	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
C
C  IBIS ROUTINE POLYREG
C
C  PURPOSE:  POLYREG PERFORMS A RIGID TRANSFORMATION OF A POLYGON
C  CORRECT FOR DIFFERENCES IN SIZE, ROTATION, ASPECT, OR SKEW.  TH
C  IS MOST EASILY SPECIFIED BY GIVING THREE INPUT TIEPOINTS AND TH
C  PONDING OUTPUT TIEPOINTS.  ALTERNATIVELY, THE USER CAN SPECIFY
C  PAIRS AND GIVE ADDITIONAL INFORMATION ON ASPECT RATIOS, AND COO
C  REVERSAL.
C  USER PARAMETERS:
C
C
C  ITIE,X1,Y1,X2,Y2 - SPECIFIES TWO TIEPOINTS IN THE INPUT PICTURE
C		NUMBERS MUST BE IN FLOATING POINT FORMAT.
C  ITIE,X1,Y1,X2,Y2,X3,Y3 - SPECIFIES THREE POINTS IN THE INPUT PI
C  OTIE,X1,Y1,X2,Y2 - SPECIFIES TWO TIEPOINTS IN THE OUTPUT PICTUR
C  OTIE,X1,Y1,X2,Y2,X3,Y3 - SPECIFIES THREE POINTS IN THE OUTPUT P
C  IUSIZE,R,S - GIVES THE ASPECT RATIO (R/S) OF THE INPUT COORDINA
C		R IS THE SIZE OF ONE UNIT IN THE FIRST COORDINATE, S
C		OF ONE UNIT IN THE SECOND COORDINATE.  THIS PARAMETER
C		WHEN ONLY TWO TIEPOINTS ARE PROVIDED.
C  OUSIZE,R,S - GIVES THE ASPECT RATIO OF THE OUTPUT COORDINATE SY
C  FLIP -	USED FOR COORDINATE REVERSAL IN THE TWO POINT CASE.
C  IGNORE,X,Y - CAUSES ALL POINTS WITH THE VALUE X,Y TO BE IGNORED
C		TRANSFORMATION.  THE DEFAULT IS TO IGNORE 0.,0.
C
C   1-87  SXP   Modified to use DGELG to solve linear system of equations.
C   3-95  AS    (CRI) MSTP S/W CONVERSION (VICAR PORTING)

	IMPLICIT NONE
	LOGICAL FLIP, XVPTST, NOPRINT, ZERO, EOF
	REAL*8 TAB(6),WORK(6,6),IH,IW,OH,OW,L,S,R1,R2,THETA1,THETA2
        REAL*8 RATIO,V51,V52,ALPHA,R,XIGNOR,YIGNOR,T,L1,S1,THETA
	REAL*4 ITIARR(6),OTIARR(6),IUSARR(2),OUSARR(2),IGNARR(2)
	REAL*4 COORD1, COORD2, EXTRA(40)
        INTEGER NITIE,NOTIE,ITIEDF,OTIEDF,COUNT,IUSIDF,OUSIDF,SKIP
        INTEGER I,J,IER,STATUS,RDGR,WRGR,GETGR,PUTGR,CLGR,PRINTCOUNT
	CHARACTER*60	STRING

      DATA IH,IW,OH,OW/4*1.D0/

C
C     GET PARAMETERS
C
        CALL IFMESSAGE('POLYREG version 6-MAR-95')

	CALL XVPARM ('ITIE',ITIARR,NITIE,ITIEDF,6)
	CALL XVPARM ('OTIE',OTIARR,NOTIE,OTIEDF,6)
	CALL XVPARM ('IUSIZE',IUSARR,COUNT,IUSIDF,2)
	CALL XVPARM ('OUSIZE',OUSARR,COUNT,OUSIDF,2)
	CALL XVP ('SKIP', SKIP, COUNT)
	CALL XVP ('IGNORE', IGNARR, COUNT)
	NOPRINT = XVPTST('NOPRINT')
	FLIP = XVPTST ('FLIP')
	XIGNOR = DBLE(IGNARR(1))
	YIGNOR = DBLE(IGNARR(2))

C		 SET UP LINEAR EQUATIONS FOR SOLUTION

	IF (NITIE .NE. NOTIE) THEN
	    CALL MABEND('NUMBER OF ITIE MUST EQUAL NUMBER OF OTIE')
	ENDIF

	IF (IUSIDF.EQ.0) THEN
	    IH = DBLE(IUSARR(1))
	    IW = DBLE(IUSARR(2))
	ENDIF
	IF (OUSIDF.EQ.0) THEN
	    OH = DBLE(OUSARR(1))
	    OW = DBLE(OUSARR(2))
	ENDIF

	DO I=1,4
	    TAB(I) = DBLE(OTIARR(I))
	ENDDO
	IF (NOTIE.EQ.6) THEN
	    TAB(5) = DBLE(OTIARR(5))
	    TAB(6) = DBLE(OTIARR(6))
	ENDIF
	DO I=1,6
	    DO J=1,6
	        WORK(I,J) = 0.D0
	    ENDDO
	ENDDO
	WORK(1,1) = DBLE(ITIARR(1))
	WORK(1,2) = DBLE(ITIARR(2))
	WORK(3,1) = DBLE(ITIARR(3))
	WORK(3,2) = DBLE(ITIARR(4))
	WORK(2,3) = WORK(1,1)
	WORK(2,4) = WORK(1,2)
	WORK(4,3) = WORK(3,1)
	WORK(4,4) = WORK(3,2)
	WORK(1,5) = 1.D0
	WORK(2,6) = 1.D0
	WORK(3,5) = 1.D0
	WORK(4,6) = 1.D0
	IF (NITIE.EQ.6) THEN
	    WORK(5,5) = 1.D0
	    WORK(6,6) = 1.D0
	    WORK(5,1) = DBLE(ITIARR(5))
	    WORK(5,2) = DBLE(ITIARR(6))
	ENDIF
	WORK(6,3) = WORK(5,1)
	WORK(6,4) = WORK(5,2)
C
C  SPECIAL CASE FOR TWO POINT POLYREG
C
	IF (NITIE .NE. 6) THEN
	    L = (WORK(3,1)-WORK(1,1))*IH
	    S = (WORK(3,2)-WORK(1,2))*IW
	    IF (FLIP) THEN
	      T = L
	      L = S
	      S = T
	    ENDIF
	    R1 = DSQRT(L*L+S*S)
	    THETA1 = DATAN2(L,S)
	    L = (TAB(3)-TAB(1))*OH
	    S = (TAB(4)-TAB(2))*OW
	    R2 = DSQRT(L*L+S*S)
	    THETA2 = DATAN2(L,S)
	    THETA = THETA2-THETA1
	    RATIO = R2/R1
	    V51 = WORK(1,1)-WORK(3,2)+WORK(1,2)
	    V52 = WORK(1,2)+WORK(3,1)-WORK(1,1)
	    ALPHA = DATAN2(V51,V52)+THETA
	    R = DSQRT(V51*V51+V52*V52)*RATIO
	    TAB(5) = R*DSIN(ALPHA)/OH
	    TAB(6) = R*DCOS(ALPHA)/OW
	    IF (FLIP) THEN
	      T = V51
	      V51 = V52
	      V52 = T
	    ENDIF
	    WORK(5,1) = V51/IH
	    WORK(5,2) = V52/IW
	    WORK(6,3) = WORK(5,1)
	    WORK(6,4) = WORK(5,2)
	ENDIF

	CALL DGELG (TAB,WORK,6,1,1.E-14,IER)
	IF (IER .NE. 0) THEN
	    CALL MABEND('SOLUTION FAILURE')
	ENDIF

C  OPEN THE INPUT AND OUTPUT GRAPHICS FILES

	STATUS = RDGR (1, 1, 2+SKIP)
        IF (STATUS .NE. 1) CALL SIGNALGR(1,STATUS,1)
	STATUS = WRGR (1, 2, 2+SKIP)
        IF (STATUS .NE. 1) CALL SIGNALGR(2,STATUS,1)

	PRINTCOUNT = 0
	IF (.NOT. NOPRINT) CALL XVMESSAGE
     *     ('       INPUT COORDINATES           OUTPUT COORDINATES',' ')

C  TRANSFORM POINTS ACCORDING TO THE SOLUTION OF THE LINEAR EQUATION

	DO WHILE (.TRUE.)
	    STATUS = GETGR (1, ZERO, EOF, COORD1, COORD2, EXTRA)
            IF (STATUS .NE. 1) CALL SIGNALGR(1,STATUS,1)
	    IF (EOF) GOTO 290
	    L = DBLE(COORD1)
	    S = DBLE(COORD2)
	    IF (DABS(L-XIGNOR)+DABS(S-YIGNOR).GT.1.D-6) THEN
		L1 = L*TAB(1)+S*TAB(2)+TAB(5)
		S1 = L*TAB(3)+S*TAB(4)+TAB(6)
		COORD1 = SNGL(L1)
		COORD2 = SNGL(S1)
	    ENDIF
	    STATUS = PUTGR (2, COORD1, COORD2, EXTRA)
            IF (STATUS .NE. 1) CALL SIGNALGR(2,STATUS,1)

	    IF (.NOT. NOPRINT .AND. PRINTCOUNT .LT. 5) THEN
		WRITE (STRING, '(F12.3,1X,F12.3,4X,F12.3,1X,F12.3)')
     *				 L,S, COORD1, COORD2
		CALL XVMESSAGE (STRING,' ')
		PRINTCOUNT = PRINTCOUNT + 1
	    ENDIF
	ENDDO

290	CONTINUE
	STATUS = CLGR (1)
        IF (STATUS .NE. 1) CALL SIGNALGR(1,STATUS,1)
	STATUS = CLGR (2)
        IF (STATUS .NE. 1) CALL SIGNALGR(2,STATUS,1)

	RETURN
	END


C     LAST UPDATE 17/07/95
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE CENTRE(VALS,NV)
      IMPLICIT NONE
C
C Purpose: Determine centre of diffraction pattern from at least three
C          points
C
C Calls   3: RDCOMF, FRPRMN, ASK
C Called by: FIX
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file
C
      INCLUDE 'FIXPAR.COM'
C
C Arguments:
C
      INTEGER NV
      REAL VALS(10)
C
C Common block:
C
      REAL XD(MAXPTS),YD(MAXPTS)
      INTEGER NDAT
      COMMON /CIRDAT/ XD,YD,NDAT
C
C External functions:
C
      REAL FUNC
      EXTERNAL FUNC,DFUNC
C
C Local variables:
C
      INTEGER I,J,K
      REAL X(3)
      REAL RESSQ,FTOL,ALPHA,TOP,DEN,DX,DY
      INTEGER ITER
      LOGICAL REPLY
C
      DATA FTOL /0.01/
C
C-----------------------------------------------------------------------
      IF(NV.EQ.0)THEN
         VALS(1) = 1.0
         VALS(2) = FLOAT(NPTS)
         NV = 2
      ELSEIF(NV.EQ.1)THEN
         IF(NINT(VALS(1)).GE.1.AND.NINT(VALS(1)).LE.NPTS)THEN
            XC = FXY(1,NINT(VALS(1)))
            YC = FXY(2,NINT(VALS(1)))
            GOTCEN = .TRUE.
C
C========Draw centre
C
            PRINT *, '500 DRAW CROSS ',XC,YC
            PRINT *, '500 CENTRE ',XC,YC
            CALL FLUSH(6)
            RETURN
         ELSE
            WRITE(6,1040)
            CALL FLUSH(6)
         ENDIF
      ENDIF
C
C========Copy relevant coordinates into work arrays
C
      K = 0
      DO 30 I=1,NV-1,2
         IF(I+1.GT.NV)VALS(I+1) = VALS(I)
         DO 40 J=NINT(VALS(I)),NINT(VALS(I+1))
            IF(J.LT.1.OR.J.GT.NPTS)THEN
               WRITE(6,1040)
               CALL FLUSH(6)
               RETURN
            ENDIF
            K = K + 1
            XD(K) = FXY(1,J)
            YD(K) = FXY(2,J)
 40      CONTINUE
 30   CONTINUE
      NDAT = K
      IF(NDAT.EQ.2)THEN
         XC = (XD(1)+XD(2))/2.0
         YC = (YD(1)+YD(2))/2.0
         GOTCEN = .TRUE.
      ELSE
C
C========Guess at centre and radius from first three points
C
         TOP = (XD(3)-XD(2))*(XD(1)-XD(3)) +
     &        (YD(3)-YD(2))*(YD(1)-YD(3))
         DEN = (XD(2)-XD(3))*(YD(2)-YD(1)) +
     &        (YD(2)-YD(3))*(XD(1)-XD(2))
         ALPHA = TOP/(2.0*DEN)
         X(1) = (XD(1)+XD(2))/2.0 + ALPHA*(YD(2)-YD(1))
         X(2) = (YD(1)+YD(2))/2.0 + ALPHA*(XD(1)-XD(2))
         X(3) = SQRT((XD(1)-X(1))**2 + (YD(1)-X(2))**2)
         WRITE(6,1050)(X(I),I=1,3)
C
C========Minimise residual using conjugate gradient method
C
         CALL FRPRMN(X,3,FTOL,ITER,RESSQ,FUNC,DFUNC)
         WRITE(6,1060)(X(I),I=1,3),ITER,SQRT(RESSQ/FLOAT(K-1))
         XC = X(1)
         YC = X(2)
         XCB = XC
         YCB = YC
         GOTCEN = .TRUE.
C
C========Draw crosses on images
C
         DO 50 I=1,NDAT
            DX = XD(I) - XC
            DY = YD(I) - YC
            DEN = SQRT(DX*DX+DY*DY)
            XD(I) = XC + DX*X(3)/DEN - 0.5
            YD(I) = YC + DY*X(3)/DEN - 0.5
            PRINT *, '500 DRAW CROSS ',XD(I),YD(I)
 50      CONTINUE
C
C========Draw circle
C
         PRINT *, '500 DRAW CIRCLE ',XC,YC,X(3)
C
C========Calculate specimen-to-detector distance if required
C
         IF(GOTWAV.AND.GOTCAL)THEN
            REPLY = .NOT.GOTSDD
            CALL ASK('700 Calculate specimen to detector distance',
     &           REPLY, 0)
            IF(REPLY)THEN
               SDD = X(3)/TAN(2.0*ASIN(WAVE/(2.0*DCAL)))
               PRINT *, '500 DISTANCE ',SDD
               WRITE(6,1080)SDD
               CALL FLUSH(6)
               GOTSDD = .TRUE.
            ENDIF
         ENDIF
      ENDIF
C
C========Draw centre
C
      PRINT *, '500 DRAW CROSS ',XC,YC
      PRINT *, '500 CENTRE ',XC,YC
      CALL FLUSH(6)
 9999 RETURN
C
 1020 FORMAT(1X,'200',
     &       1X,'Enter coordinate ranges for centre determination: ',$)
 1040 FORMAT(1X,'200',
     &       1X,'Selected point is out of range')
 1050 FORMAT(1X,'200',
     &       1X,'First estimation   X = ',F6.1,'  Y = ',F6.1,'  R = ',
     &       F6.1)
 1060 FORMAT(/1X,'200 Least-squares'/
     &       1X,'Centre  X = ',F6.1,'  Y = ',F6.1,'   Radius = ',F6.1,
     &       1X,'after ',I3,' iterations'/
     &       1X,'Residual = ',F7.3)
 1080 FORMAT(1X,'200 Specimen-to-detector distance = ',F10.1)
 2000 FORMAT(1X,'400 Numeric input only')
C-----------------------------------------------------------------------
      END


      SUBROUTINE DFPMIN(P,N,FTOL,ITER,FRET)
      PARAMETER (NMAX=50,ITMAX=200,EPS=1.E-10)
      DIMENSION P(N),HESSIN(NMAX,NMAX),XI(NMAX),G(NMAX),DG(NMAX),
     *HDG(NMAX)
      FP=FUNC(P)
      CALL DFUNC(P,G)
      DO 12 I=1,N
        DO 11 J=1,N
          HESSIN(I,J)=0.
11      CONTINUE
        HESSIN(I,I)=1.
        XI(I)=-G(I)
12    CONTINUE
      DO 24 ITS=1,ITMAX
        ITER=ITS
        CALL LINMIN(P,XI,N,FRET)
        IF(2.*ABS(FRET-FP).LE.FTOL*(ABS(FRET)+ABS(FP)+EPS))RETURN
        FP=FRET
        DO 13 I=1,N
          DG(I)=G(I)
13      CONTINUE
        FRET=FUNC(P)
        CALL DFUNC(P,G)
        DO 14 I=1,N
          DG(I)=G(I)-DG(I)
14      CONTINUE
        DO 16 I=1,N
          HDG(I)=0.
          DO 15 J=1,N
            HDG(I)=HDG(I)+HESSIN(I,J)*DG(J)
15        CONTINUE
16      CONTINUE
        FAC=0.
        FAE=0.
        DO 17 I=1,N
          FAC=FAC+DG(I)*XI(I)
          FAE=FAE+DG(I)*HDG(I)
17      CONTINUE
        FAC=1./FAC
        FAD=1./FAE
        DO 18 I=1,N
          DG(I)=FAC*XI(I)-FAD*HDG(I)
18      CONTINUE
        DO 21 I=1,N
          DO 19 J=1,N
            HESSIN(I,J)=HESSIN(I,J)+FAC*XI(I)*XI(J)
     *        -FAD*HDG(I)*HDG(J)+FAE*DG(I)*DG(J)
19        CONTINUE
21      CONTINUE
        DO 23 I=1,N
          XI(I)=0.
          DO 22 J=1,N
            XI(I)=XI(I)-HESSIN(I,J)*G(J)
22        CONTINUE
23      CONTINUE
24    CONTINUE
      PAUSE 'too many iterations in DFPMIN'
      RETURN
      END


subroutine rpn2(ixy,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)

! Riemann solver for the elasticity equations in 2d, with varying
! material properties rho, lambda, and mu
!
! waves: 4
! equations: 5
! aux fields: 5

! Conserved quantities:
!       1 sigma_11
!       2 sigma_22
!       3 sigma_12
!       4 u
!       5 v

! Auxiliary variables:
!       1  density
!       2  lamda
!       3  mu
!       4  cp
!       5  cs

! Note that although there are 5 eigenvectors, one eigenvalue
! is always zero and so we only need to compute 4 waves.
!
! solve Riemann problems along one slice of data.
!
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! Note that the i'th Riemann problem has left state qr(:,i-1)
!                                    and right state ql(:,i)
! From the basic clawpack routines, this routine is called with ql = qr
!
! This data is along a slice in the x-direction if ixy=1
!                            or the y-direction if ixy=2.
!
! Here it is assumed that auxl=auxr gives the cell values
! for this slice.
!
! On output, wave contains the waves,
!            s the speeds,
!            amdq the  left-going flux difference  A^- \Delta q
!            apdq the right-going flux difference  A^+ \Delta q
!
! Note that the waves are *not* in order of increasing lambda.
! Instead the 1- and 2-waves are the P-waves and the 3- and 4-waves
! are the S-waves.   (The 5th wave would have speed zero and is not computed.)

    implicit none

    integer, intent(in) :: ixy, maxm, meqn, mwaves, mbc, mx, maux
    double precision, intent(in) :: ql, qr, auxl, auxr
    double precision, intent(out) :: wave, s, amdq, apdq

    dimension wave( meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves, 1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension apdq(meqn, 1-mbc:maxm+mbc)
    dimension amdq(meqn, 1-mbc:maxm+mbc)
    dimension auxl(maux, 1-mbc:maxm+mbc)
    dimension auxr(maux, 1-mbc:maxm+mbc)

    integer :: ksig11, ksig22, ku, kv, i, m
    double precision :: dsig11, dsig22, dsig12, du, dv
    double precision :: alamr, amur, bulkr, cpr, csr
    double precision :: alaml, amul, bulkl, cpl, csl
    double precision :: det, a1, a2, a3, a4

    ! set ku to point to  the component of the system that corresponds
    ! to velocity in the direction of this slice, kv to the orthogonal
    ! velocity.  Similarly ksig11 and ksig22 point to normal stresses.
    ! 3rd component is always shear stress sig12.

    if (ixy.eq.1) then
        ksig11 = 1
        ksig22 = 2
        ku = 4
        kv = 5
    else
        ksig11 = 2
        ksig22 = 1
        ku = 5
        kv = 4
    endif

    ! note that notation for u and v reflects assumption that the
    ! Riemann problems are in the x-direction with u in the normal
    ! direciton and v in the orthogonal direcion, but with the above
    ! definitions of ku and kv the routine also works with ixy=2

    ! split the jump in q at each interface into waves
    ! The jump is split into leftgoing waves traveling at speeds -cp, -cs
    ! relative to the material properties to the left of the interface,
    ! and rightgoing waves traveling at speeds +cp, +cs
    ! relative to the material properties to the right of the interface,

    do i = 2-mbc, mx+mbc
        dsig11 = ql(ksig11,i) - qr(ksig11,i-1)
        dsig22 = ql(ksig22,i) - qr(ksig22,i-1)
        dsig12 = ql(3,i) - qr(3,i-1)
        du = ql(ku,i) - qr(ku,i-1)
        dv = ql(kv,i) - qr(kv,i-1)

        ! material properties in cells i (on right) and i-1 (on left):

        alamr = auxl(2,i)
        amur = auxl(3,i)
        bulkr = alamr + 2.d0*amur
        cpr = auxl(4,i)
        csr = auxl(5,i)

        alaml = auxr(2,i-1)
        amul = auxr(3,i-1)
        bulkl = alaml + 2.d0*amul
        cpl = auxr(4,i-1)
        csl = auxr(5,i-1)

        ! P-wave strengths:
        det = bulkl*cpr + bulkr*cpl
        if (det.eq.0.d0) then
            write(6,*) 'det=0 in rpn2'
            stop
        endif
        a1 = (cpr*dsig11 + bulkr*du) / det
        a2 = (cpl*dsig11 - bulkl*du) / det

        ! S-wave strengths:
        det = amul*csr + amur*csl
        if (det.eq.0.d0) then
            ! no s-waves
            a3 = 0.d0
            a4 = 0.d0
        else
            a3 = (csr*dsig12 + amur*dv) / det
            a4 = (csl*dsig12 - amul*dv) / det
        endif

        ! 5th wave has velocity 0 so is not computed or propagated.

        ! Compute the waves.

        wave(ksig11,1,i) = a1 * bulkl
        wave(ksig22,1,i) = a1 * alaml
        wave(3,1,i)  = 0.d0
        wave(ku,1,i) = a1 * cpl
        wave(kv,1,i) = 0.d0
        s(1,i) = -cpl

        wave(ksig11,2,i) = a2 * bulkr
        wave(ksig22,2,i) = a2 * alamr
        wave(3,2,i)  = 0.d0
        wave(ku,2,i) = -a2 * cpr
        wave(kv,2,i) = 0.d0
        s(2,i) = cpr

        wave(ksig11,3,i) = 0.d0
        wave(ksig22,3,i) = 0.d0
        wave(3,3,i)  = a3*amul
        wave(ku,3,i) = 0.d0
        wave(kv,3,i) = a3*csl
        s(3,i) = -csl

        wave(ksig11,4,i) = 0.d0
        wave(ksig22,4,i) = 0.d0
        wave(3,4,i)  = a4*amur
        wave(ku,4,i) = 0.d0
        wave(kv,4,i) = -a4*csr
        s(4,i) = csr

        ! compute the leftgoing and rightgoing flux differences:
        ! Note s(i,1),s(i,3) < 0   and   s(i,2),s(i,4) > 0.
        do m=1,meqn
            amdq(m,i) = s(1,i)*wave(m,1,i) + s(3,i)*wave(m,3,i)
            apdq(m,i) = s(2,i)*wave(m,2,i) + s(4,i)*wave(m,4,i)
        enddo
    enddo

    return
end subroutine rpn2


C
CXXXXNB----------------------------------------------------------------ENNNNNNNN
      SUBROUTINE SMTH25(UNSM,SF,SMTH)
C
C$$$  SUBPROGRAM DOCUMENTATION  BLOCK
C                .      .    .                                       .
C SUBPROGRAM:    SMTH25                  SMOOTHES DATA
C   PRGMMR: L. D. BURROUGHS  ORG: W/NMC21    DATE: 03-03-09
C
C ABSTRACT: SMOOTHES DATA AT A LOCATION (I,J) BY TAKING THE WEIGHTED
C   AVERAGE OF THE DATA AT THE 16 SURROUNDING POINTS AND (I,J).
C
C PROGRAM HISTORY LOG:
C   03-03-09  L. D. BURROUGHS
C
C USAGE:    CALL SMTH25(UNSM,I,J,SF,SMTH)
C
C   INPUT ARGUMENT LIST:
C     UNSM(,)  - FIELD OF DATA TO BE SMOOTHED - R*4
C     SF       - SMOOTHER NUMBER - R*4
C                0 NO SMOOTHING DONE. -1 0 1  -2-1 0 1 2
C                1  5 POINT SMOOTHER>1   .   2     1
C                                    0 . . . 1     2
C                                   -1   .   0 1 2 3 2 1
C                2  9 POINT SMOOTHER ======>-1     2        -1 0 1
C                                           -2     1       1 . . .
C                3  9 POINT SMOOTHER =====================>0 . . .
C                                        -3-2-1 0 1 2 3   -1 . . .
C                                       3       .         -4-3-2-1 0 1 2 3 4
C                4 13 POINT SMOOTHER ==>2       .        4         .
C                                       1       .        3         .
C                                       0 . . . . . . .  2         .
C                                      -1       .        1         .
C                                      -2       .        0 . . . . . . . . .
C                                      -3       .       -1         .
C                5 17 POINT SMOOTHER ==================>-2         .
C                                        -2-1 0 1 2     -3         .
C                                       2 . . . . .     -4         .
C                6 25 POINT SMOOTHER    1 . . . . .
C                                       0 . . . . .
C                                      -1 . . . . .  -1 0 1
C                                      -2 . . . . . 1 1 2 1
C                7  9 POINT WEIGHTED SMOOTHER =====>0 2 3 2
C                                                  -1 1 2 1
C
C   OUTPUT ARGUMENT LIST:
C     SMTH     - THE SMOOTHED VALUE MATRIX R*4
C
C   INPUT FILES:
C     NONE
C
C   OUTPUT FILES:
C     NONE
C
C   SUBPROGRAMS CALLED:
C
C     UNIQUE:    - NONE
C
C     LIBRARY:
C       W3LIB    - NONE
C
C       IMSL     - NONE
C
C       SPECIAL  - NONE
C
C REMARKS: NONE
C
C     VARIABLES:
C       INPUT    - NONE
C
C       INTERNAL - SUMIP2     = SUM OF VALUES FROM JM2 TO JP2 ON ROW IP2 FOR
C                               LOCATION (I,J)
C                  SUMIP1     = SUM OF VALUES FROM JM2 TO JP2 ON ROW IP1 FOR
C                               LOCATION (I,J)
C                  SUMI       = SUM OF VALUES FROM JM2 TO JP2 ON ROW I FOR
C                               LOCATION (I,J)
C                  SUMIM1     = SUM OF VALUES FROM JM2 TO JP2 ON ROW IM1 FOR
C                               LOCATION (I,J)
C                  SUMIM2     = SUM OF VALUES FROM JM2 TO JP2 ON ROW IM2 FOR
C                               LOCATION (I,J)
C                  AVG        = AVERAGE VALUE OF THE SUMS ADDED TOGETHER
C                               DIVIDED BY THE NUMBER OF POINTS (25)
C
C       OUTPUT   - NONE
C
C ATTRIBUTES:
C   LANGUAGE: VS FORTRAN
C   MACHINE:  NAS
C
C$$$
CNNNNXB----------------------------------------------------------------ENNNNNNNN
      IMPLICIT none
      SAVE

! Arguments
      REAL SF, UNSM(361,181),SMTH(361,181)
C
! Local
      REAL*4 ISURSM,JSURSM
      INTEGER i, j
      INTEGER ip1, ip2, ip3, ip4
      INTEGER im1, im2, im3, im4
      INTEGER jp1, jp2, jp3, jp4
      INTEGER jm1, jm2, jm3, jm4
      REAL sumip1, sumi, sumim1
      REAL sumip2, sumim2

C
      DO J=1,181
         DO I=1,361
            IF(SF.LT.0..OR.SF.GT.7.)THEN
               SMTH(I,J)=UNSM(I,J)
            ENDIF
            IP1=I+1
            IP2=I+2
            IP3=I+3
            IP4=I+4
            IM1=I-1
            IM2=I-2
            IM3=I-3
            IM4=I-4
            JP1=J+1
            JP2=J+2
            JP3=J+3
!Original -- typo noticed by Liz Orelup, lizo@oceanweather.com            JP2=4+4
            JP4=J+4
            JM1=J-1
            JM2=J-2
            JM3=J-3
            JM4=J-4
            IF(SF.EQ.0.)THEN
               SMTH(I,J)=UNSM(I,J)
            ENDIF
CNNNNXB----------------------------------------------------------------ENNNNNNNN
            IF(SF.EQ.1.)THEN
               IF((I.LT.2.OR.I.GT.360).OR.(J.LT.2.OR.J.GT.180))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  ISURSM=UNSM(IP1,J)+UNSM(IM1,J)
                  JSURSM=UNSM(I,JP1)+UNSM(I,JM1)
                  SMTH(I,J)=(ISURSM+JSURSM+UNSM(I,J))/5.
               ENDIF
            ENDIF
            IF(SF.EQ.2.)THEN
               IF((I.LT.3.OR.I.GT.359).OR.(J.LT.3.OR.J.GT.179))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  ISURSM=UNSM(IP2,J)+2*UNSM(IP1,J)+2*UNSM(IM1,J)+
     1                   UNSM(IM2,J)
                  JSURSM=UNSM(I,JP2)+2*UNSM(I,JP1)+2*UNSM(I,JM1)+
     1                   UNSM(I,JM2)
                  SMTH(I,J)=(ISURSM+JSURSM+3*UNSM(I,J))/15.
               ENDIF
            ENDIF
            IF(SF.EQ.3.)THEN
               IF((I.LT.3.OR.I.GT.359).OR.(J.LT.3.OR.J.GT.179))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  SUMIP1=UNSM(IP1,JP1)+UNSM(IP1,J)+UNSM(IP1,JM1)
                  SUMI=UNSM(I,JP1)+UNSM(I,J)+UNSM(I,JM1)
                  SUMIM1=UNSM(IM1,JP1)+UNSM(IM1,J)+UNSM(IM1,JM1)
                  SMTH(I,J)=(SUMIP1+SUMI+SUMIM1)/9.
               ENDIF
            ENDIF
CNNNNXB----------------------------------------------------------------ENNNNNNNN
            IF(SF.EQ.4.)THEN
               IF((I.LT.4.OR.I.GT.358).OR.(J.LT.4.OR.J.GT.178))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  ISURSM=UNSM(IP3,J)+UNSM(IP2,J)+UNSM(IP1,J)+
     1                   UNSM(IM1,J)+UNSM(IM2,J)+UNSM(IM3,J)
                  JSURSM=UNSM(I,JP3)+UNSM(I,JP2)+UNSM(I,JP1)+
     1                   UNSM(I,JM1)+UNSM(I,JM2)+UNSM(I,JM3)
                  SMTH(I,J)=(ISURSM+JSURSM+UNSM(I,J))/13.
               ENDIF
            ENDIF
            IF(SF.EQ.5.)THEN
               IF((I.LT.5.OR.I.GT.357).OR.(J.LT.5.OR.J.GT.177))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  ISURSM=UNSM(IP4,J)+UNSM(IP3,J)+UNSM(IP2,J)+
     1                   UNSM(IP1,J)+UNSM(IM1,J)+UNSM(IM2,J)+
     2                   UNSM(IM3,J)+UNSM(IM4,J)
                  JSURSM=UNSM(I,JP4)+UNSM(I,JP3)+UNSM(I,JP2)+
     1                   UNSM(I,JP1)+UNSM(I,JM1)+UNSM(I,JM2)+
     2                   UNSM(I,JM3)+UNSM(I,JM4)
                  SMTH(I,J)=(ISURSM+JSURSM+UNSM(I,J))/17.
               ENDIF
            ENDIF
CNNNNXB----------------------------------------------------------------ENNNNNNNN
            IF(SF.EQ.6.)THEN
               IF((I.LT.6.OR.I.GT.356).OR.(J.LT.6.OR.J.GT.176))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  SUMIP2=UNSM(IP2,JP2)+UNSM(IP2,JP1)+UNSM(IP2,J)+
     1                   UNSM(IP2,JM1)+UNSM(IP2,JM2)
                  SUMIP1=UNSM(IP1,JP2)+UNSM(IP1,JP1)+UNSM(IP1,J)+
     1                   UNSM(IP1,JM1)+UNSM(IP1,JM2)
                  SUMI=UNSM(I,JP2)+UNSM(I,JP1)+UNSM(I,J)+UNSM(I,JM1)+
     1                 UNSM(I,JM2)
                  SUMIM1=UNSM(IM1,JP2)+UNSM(IM1,JP1)+UNSM(IM1,J)+
     1                   UNSM(IM1,JM1)+UNSM(IM1,JM2)
                  SUMIM2=UNSM(IM2,JP2)+UNSM(IM2,JP1)+UNSM(IM2,J)+
     1                   UNSM(IM2,JM1)+UNSM(IM2,JP2)
                  SMTH(I,J)=(SUMIP2+SUMIP1+SUMI+SUMIM1+SUMIM2)/25.
               ENDIF
            ENDIF
            IF(SF.EQ.7.)THEN
               IF((I.LT.3.OR.I.GT.359).OR.(J.LT.3.OR.J.GT.179))THEN
                  SMTH(I,J)=UNSM(I,J)
               ELSE
                  SUMIP1=UNSM(IP1,JP1)+2*UNSM(IP1,J)+UNSM(IP1,JM1)
                  SUMI=2*UNSM(I,JP1)+2*UNSM(I,J)+2*UNSM(I,JM1)
                  SUMIM1=UNSM(IM1,JP1)+2*UNSM(IM1,J)+UNSM(IM1,JM1)
                  SMTH(I,J)=(SUMIP1+SUMI+SUMIM1)/14.
               ENDIF
            ENDIF
         ENDDO
      ENDDO
      RETURN
      END


c*************************************************************************
c                        DRIFT_KEPU_FCHK.F
c*************************************************************************
c Returns the value of the function f of which we are trying to find the root
c in universal variables.
c
c             Input:
c                 dt            ==>  time step (real scalar)
c                 r0            ==>  Distance between `Sun' and particle
c                                     (real scalar)
c                 mu            ==>  Reduced mass of system (real scalar)
c                 alpha         ==>  Twice the binding energy (real scalar)
c                 u             ==>  Vel. dot radial vector (real scalar)
c                 s             ==>  Approx. root of f
c             Output:
c                 f             ==>  function value ( = 0 if O.K.) (integer)
c
c Author:  Martin Duncan
c Date:    March 12/93
c Last revision: March 12/93

      subroutine drift_kepu_fchk(dt,r0,mu,alpha,u,s,f)

c...  Inputs:
      real*8 dt,r0,mu,alpha,u,s

c...  Outputs:
      real*8 f

c...  Internals:
      real*8  x,c0,c1,c2,c3

c----
c...  Executable code

        x=s*s*alpha
        call drift_kepu_stumpff(x,c0,c1,c2,c3)
        c1=c1*s
        c2 = c2*s*s
        c3 = c3*s*s*s
        f = r0*c1 + u*c2 + mu*c3 - dt

        return
        end     !   drift_kepu_fchk
c-------------------------------------------------------------------


      program wind
c
      integer     nx, ny
      real        radius, umax, dxy
c
      parameter ( nx     = 43 )
      parameter ( radius = 100. )
      parameter ( umax   = 35. )
      parameter ( dxy    = 25. )
c
      integer     ixyc, ix, iy
      real        distx, disty, dist, u10
      real        u(nx,nx), v(nx,nx)
c
      ixyc   = 1 + nx/2
c
      do 110, ix=1, nx
        do 100, iy=1, nx
          distx  = dxy * real(ix-ixyc)
          disty  = dxy * real(iy-ixyc)
          dist   = sqrt ( distx**2 + disty**2 )
          if ( dist .le. radius ) then
              u10    = umax * dist / radius
            else
              u10    = umax * radius / dist
            endif
          if ( dist .gt. 0.1*dxy ) then
              u(ix,iy) = - u10 * disty / dist
              v(ix,iy) =   u10 * distx / dist
            else
              u(ix,iy) = 0.
              v(ix,iy) = 0.
            end if
  100     continue
  110   continue
c
      open(10,file='ww3_prep_wind.inp',status='unknown')
c
      write(10,'(a)') "$ WAVEWATCH III Wind preprocessing"
      write(10,'(a)') "$ --------------------------------"
      write(10,'(a)') "  'WND' 'AI' F T"
      write(10,'(a)') "  19680606 000000"
      write(10,'(a)') "$"
      write(10,'(a)') "  'UNIT' 2 1 '(..T..)' '(..F..)'"
      write(10,'(a)') "  10 'dummy_name '"
      write(10,'(a)') "$"
c
      write (10,'(10f8.2)') ((u(ix,iy),ix=1,nx),iy=1,nx)
      write (10,'(10f8.2)') ((v(ix,iy),ix=1,nx),iy=1,nx)
c
      close(10)
c
      end


Subroutine hypmeshgen(Xb,Yb,Xg,Yg,ra,fd,Ip,Jp,opentrail)
implicit none
real(8),parameter::Pi=3.1415926535897932e+0
logical(1) opentrail
integer i,j,l,Ip,Jp,jtran,Jmax
real(8) fd,dis,nua,nuj,theta,epsic
real(8) Xb(Ip),Yb(Ip),ra(Jp)
real(8) Xg(Ip,Jp),Yg(Ip,Jp)
real(8) axE1,axW1,axP1,ayE1,ayW1,ayP1,b1,axE2,axW2,axP2,ayE2,ayW2,ayP2,b2,Se,a,cosa,df,txplus,txminus,typlus,tyminus,tx,ty,nx,ny,&
dsp,dsm,dsp0,dsm0,Xgk,Ygk,Xga,Yga,Det,Xgkm,Ygkm,Xgam,Ygam,Detm,epsi,stab1,stab2,N
real(8) V(Ip),V0(Ip),Xg0(Ip),Yg0(Ip),Xg00(Ip),Yg00(Ip),d(Ip),d0(Ip)
real(8) Ap(2,2,Ip),Aw(2,2,Ip),Ae(2,2,Ip),B(2,Ip),X(2,Ip)

Xg(:,1)=Xb
Yg(:,1)=Yb
Jmax=Jp
jtran=int(3*Jmax/4)
dis=fd
nua=2./3
if(opentrail) then
 theta=6
else
 theta=1
end if
epsic=1
DO j=2,Jp
 dis=dis*ra(j)
 nuj=2**(2-j)
 Xg0=Xg(:,j-1)
 Yg0=Yg(:,j-1)
 if(j>=3) then
  Xg00=Xg(:,j-2)
  Yg00=Yg(:,j-2)
 else
  Xg00=Xg0
  Yg00=Yg0
 end if
 DO i=2,Ip-1
  V(i)=sqrt((Xg0(i+1)-Xg0(i-1))**2+(Yg0(i+1)-Yg0(i-1))**2)*dis/2
 end DO
 DO l=1,j-2
  DO i=2,Ip-1
  if(i==2) then
   V(i)=(1-nua)*V(i)+nua*0.5*(V(i+1)+V(i))
  else if(i==Ip-1) then
   V(i)=(1-nua)*V(i)+nua*0.5*(V(i)+V(i-1))
  else
   V(i)=(1-nua)*V(i)+nua*0.5*(V(i+1)+V(i-1))
  end if
  end DO
 end DO
 if(j==2) then
  V0=V
 end if
 DO i=2,Ip-1
  dsp=sqrt((Xg0(i+1)-Xg0(i))**2+(Yg0(i+1)-Yg0(i))**2)
  dsm=sqrt((Xg0(i-1)-Xg0(i))**2+(Yg0(i-1)-Yg0(i))**2)
  dsp0=sqrt((Xg00(i+1)-Xg00(i))**2+(Yg00(i+1)-Yg00(i))**2)
  dsm0=sqrt((Xg00(i-1)-Xg00(i))**2+(Yg00(i-1)-Yg00(i))**2)
  d(i)=(dsp0+dsm0)/(dsp+dsm)
 end DO
 if(j-1>jtran.and.maxval(d)-maxval(d0)<0.and.jtran==int(3*Jmax/4)) then
  jtran=j-1
 end if
 if(j==2) then
  Se=sqrt(1./(Jmax-1))
 else if(j-1<=jtran) then
  Se=sqrt((j-2.)/(Jmax-1))
 else if(j-1>jtran) then
  Se=sqrt((jtran-1.)/(Jmax-1))
 end if
 DO i=2,Ip-1
  dsp=sqrt((Xg0(i+1)-Xg0(i))**2+(Yg0(i+1)-Yg0(i))**2)
  dsm=sqrt((Xg0(i-1)-Xg0(i))**2+(Yg0(i-1)-Yg0(i))**2)
  Xgk=(Xg0(i+1)-Xg0(i-1))/2
  Ygk=(Yg0(i+1)-Yg0(i-1))/2
  Det=Xgk**2+Ygk**2
  Xga=-Ygk*V0(i)/Det
  Yga=Xgk*V0(i)/Det
  txplus=(Xg0(i+1)-Xg0(i))/dsp
  typlus=(Yg0(i+1)-Yg0(i))/dsp
  txminus=(Xg0(i-1)-Xg0(i))/dsm
  tyminus=(Yg0(i-1)-Yg0(i))/dsm
  tx=txplus-txminus
  ty=typlus-tyminus
  Xgkm=(dsp+dsm)*tx/2
  Ygkm=(dsp+dsm)*ty/2
  Detm=Xgkm**2+Ygkm**2
  Xgam=-Ygkm*V0(i)/Detm
  Ygam=Xgkm*V0(i)/Detm
  Xga=nuj*Xgam+(1-nuj)*Xga
  Yga=nuj*Ygam+(1-nuj)*Yga
  df=max(d(i)**(2/Se),0.1)
  N=sqrt((Xga**2+Yga**2)/Det)
  nx=-ty/sqrt(tx**2+ty**2)
  ny=tx/sqrt(tx**2+ty**2)
  cosa=nx*txplus+ny*typlus
  if(acos(cosa)>=0.and.acos(cosa)<=Pi/2) then
   a=1/(1-cosa**2)
  else
   a=1
  end if
  epsi=epsic*N*Se*df*a
  stab1=epsi*((Xg0(i+1)+Xg0(i-1)-2*Xg0(i))-(Xg00(i+1)+Xg00(i-1)-2*Xg00(i)))
  stab2=epsi*((Yg0(i+1)+Yg0(i-1)-2*Yg0(i))-(Yg00(i+1)+Yg00(i-1)-2*Yg00(i)))
  ayW1=(1+theta)*(Xgk*Yga+Ygk*Xga)/Det/2
  ayE1=-(1+theta)*(Xgk*Yga+Ygk*Xga)/Det/2
  axW1=(1+theta)*(Xgk*Xga-Ygk*Yga)/Det/2+2*epsi
  axE1=-(1+theta)*(Xgk*Xga-Ygk*Yga)/Det/2+2*epsi
  axP1=1+4*epsi
  ayP1=0
  b1=-Ygk*V(i)/Det-stab1
  ayW2=(1+theta)*(Ygk*Yga-Xgk*Xga)/Det/2+2*epsi
  ayE2=-(1+theta)*(Ygk*Yga-Xgk*Xga)/Det/2+2*epsi
  axW2=(1+theta)*(Xgk*Yga+Ygk*Xga)/Det/2
  axE2=-(1+theta)*(Xgk*Yga+Ygk*Xga)/Det/2
  axP2=0
  ayP2=1+4*epsi
  b2=Xgk*V(i)/Det-stab2
  Ap(1,1,i)=axP1
  Aw(1,1,i)=axW1
  Ae(1,1,i)=axE1
  Ap(1,2,i)=ayP1
  Aw(1,2,i)=ayW1
  Ae(1,2,i)=ayE1
  Ap(2,1,i)=axP2
  Aw(2,1,i)=axW2
  Ae(2,1,i)=axE2
  Ap(2,2,i)=ayP2
  Aw(2,2,i)=ayW2
  Ae(2,2,i)=ayE2
  B(1,i)=b1
  B(2,i)=b2
 end DO
 Ap(1,1,1)=1
 Aw(1,1,1)=0
 Ae(1,1,1)=0
 Ap(1,2,1)=0
 Aw(1,2,1)=0
 Ae(1,2,1)=0
 Ap(2,1,1)=0
 Aw(2,1,1)=0
 Ae(2,1,1)=0
 Ap(2,2,1)=1
 Aw(2,2,1)=0
 Ae(2,2,1)=1
 Ap(1,1,Ip)=1
 Aw(1,1,Ip)=0
 Ae(1,1,Ip)=0
 Ap(1,2,Ip)=0
 Aw(1,2,Ip)=0
 Ae(1,2,Ip)=0
 Ap(2,1,Ip)=0
 Aw(2,1,Ip)=0
 Ae(2,1,Ip)=0
 Ap(2,2,Ip)=1
 Aw(2,2,Ip)=1
 Ae(2,2,Ip)=0
 B(1,1)=0
 B(2,1)=0
 B(1,Ip)=0
 B(2,Ip)=0
 Call BlockTDMA(Ap,Aw,Ae,B,X,2,Ip)
 Xg(:,j)=Xg0+X(1,:)
 Yg(:,j)=Yg0+X(2,:)
 V0=V
 d0=d
end DO

end Subroutine hypmeshgen


      subroutine trncap(effsh,qs,ielmt,tc)
c
c     + + + PURPOSE + + +
c
c     SR TRNCAP computes transport capacity based on new
c     potential sediment load for each particle class.
c
c     Called from: SRS CASE34, CHNRT, DETACH, ENDDET
c     Author(s): Ascough II, R. van der Zweep, V. Lopes
c     Reference in User Guide:
c
c     Version:
c     Date recoded:
c     Recoded by: Jim Ascough II
c
c     + + + KEYWORDS + + +
c
c     + + + PARAMETERS + + +
c
      include 'pmxprt.inc'
      include 'pmxelm.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
c
      real effsh, qs(mxpart), tc(mxpart)
      integer ielmt
c
c     + + + ARGUMENT DEFINITIONS + + +
c
c     effsh      -
c     qs(mxpart) -
c     tc(mxpart) -
c     ielmt      -
c
c     + + + COMMON BLOCKS + + +
c
      include 'cchcon.inc'
      include 'cchprt.inc'
c
c     + + + LOCAL VARIABLES + + +
c
      real ws(mxpart), wsqrat(mxpart), coef(mxpart), ycrit(mxpart),
     1    delta(mxpart), sigma(mxpart), p(mxpart), dltrat(mxpart), a,
     1    excap, reyn, shield, smdrat, smdrqt, t, vstar
      integer flagd1, flagd2, flagd3, k
c
c     + + + LOCAL DEFINITIONS + + +
c
c     Real Variables
c
c     ws(mxpart)     -
c     wsqrat(mxpart) -
c     coef(mxpart)   -
c     ycrit(mxpart)  -
c     delta(mxpart)  -
c     sigma(mxpart)  -
c     p(mxpart)      -
c     dltrat(mxpart) -
c     a              -
c     excap          -
c     reyn           -
c     shield         -
c     smdrat         -
c     smdrqt         -
c     t              -
c     vstar          -
c
c     Integer Variables
c
c     flagd1 -
c     flagd2 -
c     flagd3 -
c     k      -
c
c     + + + SAVES + + +
c
c     + + + SUBROUTINES CALLED + + +
c
c     shield
c
c     + + + DATA INITIALIZATIONS + + +
c
c     + + + END SPECIFICATIONS + + +
c
c
      vstar = sqrt(effsh/msdh2o)
      coef(cnpart) = vstar * agrav * msdh2o
c
      t = 0.0
c
      do 10 k = 1, cnpart
        coef(k) = coef(cnpart) * crdia(k,ielmt) * crspg(k)
   10 continue
c
      do 20 k = 1, cnpart
c
        if (qs(k).eq.0.0) qs(k) = 1.0e-10
        reyn = vstar * crdia(k,ielmt) / knvis
        ycrit(k) = shield(reyn)
        delta(k) = (vstar**2/(crspg(k)-1.0)/agrav/crdia(k,ielmt)/
     1      ycrit(k)) - 1.0
c
        if (delta(k).le.0.0) then
          delta(k) = 0.0
          p(k) = 0.0
        else
          sigma(k) = delta(k) * 2.45 * crspg(k) ** (-0.4) *
     1        sqrt(ycrit(k))
          p(k) = yalcon * delta(k) * (1.0-1.0/sigma(k)*
     1        alog(1.0+sigma(k)))
        end if
c
        t = t + delta(k)
   20 continue
c
      if (t.eq.0.0) t = 1000.0
c
      do 30 k = 1, cnpart
        dltrat(k) = delta(k) / t
c       ws(k)     = p(k)*dltrat(k)*coef(k)
        ws(k) = p(k) * dltrat(k) * coef(k)
   30 continue
c
   40 continue
c
      flagd1 = 0
      flagd2 = 0
      flagd3 = 0
c
      do 50 k = 1, cnpart
        wsqrat(k) = ws(k) / qs(k)
        if (wsqrat(k).gt.1.0) flagd3 = flagd3 + 1
        if (wsqrat(k).ge.1.0) flagd1 = flagd1 + 1
        if (wsqrat(k).le.1.0) flagd2 = flagd2 + 1
   50 continue
c
      if (flagd2.ne.cnpart) then
c
        if (flagd3.ne.cnpart) then
          if (flagd1.eq.cnpart) go to 100
          go to 70
        end if
c
      end if
c
      do 60 k = 1, cnpart
        tc(k) = ws(k)
   60 continue
c
      return
c
   70 continue
c
      smdrqt = 0.0
      smdrat = 0.0
c
      do 80 k = 1, cnpart
c
        if (wsqrat(k).ge.1.0) then
          smdrqt = smdrqt + qs(k) / coef(k) / p(k)
          ws(k) = qs(k)
        else
          if (wsqrat(k).lt.1.0) smdrat = smdrat + dltrat(k)
        end if
c
   80 continue
c
      excap = 1.0 - smdrqt
c
      do 90 k = 1, cnpart
        if (smdrat.eq.0.0) smdrat = 1000000.0
        if (wsqrat(k).lt.1.0) ws(k) = dltrat(k) / smdrat * excap *
     1      p(k) * coef(k)
   90 continue
c
      go to 40
c
  100 continue
c
      smdrat = 0.0
c
      do 110 k = 1, cnpart
        smdrat = smdrat + qs(k) / (coef(k)*p(k))
  110 continue
c
      a = 1.0 / smdrat
      if ((a.gt.0.9999900).and.(a.lt.1.0000099)) a = 1.000000
c
      do 120 k = 1, cnpart
        tc(k) = a * qs(k)
  120 continue
c
      return
      end


C
C...NLO PARAMETRIZATION (DIS) :
C
      SUBROUTINE PHO_DOR94DI(X,Q2,Uv,Dv,Del,Udb,Sb,Gl)
      IMPLICIT NONE
      DOUBLE PRECISION ad , ae , ag , agx , akd , ake , akg , aks ,
     &                 aku , akx , alg , als , alx , as , au , bd , be ,
     &                 beg , bes , bex
      DOUBLE PRECISION bg , bgx , bkd , bke , bkg , bku , bkx , bs ,
     &                 bu , cd , ce , cg , cu , cx , dd , de , Del ,
     &                 dg , ds , dst
      DOUBLE PRECISION du , Dv , dx , eg , esg , ess , est , esx , ex ,
     &                 Gl , lam2 , mu2 , nd , ne , nu , PHO_DOR94FS ,
     &                 PHO_DOR94FV , PHO_DOR94FW , Q2 , s
      DOUBLE PRECISION s2 , s3 , Sb , Udb , Uv , X
      SAVE

      mu2 = 0.34
      lam2 = 0.248*0.248
      s = LOG(LOG(Q2/lam2)/LOG(mu2/lam2))
      ds = SQRT(s)
      s2 = s*s
      s3 = s2*s
C...UV :
      nu = 2.484 + 0.116*s + 0.093*s2
      aku = 0.563 - 0.025*s
      bku = 0.054 + 0.154*s
      au = -0.326 - 0.058*s - 0.135*s2
      bu = -3.322 + 8.259*s - 3.119*s2 + 0.291*s3
      cu = 11.52 - 12.99*s + 3.161*s2
      du = 2.808 + 1.400*s - 0.557*s2 + 0.119*s3
      Uv = PHO_DOR94FV(X,nu,aku,bku,au,bu,cu,du)
C...DV :
      nd = 0.156 - 0.017*s
      akd = 0.299 - 0.022*s
      bkd = 0.259 - 0.015*s
      ad = 3.445 + 1.278*s + 0.326*s2
      bd = -6.934 + 37.45*s - 18.95*s2 + 1.463*s3
      cd = 55.45 - 69.92*s + 20.78*s2
      dd = 3.577 + 1.441*s - 0.683*s2 + 0.179*s3
      Dv = PHO_DOR94FV(X,nd,akd,bkd,ad,bd,cd,dd)
C...DEL :
      ne = 0.099 + 0.019*s + 0.002*s2
      ake = 0.419 - 0.013*s
      bke = 1.064 - 0.038*s
      ae = -44.00 + 98.70*s - 14.79*s2
      be = 28.59 - 40.94*s - 13.66*s2 + 2.523*s3
      ce = 84.57 - 108.8*s + 31.52*s2
      de = 7.469 + 2.480*s - 0.866*s2
      Del = PHO_DOR94FV(X,ne,ake,bke,ae,be,ce,de)
C...UDB :
      alx = 1.215
      bex = 0.466
      akx = 0.326 + 0.150*s
      bkx = 0.956 + 0.405*s
      agx = 0.272
      bgx = 3.794 - 2.359*ds
      cx = 2.014
      dx = 7.941 + 0.534*ds - 0.940*s + 0.410*s2
      ex = 3.049 + 1.597*s
      esx = 4.396 - 4.594*ds + 3.268*s
      Udb = PHO_DOR94FW(X,s,alx,bex,akx,bkx,agx,bgx,cx,dx,ex,esx)
C...SB :
      als = 0.175
      bes = 0.344
      aks = 1.415 - 0.641*ds
      as = 0.580 - 9.763*ds + 6.795*s - 0.558*s2
      bs = 5.617 + 5.709*ds - 3.972*s
      dst = 13.78 - 9.581*s + 5.370*s2 - 0.996*s3
      est = 4.546 + 0.372*s2
      ess = 5.053 - 1.070*s + 0.805*s2
      Sb = PHO_DOR94FS(X,s,als,bes,aks,as,bs,dst,est,ess)
C...GL :
      alg = 1.258
      beg = 1.846
      akg = 2.423
      bkg = 2.427 + 1.311*s - 0.153*s2
      ag = 25.09 - 7.935*s
      bg = -14.84 - 124.3*ds + 72.18*s
      cg = 590.3 - 173.8*s
      dg = 5.196 + 1.857*s
      eg = -1.648 + 3.988*s - 0.432*s2
      esg = 3.232 - 0.542*s
      Gl = PHO_DOR94FW(X,s,alg,beg,akg,bkg,ag,bg,cg,dg,eg,esg)

      END SUBROUTINE


!     polynomial fitting for {p,r}
!     two steps: 1st global linear fitting; 2nd local fitting with basis up to third order
      subroutine fit(am,x,p,r,w,ndim,ntr,u,du,ap,fr)

      implicit real*8(a-h, o-z)

      integer*4                  :: ntr,ndim
!      integer*4, parameter        :: nb = ndim+1
      real*8, dimension(ntr)      :: w,u
      real*8, dimension(ndim)     :: am
      real*8, dimension(ndim,ntr) :: x,p,r,du,fr,ap,ar
      real*8, dimension(ndim,ndim,ntr) :: ddp,ddr,dp,dr

      real*8 f(ndim+1,ntr),f2(4),df2(4),ddf2(4),s1(ndim+1,ndim+1),s2(4,4),cp(ndim+1,ndim), &
             mat(ndim+1,ndim+1),cr(ndim+1,ndim),cpr(4,2)
      integer info

!---------matrix S1 & c for linear fitting------------------
      nb = ndim+1
      cp = 0d0
      cr = 0d0
      s1 = 0d0
      err = 0d0

      call basis(Ndim,Ntr,x,f)

      print *,'tag1'

      do j = 1,ndim+1
        do k = 1,ndim
          do i = 1,ntr
            print *,'here'
            cp(j,k) = cp(j,k)+f(j,i)*p(k,i)*w(i)
            cr(j,k) = cr(j,k)+f(j,i)*r(k,i)*w(i)
          enddo
        enddo
      enddo

      print *,'tag2'

      do k1=1,nb
        do k2=1,nb
          do i=1,ntr
            s1(k1,k2) = s1(k1,k2)+f(k1,i)*f(k2,i)*w(i)
          enddo
        enddo
      enddo

      print *,'tag3'
!---------------solve matrix M*c = f*p-------------
      mat = s1
      call dposv('U',nb,ndim,mat,nb,cp,nb,INFO)
      if(info/=0) then
        write(*,*) 'linear fitting of p failed.'
        stop
      endif
!-------------same for r--------------------------
      mat = s1
      call dposv('U',nb,ndim,mat,nb,cr,nb,INFO)
      if(info/=0) then
        write(*,*) 'linear fitting of r failed.'
        stop
      endif

      print *,'tag4'
!-------------output for {ap,ar}--------------------
      dp = 0d0
      ap = 0d0
      ar = 0d0
      dr = 0d0
      ddp = 0.d0
      ddr = 0.d0

      do i=1,ntr
        do j=1,ndim
          do k=1,nb
            ap(j,i) = ap(j,i)+cp(k,j)*f(k,i)
            ar(j,i) = ar(j,i)+cr(k,j)*f(k,i)
          enddo
        enddo
      enddo
!------first-order derivative of p,r, second order is 0 for linear fitting---------------
      do i=1,ntr
        do j=1,ndim
          do k=1,ndim
            dp(k,j,i) = cp(k,j)
            dr(k,j,i) = cr(k,j)
          enddo
        enddo
      enddo

!---------------------------------------
!     2nd fitting for each DoF
!---------------------------------------
      dimloop:do j=1,ndim

        s2 = 0d0
        cpr = 0d0

!        do i=1,ntr
!          f2 = (/x(j,i),x(j,i)**2,x(j,i)**3,1d0/)
!          df2 = (/1d0,2d0*x(j,i),3d0*x(j,i)**2,0d0/)
!        enddo

        do k=1,4
          do i=1,ntr
          f2 = (/x(j,i),x(j,i)**2,x(j,i)**3,1d0/)
            cpr(k,1) = cpr(k,1)+(p(j,i)-ap(j,i))*f2(k)*w(i)
            cpr(k,2) = cpr(k,2)+(r(j,i)-ar(j,i))*f2(k)*w(i)
          enddo
        enddo

          do m=1,4
            do n=1,4
              do i=1,ntr
              f2 = (/x(j,i),x(j,i)**2,x(j,i)**3,1d0/)
              s2(m,n) = s2(m,n)+f2(m)*f2(n)*w(i)
            enddo
          enddo
        enddo

        call dposv('U',4,2,s2,4,cpr,4,info)
        if(info/=0) then
          write(*,*) 'cubic fitting of r failed.'
          stop
        endif

!------second order derivative only contain diagonal elements--------------------
!-------4-dim array ddp(ndim,ndim,ndim,ntraj) contract to ddp(ndim,ndim,ntraj)----
      do i=1,ntr
          f2 = (/x(j,i),x(j,i)**2,x(j,i)**3,1d0/)
          df2 = (/1d0,2d0*x(j,i),3d0*x(j,i)**2,0d0/)
          ddf2 = (/0d0,2d0,6d0*x(j,i),0d0/)

        do k=1,4
          ap(j,i) = ap(j,i)+cpr(k,1)*f2(k)
          dp(j,j,i) = dp(j,j,i)+cpr(k,1)*df2(k)
          ddp(j,j,i) = ddp(j,j,i)+cpr(k,1)*ddf2(k)

          ar(j,i) = ar(j,i)+cpr(k,2)*f2(k)
          dr(j,j,i) = dr(j,j,i)+cpr(k,2)*df2(k)
          ddr(j,j,i) = ddr(j,j,i)+cpr(k,2)*ddf2(k)
        enddo

      enddo

      enddo dimloop

      u = 0.d0
      du = 0.d0
      fr = 0.d0

      do i=1,ntr
        do j=1,ndim
          u(i) = u(i)-(ar(j,i)**2+dr(j,j,i))/2d0/am(j)
        enddo

        do j=1,ndim

          do k=1,ndim
            du(j,i) = du(j,i)-(ar(k,i)*dr(j,k,i))/am(k)
            fr(j,i) = fr(j,i)-dp(j,k,i)*ar(k,i)/am(k)
          enddo

          du(j,i) = du(j,i)-ddr(j,j,i)/2d0/am(j)
          fr(j,i) = fr(j,i)-ddp(j,j,i)/2d0/am(j)
        enddo

      enddo

      return
      end subroutine
!----------------------------------------
!     linear basis
!---------------------------------------
      subroutine basis(Ndim,Ntr,x,f)
      implicit real*8(a-h,o-z)
      integer*4  :: Ndim,Ntr
      real*8      :: x(Ndim,Ntr)
      real*8,intent(OUT) :: f(Ndim+1,Ntr)

      f = 0d0

!---basis vector f = ((x(i),i=1,Ndim),1) for each trajectory-------------------
      do i=1,Ntr
        do j=1,Ndim
          f(j,i)=x(j,i)
        enddo
          f(Ndim+1,i)=1d0
       enddo

      return
      end subroutine
!--------------------------------------------------------------


subroutine  ALBEDO (SOLSIN)
  use simsphere_mod, only: albg, albf, wgg, wmax, frveg, xlai, albdoe, sigf, eq
  implicit none

  real :: SOLSIN
  logical :: ALGFLG = .false. ,ALFFLG = .false.
  integer :: ALBFLG = 0

!      INCLUDE 'modvars.h'

! **  Modified 1/8/90 to allow user to specify Albedoes.

! **  If the albedoes are ommitted in START then they are calculated,
! **  otherwise the albedo of the ground and the foliage input are used
! **  to calculate the weighted albedo (ALBDOE).
! **  Note: ALBF depends on solar angle (SOLSIN); ALBG on WGG.

  IF (ALBFLG == 0) THEN
    IF (eq(ALBG,0.0)) ALGFLG = .TRUE.
    IF (eq(ALBF,0.0)) ALFFLG = .TRUE.
    ALBFLG = 1
  ENDIF

  IF ( ALGFLG ) THEN
    ALBG = 0.25 - 0.20 * WGG / WMAX     !  Toby's Value
!	ALBG = 0.20 - 0.15 * WGG / WMAX     !  Fudged Dim
!	ALBG = 0.30 - 0.20 * WGG / WMAX     !  Fudged Bright
  ENDIF

  IF ( ALFFLG ) THEN
!	ALBF = 0.025 /( 0.1 + 0.1 * SOLSIN ) + ( 1 - SOLSIN**2 ) * 0.1	! T
    ALBF = 0.032 /( 0.1 + 0.1 * SOLSIN ) + ( 1 - SOLSIN**2 ) * 0.1 ! A
  ENDIF

  SIGF = 1 - EXP(-0.4 * XLAI )
  ALBDOE = (SIGF*ALBF + (1 - SIGF)*ALBG)*FRVEG + (1-FRVEG) * ALBG

  return
end


      SUBROUTINE NF01BU( STOR, UPLO, N, IPAR, LIPAR, DPAR, LDPAR, J,
     $                   LDJ, JTJ, LDJTJ, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix J'*J + c*I, for the Jacobian J as received
C     from SLICOT Library routine NF01BD:
C
C          /  dy(1)/dwb(1)  |  dy(1)/dtheta  \
C     Jc = |       :        |       :        | .
C          \  dy(L)/dwb(L)  |  dy(L)/dtheta  /
C
C     This is a compressed representation of the actual structure
C
C         /   J_1    0    ..   0   |  L_1  \
C         |    0    J_2   ..   0   |  L_2  |
C     J = |    :     :    ..   :   |   :   | .
C         |    :     :    ..   :   |   :   |
C         \    0     0    ..  J_L  |  L_L  /
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     STOR    CHARACTER*1
C             Specifies the storage scheme for the symmetric
C             matrix J'*J + c*I, as follows:
C             = 'F' :  full storage is used;
C             = 'P' :  packed storage is used.
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix J'*J + c*I is stored,
C             as follows:
C             = 'U' :  the upper triagular part is stored;
C             = 'L' :  the lower triagular part is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix J'*J + c*I.
C             N = BN*BSN + ST >= 0.  (See parameter description below.)
C
C     IPAR    (input) INTEGER array, dimension (LIPAR)
C             The integer parameters describing the structure of the
C             matrix J, as follows:
C             IPAR(1) must contain ST, the number of parameters
C                     corresponding to the linear part.  ST >= 0.
C             IPAR(2) must contain BN, the number of blocks, BN = L,
C                     for the parameters corresponding to the nonlinear
C                     part.  BN >= 0.
C             IPAR(3) must contain BSM, the number of rows of the blocks
C                     J_k = dy(k)/dwb(k), k = 1:BN, if BN > 0, or the
C                     number of rows of the matrix J, if BN <= 1.
C             IPAR(4) must contain BSN, the number of columns of the
C                     blocks J_k, k = 1:BN.  BSN >= 0.
C
C     LIPAR   (input) INTEGER
C             The length of the array IPAR.  LIPAR >= 4.
C
C     DPAR    (input) DOUBLE PRECISION array, dimension (LDPAR)
C             The real parameters needed for solving the problem.
C             The entry DPAR(1) must contain the real scalar c.
C
C     LDPAR   (input) INTEGER
C             The length of the array DPAR.  LDPAR >= 1.
C
C     J       (input) DOUBLE PRECISION array, dimension (LDJ, NC)
C             where NC = N if BN <= 1, and NC = BSN+ST, if BN > 1.
C             The leading NR-by-NC part of this array must contain
C             the (compressed) representation (Jc) of the Jacobian
C             matrix J, where NR = BSM if BN <= 1, and NR = BN*BSM,
C             if BN > 1.
C
C     LDJ     (input) INTEGER
C             The leading dimension of array J.  LDJ >= MAX(1,NR).
C
C     JTJ     (output) DOUBLE PRECISION array,
C                      dimension (LDJTJ,N),    if STOR = 'F',
C                      dimension (N*(N+1)/2),  if STOR = 'P'.
C             The leading N-by-N (if STOR = 'F'), or N*(N+1)/2 (if
C             STOR = 'P') part of this array contains the upper or
C             lower triangle of the matrix J'*J + c*I, depending on
C             UPLO = 'U', or UPLO = 'L', respectively, stored either as
C             a two-dimensional, or one-dimensional array, depending
C             on STOR.
C
C     LDJTJ   INTEGER
C             The leading dimension of the array JTJ.
C             LDJTJ >= MAX(1,N), if STOR = 'F'.
C             LDJTJ >= 1,        if STOR = 'P'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             Currently, this array is not used.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 0.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix product is computed columnn-wise, exploiting the
C     symmetry. BLAS 3 routines DGEMM and DSYRK are used if STOR = 'F',
C     and BLAS 2 routine DGEMV is used if STOR = 'P'.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 2001.
C
C     REVISIONS
C
C     V. Sima, Dec. 2001, Mar. 2002.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix algebra, matrix operations,
C     Wiener system.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         STOR, UPLO
      INTEGER           INFO, LDJ, LDJTJ, LDPAR, LDWORK, LIPAR, N
C     .. Array Arguments ..
      DOUBLE PRECISION  DPAR(*), DWORK(*), J(LDJ,*), JTJ(*)
      INTEGER           IPAR(*)
C     .. Local Scalars ..
      LOGICAL           FULL, UPPER
      INTEGER           BN, BSM, BSN, I1, IBSM, IBSN, II, JL, K, M,
     $                  NBSN, NTHS, ST
      DOUBLE PRECISION  C
C     .. Local Arrays ..
      DOUBLE PRECISION  TMP(1)
      INTEGER           ITMP(1)
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DLASET, DSYRK, NF01BV,
     $                  XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     ..
C     .. Executable Statements ..
C
      INFO = 0
C
      FULL  = LSAME( STOR, 'F' )
      UPPER = LSAME( UPLO, 'U' )
C
      IF( .NOT.( FULL .OR. LSAME( STOR, 'P' ) ) ) THEN
         INFO = -1
      ELSEIF ( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
         INFO = -2
      ELSEIF ( N.LT.0 ) THEN
         INFO = -3
      ELSEIF ( LIPAR.LT.4 ) THEN
         INFO = -5
      ELSEIF ( LDPAR.LT.1 ) THEN
         INFO = -7
      ELSEIF ( LDJTJ.LT.1 .OR. ( FULL .AND. LDJTJ.LT.N ) ) THEN
         INFO = -11
      ELSEIF ( LDWORK.LT.0 ) THEN
         INFO = -13
      ELSE
         ST   = IPAR(1)
         BN   = IPAR(2)
         BSM  = IPAR(3)
         BSN  = IPAR(4)
         NTHS = BN*BSN
         IF ( BN.GT.1 ) THEN
            M = BN*BSM
         ELSE
            M = BSM
         END IF
         IF ( MIN( ST, BN, BSM, BSN ).LT.0 ) THEN
            INFO = -4
         ELSEIF ( N.NE.NTHS + ST ) THEN
            INFO = -3
         ELSEIF ( LDJ.LT.MAX( 1, M ) ) THEN
            INFO = -9
         END IF
      ENDIF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'NF01BU', -INFO )
         RETURN
      ENDIF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 )
     $   RETURN
C
      C = DPAR(1)
C
      IF ( BN.LE.1 .OR. BSN.EQ.0 .OR. BSM.EQ.0 ) THEN
C
C        Special case, l <= 1 or BSN = 0 or BSM = 0: the Jacobian is
C        represented as a full matrix.
C
         ITMP(1) = M
         CALL NF01BV( STOR, UPLO, N, ITMP, 1, DPAR, 1, J, LDJ, JTJ,
     $                LDJTJ, DWORK, LDWORK, INFO )
         RETURN
      END IF
C
C     General case: l > 1, BSN > 0, BSM > 0.
C
      JL = BSN + 1
C
      IF ( FULL ) THEN
C
         NBSN = N*BSN
C
         IF ( UPPER ) THEN
C
C           Compute the leading upper triangular part (full storage).
C
            CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ, LDJTJ )
            CALL DSYRK(  UPLO, 'Transpose', BSN, BSM, ONE, J, LDJ, ONE,
     $                   JTJ, LDJTJ )
            IBSN = BSN
            I1   = NBSN + 1
C
            DO 10 IBSM = BSM + 1, M, BSM
               II = I1 + IBSN
               CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1),
     $                      LDJTJ )
               I1 = I1 + NBSN
               CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ )
               CALL DSYRK(  UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1),
     $                      LDJ, ONE, JTJ(II), LDJTJ )
               IBSN = IBSN + BSN
   10       CONTINUE
C
            IF ( ST.GT.0 ) THEN
C
C              Compute the last block column.
C
               DO 20 IBSM = 1, M, BSM
                  CALL DGEMM( 'Transpose', 'NoTranspose', BSN, ST, BSM,
     $                        ONE, J(IBSM,1), LDJ, J(IBSM,JL), LDJ,
     $                        ZERO, JTJ(I1), LDJTJ )
                  I1 = I1 + BSN
   20          CONTINUE
C
               CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(I1), LDJTJ )
               CALL DSYRK(  UPLO, 'Transpose', ST, M, ONE, J(1,JL),
     $                      LDJ, ONE, JTJ(I1), LDJTJ )
            END IF
C
         ELSE
C
C           Compute the leading lower triangular part (full storage).
C
            IBSN = NTHS
            II   = 1
C
            DO 30 IBSM = 1, M, BSM
               I1 = II + BSN
               CALL DLASET( UPLO, BSN, BSN, ZERO, C, JTJ(II), LDJTJ )
               CALL DSYRK(  UPLO, 'Transpose', BSN, BSM, ONE, J(IBSM,1),
     $                      LDJ, ONE, JTJ(II), LDJTJ )
               IBSN = IBSN - BSN
               CALL DLASET( 'Full', IBSN, BSN, ZERO, ZERO, JTJ(I1),
     $                      LDJTJ )
               II = I1 + NBSN
               IF ( ST.GT.0 )
     $            CALL DGEMM( 'Transpose', 'NoTranspose', ST, BSN, BSM,
     $                        ONE, J(IBSM,JL), LDJ, J(IBSM,1), LDJ,
     $                        ZERO, JTJ(I1+IBSN), LDJTJ )
   30       CONTINUE
C
            IF ( ST.GT.0 ) THEN
C
C              Compute the last diagonal block.
C
               CALL DLASET( UPLO, ST, ST, ZERO, C, JTJ(II), LDJTJ )
               CALL DSYRK(  UPLO, 'Transpose', ST, M, ONE, J(1,JL),
     $                      LDJ, ONE, JTJ(II), LDJTJ )
            END IF
C
         END IF
C
      ELSE
C
         TMP(1) = ZERO
C
         IF ( UPPER ) THEN
C
C           Compute the leading upper triangular part (packed storage).
C
            IBSN = 0
            I1   = 1
C
            DO 50 IBSM = 1, M, BSM
C
               DO 40 K = 1, BSN
                  II = I1 + IBSN
                  CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 )
                  CALL DGEMV( 'Transpose', BSM, K, ONE, J(IBSM,1), LDJ,
     $                        J(IBSM,K), 1, ZERO, JTJ(II), 1 )
                  I1 = II + K
                  JTJ(I1-1) = JTJ(I1-1) + C
   40          CONTINUE
C
               IBSN = IBSN + BSN
   50       CONTINUE
C
C           Compute the last block column.
C
            DO 70 K = 1, ST
C
               DO 60 IBSM = 1, M, BSM
                  CALL DGEMV( 'Transpose', BSM, BSN, ONE, J(IBSM,1),
     $                        LDJ, J(IBSM,BSN+K), 1, ZERO, JTJ(I1), 1 )
                  I1 = I1 + BSN
   60          CONTINUE
C
               CALL DGEMV( 'Transpose', M, K, ONE, J(1,JL), LDJ,
     $                     J(1,BSN+K), 1, ZERO, JTJ(I1), 1 )
               I1 = I1 + K
               JTJ(I1-1) = JTJ(I1-1) + C
   70       CONTINUE
C
         ELSE
C
C           Compute the leading lower triangular part (packed storage).
C
            IBSN = NTHS
            II   = 1
C
            DO 90 IBSM = 1, M, BSM
               IBSN = IBSN - BSN
C
               DO 80 K = 1, BSN
                  I1 = II + BSN - K + 1
                  CALL DCOPY( IBSN, TMP, 0, JTJ(I1), 1 )
                  CALL DGEMV( 'Transpose', BSM, BSN-K+1, ONE, J(IBSM,K),
     $                        LDJ, J(IBSM,K), 1, ZERO, JTJ(II), 1 )
                  JTJ(II) = JTJ(II) + C
                  I1 = I1 + IBSN
                  II = I1 + ST
                  IF ( ST.GT.0 )
     $               CALL DGEMV( 'Transpose', BSM, ST, ONE, J(IBSM,JL),
     $                           LDJ, J(IBSM,K), 1, ZERO, JTJ(I1), 1 )
   80          CONTINUE
C
   90       CONTINUE
C
C           Compute the last diagonal block.
C
            DO 100 K = 1, ST
               CALL DGEMV( 'Transpose', M, ST-K+1, ONE, J(1,BSN+K), LDJ,
     $                     J(1,BSN+K), 1, ZERO, JTJ(II), 1 )
               JTJ(II) = JTJ(II) + C
               II = II + ST - K + 1
  100       CONTINUE
C
         END IF
C
      END IF
C
      RETURN
C
C *** Last line of NF01BU ***
      END


! { dg-do run }
!
! PR fortran/66089
! Check that we do create a temporary for C(1) below in the assignment
! to C.

  type :: t
    integer :: c
  end type t

  type(t), dimension(5) :: b, c

  b = t(7)
  c = t(13)
  c = plus(c(1), b)
! print *, c
  if (any(c%c /= 20)) call abort

contains

  elemental function plus(lhs, rhs)
    type(t), intent(in) :: lhs, rhs
    type(t)             :: plus
    plus%c = lhs%c + rhs%c
  end function plus

end


      REAL             FUNCTION SDOT(N,X,INCX,Y,INCY)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2006-06-07 SDOT   Krogh  Removed arithmetic if
C>> 1994-11-11 SDOT   Krogh  Declared all vars.
c>> 1994-10-20 SDOT   Krogh  Changes to use M77CON
c>> 1994-04-19 SDOT   Krogh  Minor -- Made code versions line up.
C>> 1985-08-02 SDOT   Lawson Initial code.
c--S replaces "?": ?DOT
C
C     RETURNS THE DOT PRODUCT OF X AND Y.
C     SDOT = SUM FOR I = 0 TO N-1 OF  X(LX+I*INCX) * Y(LY+I*INCY),
C     WHERE LX = 1 IF INCX .GE. 0, ELSE LX = (-INCX)*N, AND LY IS
C     DEFINED IN A SIMILAR WAY USING INCY.
C
      INTEGER N, INCX, INCY, IX, IY, I, M, MP1, NS
      REAL             X(*),Y(*)
      SDOT = 0.0E0
      IF(N.LE.0)RETURN
      IF ((INCX .NE. INCY) .OR. (INCX .LT. 0)) THEN
C         CODE FOR UNEQUAL OR NONPOSITIVE INCREMENTS.
        IX = 1
        IY = 1
        IF(INCX.LT.0)IX = (-N+1)*INCX + 1
        IF(INCY.LT.0)IY = (-N+1)*INCY + 1
        DO 10 I = 1,N
          SDOT = SDOT + X(IX)*Y(IY)
          IX = IX + INCX
          IY = IY + INCY
 10     CONTINUE
      ELSE IF (INCX .EQ. 1) THEN
C        CODE FOR BOTH INCREMENTS EQUAL TO 1.
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 5.
        M = MOD(N,5)
        IF( M .EQ. 0 ) GO TO 40
        DO 30 I = 1,M
          SDOT = SDOT + X(I)*Y(I)
 30     CONTINUE
        IF( N .LT. 5 ) RETURN
 40     MP1 = M + 1
        DO 50 I = MP1,N,5
          SDOT = SDOT + X(I)*Y(I) + X(I+1)*Y(I+1) +
     $      X(I + 2)*Y(I + 2) + X(I + 3)*Y(I + 3) + X(I + 4)*Y(I + 4)
 50     CONTINUE
      ELSE
C         CODE FOR POSITIVE EQUAL INCREMENTS .NE.1.
        NS = N*INCX
        DO 70 I=1,NS,INCX
          SDOT = SDOT + X(I)*Y(I)
 70     CONTINUE
      END IF
      RETURN
      END


! { dg-do run }
! PR 20074: This used to segfault at runtime.
! Test case contributed by "Alfredo Buttari" <pitagoras@tin.it>

program tryreshape

  integer,allocatable :: vect1(:),resh1(:,:)
  integer,pointer :: vect(:),resh(:,:)
  integer :: vect2(2*4), resh2(2,4)
  integer :: r, s(2)

  r=2;  nb=4

  s(:)=(/r,nb/)

  allocate(vect(nb*r),vect1(nb*r))
  allocate(resh(r,nb),resh1(r,nb))

  vect =1
  vect1=1
  vect2=1

  resh2 = reshape(vect2,s)
  if (resh2(1,1) /= 1.0) call abort

  resh1 = reshape(vect1,s)
  if (resh1(1,1) /= 1.0) call abort

  resh = reshape(vect,s)
  if (resh(1,1) /= 1.0) call abort

end program tryreshape


module mod_tree_map
  implicit none

  type t_entry
    private
    integer :: key
    integer :: val
  end type t_entry

  type t_node
    private
    type(t_node), pointer :: left => null(), right => null()
    integer :: level = 1
    type(t_entry), pointer :: e => null()
  end type t_node

  type t_tree_map
    private
    type(t_node), pointer :: root => null()
    integer :: deflt = -1
  end type t_tree_map

contains

  function new_entry(key,val) result(e)
    integer, intent(in) :: key
    integer, intent(in) :: val
    type(t_entry), pointer :: e
    e => null()
    allocate(e)
    e%key = key
    e%val = val
  end

  function new_node(e) result(n)
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: n
    n => null()
    allocate(n)
    n%e => e
  end

  integer function level(n)
    type(t_node), pointer, intent(in) :: n
    level = 0
    if (.not.associated(n)) return
    level = n%level
  end

  logical function is_leaf(n)
    type(t_node), pointer, intent(in) :: n
    is_leaf = associated(n) .and. .not.associated(n%left) .and. &
    &         .not.associated(n%right)
  end

  recursive function tree_size(n) result(s)
    type(t_node), pointer, intent(in) :: n
    integer :: s
    s = 0
    if (.not.associated(n)) return
    s = 1+tree_size(n%left)+tree_size(n%right)
  end

  function skew(n) result(l)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: l
    l => n
    if (.not.(associated(n) .and. associated(n%left) .and. &
    &   n%left%level == n%level)) return
    l => n%left
    n%left => l%right
    l%right => n
  end

  function split(n) result(r)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: r
    r => n
    if (.not.(associated(n) .and. associated(n%right) .and. &
    &   associated(n%right%right) .and. n%right%right%level == n%level)) return
    r => n%right
    n%right => r%left
    r%left => n
    r%level = r%level+1
  end

  function predecessor(n) result(p)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: p
    p => null()
    if (.not.associated(n%left)) return
    p => n%left
    do while (associated(p%right))
      p => p%right
    end do
  end

  function successor(n) result(s)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: s
    s => null()
    if (.not.associated(n%right)) return
    s => n%right
    do while (associated(s%left))
      s => s%left
    end do
  end

  recursive function insert(n,e) result(t)
    type(t_node), pointer, intent(in) :: n
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: t
    t => new_node(e)
    if (.not.associated(n)) return
    t => n
    if (e%key < t%e%key) then
      t%left => insert(t%left,e)
    else if (e%key > t%e%key) then
      t%right => insert(t%right,e)
    else
      t%e => e
    end if
    t => skew(t)
    t => split(t)
  end

  recursive function delete(n,e) result(t)
    type(t_node), pointer, intent(in) :: n
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: t, l
    t => n
    if (.not.associated(n)) return
    if (e%key < t%e%key) then
      t%left => delete(t%left,e)
    else if (e%key > t%e%key) then
      t%right => delete(t%right,e)
    else
      if (is_leaf(t)) return
      if (.not.associated(t%left)) then
        l => successor(t)
        t%right => delete(t%right,l%e)
        t%e => l%e
      else
        l => predecessor(t)
        t%left => delete(t%left,l%e)
        t%e => l%e
      end if
    end if
    t => decrease_level(t)
    t => skew(t)
    t%right => skew(t%right)
    if (associated(t%right)) t%right%right => skew(t%right%right)
    t => split(t)
    t%right => split(t%right)
  end

  function decrease_level(n) result(t)
    type(t_node), pointer, intent(in) :: n
    type(t_node), pointer :: t
    integer :: should_be
    t => n
    should_be = min(level(t%left),level(t%right))+1
    if (t%level > should_be) then
      t%level = should_be
      if (level(t%right) > should_be) t%right%level = should_be
    end if
  end

  recursive subroutine release_tree(t)
    type(t_node), pointer, intent(inout) :: t
    if (.not.associated(t)) return
    call release_tree(t%left)
    call release_tree(t%right)
    deallocate(t)
  end

  recursive subroutine get_keys_list(t,keys,num)
    type(t_node), pointer, intent(in) :: t
    integer, intent(inout) :: keys(:)
    integer, intent(inout) :: num
    if (.not.associated(t)) return
    call get_keys_list(t%left,keys,num)
    num = num+1
    keys(num) = t%e%key
    call get_keys_list(t%right,keys,num)
  end

  integer function size_of(map)
    type(t_tree_map), intent(in) :: map
    size_of = tree_size(map%root)
  end

  subroutine clear(map)
    type(t_tree_map), intent(inout) :: map
    call release_tree(map%root)
    map%root => null()
  end

  subroutine set_default(map,deflt)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: deflt
    map%deflt = deflt
  end

  subroutine put_entry(map,e)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    map%root => insert(map%root,e)
  end

  subroutine remove_entry(map,e)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    map%root => delete(map%root,e)
  end

  function get_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    do while (associated(n))
      if (e%key < n%e%key) then
        n => n%left
      else if (e%key > n%e%key) then
        n => n%right
      else
        ret => n%e
        return
      end if
    end do
  end

  function contain_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: n
    logical :: ret
    ret = .false.
    n => map%root
    do while (associated(n))
      if (e%key < n%e%key) then
        n => n%left
      else if (e%key > n%e%key) then
        n => n%right
      else
        ret = .true.
        return
      end if
    end do
  end

  function get_first_entry(map) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    if (.not.associated(n)) return
    do while (associated(n%left))
      n => n%left
    end do
    ret => n%e
  end

  function poll_first_entry(map) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    if (.not.associated(n)) return
    do while (associated(n%left))
      n => n%left
    end do
    ret => n%e
    map%root => delete(map%root,ret)
  end

  function get_last_entry(map) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    if (.not.associated(n)) return
    do while (associated(n%right))
      n => n%right
    end do
    ret => n%e
  end

  function poll_last_entry(map) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    if (.not.associated(n)) return
    do while (associated(n%right))
      n => n%right
    end do
    ret => n%e
    map%root => delete(map%root,ret)
  end

  function floor_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    do while (associated(n))
      if (e%key < n%e%key) then
        n => n%left
      else if (e%key > n%e%key) then
        if (.not.associated(ret)) then
          ret => n%e
          cycle
        end if
        if (e%key-ret%key > e%key-n%e%key) ret => n%e
        n => n%right
      else
        ret => n%e
        return
      end if
    end do
  end

  function lower_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_entry), pointer :: ret
    ret => floor_entry(map,new_entry(e%key-1,0))
  end

  function ceiling_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_node), pointer :: n
    type(t_entry), pointer :: ret
    ret => null()
    n => map%root
    do while (associated(n))
      if (e%key < n%e%key) then
        if (.not.associated(ret)) then
          ret => n%e
          cycle
        end if
        if (e%key-ret%key < e%key-n%e%key) ret => n%e
        n => n%left
      else if (e%key > n%e%key) then
        n => n%right
      else
        ret => n%e
        return
      end if
    end do
  end

  function higher_entry(map,e) result(ret)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer, intent(in) :: e
    type(t_entry), pointer :: ret
    ret => ceiling_entry(map,new_entry(e%key+1,0))
  end

  subroutine get_keys(map,keys,num)
    type(t_tree_map), intent(inout) :: map
    integer, intent(inout) :: keys(:)
    integer, intent(inout) :: num
    keys = 0
    num = 0
    call get_keys_list(map%root,keys,num)
  end

  subroutine put(map,key,val)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    integer, intent(in) :: val
    call put_entry(map,new_entry(key,val))
  end

  subroutine remove(map,key)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    call remove_entry(map,new_entry(key,0))
  end

  function get(map,key) result(val)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    type(t_entry), pointer :: tmp
    integer :: val
    val = map%deflt
    tmp => get_entry(map,new_entry(key,0))
    if (.not.associated(tmp)) return
    val = tmp%val
  end

  logical function contain(map,key)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    contain = contain_entry(map,new_entry(key,0))
  end

  function get_first_key(map) result(key)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer :: tmp
    integer :: key
    key = map%deflt
    tmp => get_first_entry(map)
    if (.not.associated(tmp)) return
    key = tmp%key
  end

  function get_last_key(map) result(key)
    type(t_tree_map), intent(inout) :: map
    type(t_entry), pointer :: tmp
    integer :: key
    key = map%deflt
    tmp => get_last_entry(map)
    if (.not.associated(tmp)) return
    key = tmp%key
  end

  function floor_key(map,key) result(ret)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    type(t_entry), pointer :: tmp
    integer :: ret
    ret = map%deflt
    tmp => floor_entry(map,new_entry(key,0))
    if (.not.associated(tmp)) return
    ret = tmp%key
  end

  function lower_key(map,key) result(ret)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    type(t_entry), pointer :: tmp
    integer :: ret
    ret = map%deflt
    tmp => lower_entry(map,new_entry(key,0))
    if (.not.associated(tmp)) return
    ret = tmp%key
  end

  function ceiling_key(map,key) result(ret)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    type(t_entry), pointer :: tmp
    integer :: ret
    ret = map%deflt
    tmp => ceiling_entry(map,new_entry(key,0))
    if (.not.associated(tmp)) return
    ret = tmp%key
  end

  function higher_key(map,key) result(ret)
    type(t_tree_map), intent(inout) :: map
    integer, intent(in) :: key
    type(t_entry), pointer :: tmp
    integer :: ret
    ret = map%deflt
    tmp => higher_entry(map,new_entry(key,0))
    if (.not.associated(tmp)) return
    ret = tmp%key
  end

end module mod_tree_map


        subroutine id_randperm(n,ind)
c
c       draws a permutation ind uniformly at random from the group
c       of all permutations of n objects.
c
c       input:
c       n -- length of ind
c
c       output:
c       ind -- random permutation of length n
c
        implicit none
        integer n,ind(n),m,j,iswap
        real*8 r
c
c
c       Initialize ind.
c
        do j = 1,n
          ind(j) = j
        enddo ! j
c
c
c       Shuffle ind via the Fisher-Yates (Knuth/Durstenfeld) algorithm.
c
        do m = n,2,-1
c
c         Draw an integer uniformly at random from 1, 2, ..., m.
c
          call id_srand(1,r)
          j = m*r+1
c
c         Uncomment the following line if r could equal 1:
c         if(j .eq. m+1) j = m
c
c         Swap ind(j) and ind(m).
c
          iswap = ind(j)
          ind(j) = ind(m)
          ind(m) = iswap
c
        enddo ! m
c
c
        return
        end


!-------------------------------------------------------------------------------------------------
! Fortran source code for module {{ cookiecutter.package_name }}.{{ cookiecutter.module_name }}
!-------------------------------------------------------------------------------------------------
! Remarks:
!   . Enter Python documentation for this module in ``./{{ cookiecutter.module_name }}.rst``.
!     You might want to check the f2py output for the interfaces of the C-wrapper functions.
!     It will be autmatically included in the {{ cookiecutter.package_name }} documentation.
!   . Documument the Fortran routines in this file. This documentation will not be included
!     in the {{ cookiecutter.package_name }} documentation (because there is no recent sphinx
!     extension for modern fortran.

subroutine add(x,y,z,n)
  ! Compute the
  !
  ! Python use:
  !    import {{ cookiecutter.project_name }}.{{ cookiecutter.module_name }} as f90
  !    a      = np.array([1,2,3],dtype=np.float64)
  !    result = np.ndarray((2,), np.float64)
  !    f90.mean_and_stddev(result,a)
  !    avg = result[0]
  !    std = result[1]
    implicit none
  !-------------------------------------------------------------------------------------------------
    integer*4              , intent(in)    :: n
    real*8   , dimension(n), intent(in)    :: x,y
    real*8   , dimension(n), intent(inout) :: z
    ! intent is inout because we do not want to return an array to avoid needless copying
  !-------------------------------------------------------------------------------------------------
  ! declare local variables
    integer*4 :: i
  !-------------------------------------------------------------------------------------------------
    do i=1,n
        z(i) = x(i) + y(i)
    end do
end subroutine add


      subroutine gridbicub(
     >   x_newgrid,nx_new,y_newgrid,ny_new,f_new,if1,
     >   nx,xpkg,ny,ypkg,fspl,inf3,iwarn,ier)
c
c  regrid a spline function f defined vs. x,y as in xpkg,ypkg
c  to a new grid, given by x_newgrid, y_newgrid
c
c  set warning flag if the range x_newgrid, y_newgrid
c  exceeds the range of the original xpkg,ypkg.
c
c  (xpkg,ypkg -- axis data, see genxpkg subroutine)
c
c  input:
c
      real x_newgrid(nx_new)            ! new x grid
      real y_newgrid(ny_new)            ! new y grid
c
c  output:
c
      integer if1                       ! 1st dimension of f_new
      real f_new(if1,ny_new)            ! f evaluated on this grid
c
c  input:
c
      integer nx                        ! size of old grid
      real xpkg(nx,4)                   ! old grid "package"
      integer ny                        ! size of old grid
      real ypkg(ny,4)                   ! old grid "package"
c
      integer inf3                      ! array dimension
      real fspl(4,inf3,ny)              ! compact spline coefficients of f
c
c  output:
c  condition codes, =0 for normal exit
c
      integer iwarn                     ! =1 if new grid points out of range
      integer ier                       ! =1 if there is an argument error
c
c--------------------------------------------
c  local
c
      real ytmp(nx_new)
      integer ict(6)
c
      data ict/1,0,0,0,0,0/
c
c--------------------------------------------
c
      do iy=1,ny_new
         ytmp=y_newgrid(iy)
         call vecbicub(ict,nx_new,x_newgrid,ytmp,nx_new,f_new(1,iy),
     >      nx,xpkg,ny,ypkg,fspl,inf3,iwarn,ier)
      enddo
c
      return
      end


subroutine  corrente

!****************************************************************!
! COMPUTE: current density from J = curl(B)                      !
!          [2D version]                                          !
! -------------------------------------------------------------- !
! original version:             F. Califano, 2006                !
! MPI parallel version:         M. Faganello/F. Valentini, 2008  !
! Anisotropic/FLR-MHD version:  S. S. Cerri, 2011                !
!****************************************************************!

use parameter_mod
use parallel_mod
use dom_distr_mod
use box_mod
use deriv_mod
use fields_UJ_mod
use fields_EB_mod

IMPLICIT NONE

integer :: ix, iy, iz

REAL(dp),ALLOCATABLE :: zx(:), zy(:), zz(:)
REAL(dp), ALLOCATABLE :: Bt(:,:,:)

allocate(zx(nx))
allocate(zy(ny))
allocate(zz(nz))

ALLOCATE( Bt( nx, nyt, nz ) )  ! nyt ~ ny/nproc

!--compute Jx
do iz = 1, nz
  do ix = 1, nxl
    call  dery_1( Bz(ix,:,iz), Jx(ix,:,iz) )
  enddo
enddo

!--compute Jy
call traspdist( Bz, Bt, 1 )
do iz = 1, nz
  do iy = 1, nyt
    call  derx_1(Bt(:,iy,iz), zx )
    Bt(:,iy,iz) = - zx
  enddo
enddo
call traspdist( Jy, Bt, -1 )

!--compute Jz
call traspdist( By, Bt, 1 )
do iz = 1, nz
  do iy = 1, nyt
    call  derx_1( Bt(:,iy,iz), zx )
    Bt(:,iy,iz) = zx
  enddo
enddo
call traspdist( Jz, Bt, -1 )
!
do iz = 1, nz
  do ix = 1, nxl
    call dery_1( Bx(ix,:,iz), zy )
    Jz(ix,:,iz) = Jz(ix,:,iz) - zy
  enddo
enddo

deallocate(zx)
deallocate(zy)
deallocate(zz)
deallocate(Bt)

end subroutine


c*************************************************************
c Compute percent map relative average valye of velocity
c*************************************************************
      SUBROUTINE PERC_MAP(infile,nxy)
      IMPLICIT NONE
      include "line.h"
c TYPE definitions ++++++++++++++++++++++++++++++++++++++
      character*160  infile,outfile
      real*8    d_clon,d_clat,vel
      real*8    dcof,dsum,dscof,aver_vel,velper
      integer*4 i,lnd,nq,nxy
      integer*4 LNBLNK
c END TYPE definitions ++++++++++++++++++++++++++++++++++
      lnd=LNBLNK(infile)
      outfile=infile(1:lnd)//'_%_'
      open(unit=61,file=infile,STATUS='OLD')
      open(unit=62,file=outfile,status='UNKNOWN')
      dsum=0.0d0
      dscof=0.0d0
      do i=1,nxy
        read(61,'(3f12.4)') d_clon,d_clat,vel
        dcof=DABS(DCOS(d_clat*drad))
        dsum=dsum+vel*dcof
        dscof=dscof+dcof
      enddo
      close(61)
      open(unit=61,file=infile,STATUS='OLD')
      nq=i-1
      aver_vel=dsum/dscof
      do i=1,nxy
        read(61,'(3f12.4)') d_clon,d_clat,vel
        velper=100.*(vel-aver_vel)/aver_vel
        write(62,'(2f12.4,f12.5)') d_clon,d_clat,velper
      enddo
      close(61)
      close(62)
      write (8,1000) aver_vel,nq
      write (*,1000) aver_vel,nq
 1000 format(' average velocity  = ',f12.5,
     *' (km/sec), npoints=',i7)
      return
      end


*----------------------------------------------------------------------*
      integer function rank_ivec(rank,ivec,nel)
*----------------------------------------------------------------------*
*     return on rank the rank of the entries on ivec and the
*     index of the permutation as function result (ordering conforms
*     with the order produced by next_perm())
*----------------------------------------------------------------------*
      implicit none

      integer, intent(in) ::
     &     nel, ivec(nel)
      integer, intent(out) ::
     &     rank(nel)

      integer ::
     &     idx, jdx, value, rk

      rank_ivec = 0
      rank(1:nel) = 0
      do idx = 1, nel-1
        value = ivec(idx)
        rk = 0
        do jdx = idx+1, nel
          if (     (value.gt.ivec(jdx)) ) rk = rk+1
          if (.not.(value.gt.ivec(jdx)) ) rank(jdx) = rank(jdx)+1
        end do
        rank(idx) = rank(idx)+rk
        rank_ivec = rank_ivec*(nel-idx+1) + rk
      end do

      return
      end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine fsuper(time,t,a,b,h1,h2,h3,h4,h5,h6,func,funcp)
!
      implicit none
!
      real*8 time,t,a,b,h1,h2,h3,h4,h5,h6,fexm,fexp,func,funcp
!
      fexm=dexp(h1*t)
      fexp=dexp(-h2*t)
!
!     function
!
      func=(a+b*time)*(fexm*h3+fexp*h4)
     &    -b*(fexm*(t*h3-h5)+fexp*(t*h4+h6))
!
!     derivative of the function
!
      funcp=(a+b*time)*(fexm-fexp)-b*(fexm*(t-h3)-fexp*(t+h4))

!
      return
      end