*deck stvint
      subroutine stvint(hpt,hwt)
c
c  gauss-hermite quadrature using minimum-point formula
c
      implicit real*8 (a-h,o-z)
      parameter (zero=0.0d0)
      common /stv/ xint,yint,zint,t,x0,y0,z0,xi,yi,zi,xj,yj,zj,ni,nj
      dimension hpt(*), hwt(*)
c
      xint=zero
      yint=zero
      zint=zero
      npts=(ni+nj)/2
      imax=(npts*(npts+1))/2
      imin=imax-npts+1
      do 40 i=imin,imax
        dum=hpt(i)/t
        ptx=dum+x0
        pty=dum+y0
        ptz=dum+z0
        ax=ptx-xi
        ay=pty-yi
        az=ptz-zi
        bx=ptx-xj
        by=pty-yj
        bz=ptz-zj
        dum=hwt(i)
c       # take care to avoid (0.0d0)**0
        dumx = dum
        dumy = dum
        dumz = dum
        do 20 ipwr = 1,ni-1
          dumx = dumx*ax
          dumy = dumy*ay
          dumz = dumz*az
   20   continue
        do 30 ipwr = 1,nj-1
          dumx = dumx*bx
          dumy = dumy*by
          dumz = dumz*bz
   30   continue
        xint = xint + dumx
        yint = yint + dumy
        zint = zint + dumz
c       xint=xint+dum*ax**(ni-1)*bx**(nj-1)
c       yint=yint+dum*ay**(ni-1)*by**(nj-1)
c       zint=zint+dum*az**(ni-1)*bz**(nj-1)
   40 continue
      return
      end


*deck qbess
      subroutine qbess( alpha,      apwr,       aterm1,     aterm2,
     &      binom,      bpref,      bpwr,       bterm1,     dfac,
     &      l,          lambu,      lmahi,      lmbhi,      ltot1,
     &      nu,         prd,        qsum,       rka,        rkb,
     &      ssi )
c
c  compute type 2 radial integrals, scaled by exp(-arc2)/sqrt(pi),
c  using the bessel function formula for
c  lama=max(l,nu) to lmahi, lamb=max(l,nu) to lmbhi, n=lama+lamb-l-l
c
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, a1=1.0d0, a2=2.0d0, a4=4.0d0)
      dimension apwr(*), aterm1(*), aterm2(*), binom(*), bpref(*),
     &  bpwr(*), bterm1(*), dfac(*), qsum(ltot1,lambu,*), ssi(*)
c
c     nu=l+1-npi/2
c     # bessel function formula applies to all npi=2 cases, no npi=1
c     # cases, and some npi=0 cases.
      num1=nu-1
      lmlo=max(l,nu)
      lmaphi=lmahi-num1
      lmbphi=lmbhi-num1
      fcta=rka/(alpha+alpha)
      fct=rka*fcta
      fctb=rkb/(alpha+alpha)
      bpref(1)=fctb**num1
      do 24 lambp=2,lmbphi
        bpref(lambp)=fctb*bpref(lambp-1)
   24 continue
      apwr(1)=a1
      apwr(2)=fct
      do 28 lambp=3,lmbphi
        apwr(lambp)=fct*apwr(lambp-1)
   28 continue
      fct=rkb*fctb
      bpwr(1)=a1
      bpwr(2)=fct
      do 32 lamap=3,lmaphi
        bpwr(lamap)=fct*bpwr(lamap-1)
   32 continue
      lmihi=lmaphi+lmbphi+(nu-2)
      call ssibfn(lmihi-1,rka*fctb,ssi)
      do 36 lami=1,lmihi
        ssi(lami)=ssi(lami)/dfac(lami+lami-1)
   36 continue
      lmplo=lmlo-num1
      fctra=(alpha+alpha)**(nu-2)*fcta**(lmlo-1)*prd/sqrt(a4*alpha)*
     &  ((dfac(2*(2*lmplo+num1)-1)/dfac(2*(lmplo+num1)+1))*
     &  dfac(2*num1+1))/dfac(2*(lmplo+num1)+1)
      fctran=(2*(2*lmplo+num1)-1)
      fctrad=(2*(lmplo+num1)+1)
      do 64 lamap=lmplo,lmaphi
        fctru=a1
        fctrun=(nu+num1)
        fctrud=(2*(lamap+num1)+1)
        do 40 iu=1,lmbphi
          aterm1(iu)=fctru*apwr(iu)
          fctru=fctru*fctrun/fctrud
          fctrun=fctrun+a2
          fctrud=fctrud+a2
   40   continue
        do 44 it=1,lamap
          bterm1(it)=binom((lamap*(lamap-1))/2+it)*bpwr(it)
   44   continue
        fctrb=fctra
        fctrbn=(2*(lamap+lmplo+num1)-1)
        fctrbd=(2*(lmplo+num1)+1)
        do 60 lambp=lmplo,lmbphi
          n=((2*(nu-l)-1)+lamap)+lambp
          do 48 iu=1,lambp
            aterm2(iu)=binom((lambp*(lambp-1))/2+iu)*aterm1(iu)
   48     continue
          sum=a0
          fctrt=a1
          fctrtn=(nu+num1)
          fctrtd=(2*(lambp+num1)+1)
          do 56 it=1,lamap
            do 52 iu=1,lambp
              sum=sum+aterm2(iu)*(fctrt*bterm1(it))*
     &          ssi((it+(nu-2))+iu)
   52       continue
            fctrt=fctrt*fctrtn/fctrtd
            fctrtn=fctrtn+a2
            fctrtd=fctrtd+a2
   56     continue
          qsum(n,lambp+num1,lamap+num1)=qsum(n,lambp+num1,lamap+num1)+
     &      fctrb * bpref(lambp) * sum
          fctrb=fctrb*fctrbn/fctrbd
          fctrbn=fctrbn+a2
          fctrbd=fctrbd+a2
   60   continue
        fctra=fcta*fctra*fctran/fctrad
        fctran=fctran+a2
        fctrad=fctrad+a2
   64 continue
      return
      end


      INTEGER FUNCTION NV3INIgvar
     +(IFUNC,IPARMS)
      IMPLICIT NONE

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      INTEGER      ETIME , IMCACT, IMGDAY, IMGTM , RATROL, RATPTC
      INTEGER      RATYAW, LDR1  , LDR2  , LDR3  , LDR4  , LDR5
      INTEGER      LDR6  , LDR7  , LDR8  , LDR9  , LDR10 , LDR11
      INTEGER      LDR12 , LDR13 , RDDR1 , RDDR2 , RDDR3 , RDDR4
      INTEGER      RDDR5 , RDDR6 , RDDR7 , RDDR8 , RDDR9 , RDDR10
      INTEGER      RDDR11, DGL1  , DGL2  , DGL3  , DGL4  , DGL5
      INTEGER      DGL6  , DGL7  , DGL8  , DGL9  , DOY1  , DOY2
      INTEGER      DOY3  , DOY4  , DOY5  , DOY6  , DOY7  , DOY8
      INTEGER      DOY9  , EXPTIM, RAAWDS, PAAWDS, YAAWDS, RMAWDS
      INTEGER      PMAWDS, EDTIME, IMCROL, IMCPTC, IMCYAW, IMGSND
      INTEGER      REFLON, REFDIS, REFLAT, REFYAW, STTYPE, IDNTFR
      INTEGER      IOFNC , IOFNI , IOFEC , IOFEI,  IYFLIP

      PARAMETER (STTYPE = 1)
      PARAMETER (IDNTFR = 2)
      PARAMETER (IMCACT = 3)
      PARAMETER (IYFLIP  = 4)
      PARAMETER (REFLON = 6)
      PARAMETER (REFDIS = 7)
      PARAMETER (REFLAT = 8)
      PARAMETER (REFYAW = 9)
      PARAMETER (RATROL = 10)
      PARAMETER (RATPTC = 11)
      PARAMETER (RATYAW = 12)
      PARAMETER (ETIME  = 13)
      PARAMETER (EDTIME = 15)
      PARAMETER (IMCROL = 16)
      PARAMETER (IMCPTC = 17)
      PARAMETER (IMCYAW = 18)
      PARAMETER (LDR1   = 19)
      PARAMETER (LDR2   = 20)
      PARAMETER (LDR3   = 21)
      PARAMETER (LDR4   = 22)
      PARAMETER (LDR5   = 23)
      PARAMETER (LDR6   = 24)
      PARAMETER (LDR7   = 25)
      PARAMETER (LDR8   = 26)
      PARAMETER (LDR9   = 27)
      PARAMETER (LDR10  = 28)
      PARAMETER (LDR11  = 29)
      PARAMETER (LDR12  = 30)
      PARAMETER (LDR13  = 31)
      PARAMETER (RDDR1  = 32)
      PARAMETER (RDDR2  = 33)
      PARAMETER (RDDR3  = 34)
      PARAMETER (RDDR4  = 35)
      PARAMETER (RDDR5  = 36)
      PARAMETER (RDDR6  = 37)
      PARAMETER (RDDR7  = 38)
      PARAMETER (RDDR8  = 39)
      PARAMETER (RDDR9  = 40)
      PARAMETER (RDDR10 = 41)
      PARAMETER (RDDR11 = 42)
      PARAMETER (DGL1   = 43)
      PARAMETER (DGL2   = 44)
      PARAMETER (DGL3   = 45)
      PARAMETER (DGL4   = 46)
      PARAMETER (DGL5   = 47)
      PARAMETER (DGL6   = 48)
      PARAMETER (DGL7   = 49)
      PARAMETER (DGL8   = 50)
      PARAMETER (DGL9   = 51)
      PARAMETER (DOY1   = 52)
      PARAMETER (DOY2   = 53)
      PARAMETER (DOY3   = 54)
      PARAMETER (DOY4   = 55)
      PARAMETER (DOY5   = 56)
      PARAMETER (DOY6   = 57)
      PARAMETER (DOY7   = 58)
      PARAMETER (DOY8   = 59)
      PARAMETER (DOY9   = 60)
      PARAMETER (EXPTIM = 62)
      PARAMETER (RAAWDS = 63)
      PARAMETER (PAAWDS = 130)
      PARAMETER (YAAWDS = 185)
      PARAMETER (RMAWDS = 258)
      PARAMETER (PMAWDS = 313)

      PARAMETER (IMGDAY = 368)
      PARAMETER (IMGTM  = 369)
      PARAMETER (IMGSND = 370)

      PARAMETER (IOFNC = 380)
      PARAMETER (IOFEC = 381)
      PARAMETER (IOFNI = 382)
      PARAMETER (IOFEI = 383)

      INTEGER      MXCDSZ

      PARAMETER (MXCDSZ = 5*128)

      INTEGER      OASIZE, PCOEFS, RMACFS, CUTOF1, CUTOF2

      PARAMETER (OASIZE = 336)
      PARAMETER (PCOEFS = 117)
      PARAMETER (RMACFS = 227)
      PARAMETER (CUTOF1 = 116)
      PARAMETER (CUTOF2 = 226)

      INTEGER      SSCAN , SGBCT , TSCLS , NEWIMG, ENDIMG, TIMSIZ
      INTEGER      SWFPX , SEFPX , SNFLN , SSFLN , SDSTA , DWELL1
      INTEGER      NAVLOC, DWELL2, DWELL4, SNSLN , WARN  , STPLOC
      INTEGER      NAVEND, IMCFLG, FLPFLG

      PARAMETER (SSCAN  = 31)
      PARAMETER (SDSTA  = 33)
      PARAMETER (SGBCT  = 45)
      PARAMETER (TSCLS  = 67)
      PARAMETER (NEWIMG = 15)
      PARAMETER (ENDIMG = 14)
      PARAMETER (WARN   = 11)
      PARAMETER (STPLOC = 3)
      PARAMETER (DWELL1 = 4)
      PARAMETER (DWELL2 = 5)
      PARAMETER (DWELL4 = 6)
      PARAMETER (IMCFLG = 7)
      PARAMETER (TIMSIZ = 8)
      PARAMETER (FLPFLG = 15)
      PARAMETER (SNSLN  = 185)
      PARAMETER (SWFPX  = 187)
      PARAMETER (SEFPX  = 189)
      PARAMETER (SNFLN  = 191)
      PARAMETER (SSFLN  = 193)
      PARAMETER (NAVLOC = 307)
      PARAMETER (NAVEND = 1718)

      DOUBLE PRECISION  TE    , PHI   , PSI   , U     , SINU  , COSU
      DOUBLE PRECISION  SINOI , COSOI , SLAT  , ASC   , SINASC, COSASC
      DOUBLE PRECISION  SYAW  , W     , SW    , CW    , S2W   , C2W
      DOUBLE PRECISION  SW1   , CW1   , SW3   , CW3   , GATTgvarnv3
     +
      DOUBLE PRECISION  SUBLAT, SUBLON, SECS  , WA
      REAL              RPARMS(MXCDSZ)
      DOUBLE PRECISION  IMGTIM, EPOCH , TIMEXgvarnv3
     + , TIME50gvarnv3
     +, R     , B(3,3)
      DOUBLE PRECISION  AEC   , TS    , DR    , LAM   , DLAT  , DYAW
      DOUBLE PRECISION  AEBE2C, AEBE3C, AEBE4C, FERC
      INTEGER      IFUNC , LIT   , ITYPE , IMC   , YEAR  , DAY
      INTEGER      IFTOK , HOUR  , MINUTS, INSTR , IPARMS(MXCDSZ)
      INTEGER      COUNT , OFFSET, LOOP  , IPARM2(MXCDSZ), TIME(2)
      INTEGER      IFLIP
      LOGICAL      BTEST
      CHARACTER*4  CLIT
      CHARACTER*12 CFZ

      EQUIVALENCE(IPARM2,RPARMS)

      COMMON /GVRCOMgvarnv3/
     + ITYPE , INSTR , SUBLAT, SUBLON, IFLIP
      COMMON /RADCOMgvarnv3/
     + AEC   , FERC  , AEBE2C, AEBE3C, AEBE4C
      COMMON /SAVCOMgvarnv3/
     + B     , DR    , PHI

      INTEGER      I     , J     , RELLST(40,2), INTLST(55)

      DATA ((RELLST(I,J),J=1,2),I=1,31) / 5,11,14,64,66,95,99,101,104,
     &        106,109,111,114,116,117,119,121,150,154,156,159,161,164,
     &        166,169,171,172,174,176,205,209,211,214,216,219,221,224,
     &        226,227,229,231,260,264,266,269,271,274,276,279,284,286,
     &        315,319,321,324,326,329,331,334,336,-1,-1 /

      DATA (INTLST(I),I=1,55) / 1,2,12,13,65,96,97,98,102,103,107,108,
     &    112,113,120,151,152,153,157,158,162,163,167,168,175,206,207,
     &    208,212,213,217,218,222,223,230,261,262,263,267,268,272,273,
     &    277,278,285,316,317,318,322,323,327,328,332,333,-1 /

      AEC    = AE
      FERC   = FER
      AEBE2C = DBLE(AEBE2)
      AEBE3C = DBLE(AEBE3)
      AEBE4C = DBLE(AEBE4)

      IF (IFUNC.EQ.1) THEN
        IF (IPARMS(STTYPE).NE.LIT('GVAR')) THEN
          NV3INIgvar
     + = -1
          RETURN
        ENDIF
        ITYPE = 1

        DO 1 LOOP = 1, MXCDSZ
 1        IPARM2(LOOP) = IPARMS(LOOP)

        COUNT = 1
        RPARMS(IMGTM) = REAL(IPARM2(IMGTM))/1000.
 2      IF (RELLST(COUNT,1).EQ.-1) GOTO 4
          OFFSET = 1
          IF (RELLST(COUNT,1).GT.CUTOF1) OFFSET = 13
          IF (RELLST(COUNT,1).GT.CUTOF2) OFFSET = 31
          DO 3 LOOP=RELLST(COUNT,1),RELLST(COUNT,2)
            IF (LOOP.EQ.14.OR.LOOP.EQ.61.OR.(MOD(LOOP-8,55).EQ.0.AND.
     &                                               LOOP.NE.8)) THEN
              RPARMS(LOOP+OFFSET) = REAL(IPARM2(LOOP+OFFSET))/100.
            ELSE
              RPARMS(LOOP+OFFSET) = REAL(IPARM2(LOOP+OFFSET))/10000000.
            ENDIF
 3        CONTINUE
          COUNT = COUNT + 1
        GOTO 2

 4      INSTR = IPARMS(IMGSND)

        CALL SETCONgvarnv3
     +(INSTR, IPARMS(IOFNC), IPARMS(IOFNI), IPARMS(IOFEC),
     &                                                  IPARMS(IOFEI))

        YEAR    = 1900 + IPARMS(IMGDAY) / 1000
        DAY     = IPARMS(IMGDAY) - IPARMS(IMGDAY) / 1000 * 1000
        HOUR    = RPARMS(IMGTM) / 10000
        MINUTS  = RPARMS(IMGTM) / 100 - HOUR * 100
        SECS    = RPARMS(IMGTM) - REAL(100*MINUTS) - REAL(10000*HOUR)
        IMGTIM  = TIMEXgvarnv3
     +(YEAR, DAY, HOUR, MINUTS, SECS)
        TIME(1) = IFTOK(CFZ(IPARMS(ETIME)))
        TIME(2) = IFTOK(CFZ(IPARMS(ETIME+1)))
        EPOCH   = TIME50gvarnv3
     +(TIME)
        IMC     = 1
        IFLIP   = 1
        IF (BTEST(IPARMS(IMCACT),IMCFLG)) IMC = 0
        IF (BTEST(IPARMS(IYFLIP),FLPFLG)) IFLIP = -1
        CALL DDEST('IFLIP is set to',IFLIP)
        IF (IFLIP.eq.-1) CALL DDEST('USING FLIPPED NAV',0)

        LAM = RPARMS(REFLON)
        DR  = RPARMS(REFDIS)
        PHI = RPARMS(REFLAT)
        PSI = RPARMS(REFYAW)

        ROLL  = RPARMS(RATROL)
        PITCH = RPARMS(RATPTC)
        YAW   = RPARMS(RATYAW)
        RMA   = 0.
        PMA   = 0.

        IF (IMC.NE.0) THEN

          DR  = 0.
          PHI = 0.
          PSI = 0.

          TS = IMGTIM - EPOCH

          W   = 0.729115D - 4 * 60.0D0 * TS
          SW  = DSIN(W)
          CW  = DCOS(W)
          SW1 = DSIN(0.927*W)
          CW1 = DCOS(0.927*W)
          S2W = DSIN(2.*W)
          C2W = DCOS(2.*W)
          SW3 = DSIN(1.9268*W)
          CW3 = DCOS(1.9268*W)

          LAM = LAM + RPARMS(LDR1) + (RPARMS(LDR2) + RPARMS(LDR3)*W) * W
     &        + (RPARMS(LDR10)*SW1 + RPARMS(LDR11)*CW1 + RPARMS(LDR4)*SW
     &        + RPARMS(LDR5)*CW + RPARMS(LDR6)*S2W + RPARMS(LDR7)*C2W
     &        + RPARMS(LDR8)*SW3+RPARMS(LDR9)*CW3 + W*(RPARMS(LDR12)*SW
     &        + RPARMS(LDR13)*CW))*2.

          DR = DR + RPARMS(RDDR1) + RPARMS(RDDR2)*CW + RPARMS(RDDR3)*SW
     &          + RPARMS(RDDR4)*C2W + RPARMS(RDDR5)*S2W + RPARMS(RDDR6)
     &          * CW3+RPARMS(RDDR7)*SW3 + RPARMS(RDDR8)*CW1
     &          + RPARMS(RDDR9)*SW1 + W*(RPARMS(RDDR10)*CW
     &          + RPARMS(RDDR11)*SW)

          DLAT = RPARMS(DGL1) + RPARMS(DGL2)*CW + RPARMS(DGL3)*SW
     &        + RPARMS(DGL4)*C2W + RPARMS(DGL5)*S2W + W*(RPARMS(DGL6)*CW
     &        + RPARMS(DGL7)*SW) + RPARMS(DGL8)*CW1+RPARMS(DGL9)*SW1

          PHI = PHI + DLAT * (1. + DLAT * DLAT / 6.)

          DYAW = RPARMS(DOY1) + RPARMS(DOY2)*SW + RPARMS(DOY3)*CW
     &         + RPARMS(DOY4)*S2W + RPARMS(DOY5)*C2W
     &         + W*(RPARMS(DOY6)*SW + RPARMS(DOY7)*CW)
     &         + RPARMS(DOY8)*SW1 + RPARMS(DOY9)*CW1

          PSI = PSI + DYAW * (1. + DYAW * DYAW / 6.)

        ENDIF

        SLAT  = DSIN(PHI)
        SYAW  = DSIN(PSI)
        SINOI = SLAT**2 + SYAW**2
        COSOI = DSQRT(1.-SINOI)
        SINOI = DSQRT(SINOI)

        IF (SLAT .EQ. 0.0D0 .AND. SYAW .EQ. 0.0D0) THEN
          U = 0.0D0
        ELSE
          U = DATAN2(SLAT,SYAW)
        ENDIF

        SINU  = DSIN(U)
        COSU  = DCOS(U)

        ASC    = LAM-U
        SINASC = DSIN(ASC)
        COSASC = DCOS(ASC)

        SUBLAT = DATAN(AEBE2C*DTAN(PHI))

        SUBLON = ASC+DATAN2(COSOI*SINU,COSU)

        B(1,2) = -SINASC*SINOI
        B(2,2) =  COSASC*SINOI
        B(3,2) = -COSOI
        B(1,3) = -COSASC*COSU+SINASC*SINU*COSOI
        B(2,3) = -SINASC*COSU-COSASC*SINU*COSOI
        B(3,3) = -SLAT
        B(1,1) = -COSASC*SINU-SINASC*COSU*COSOI
        B(2,1) = -SINASC*SINU+COSASC*COSU*COSOI
        B(3,1) =  COSU*SINOI

        R     = (NOMORB+DR)/AEC
        XS(1) = -B(1,3)*R
        XS(2) = -B(2,3)*R
        XS(3) = -B(3,3)*R

        Q3 = XS(1)**2 + XS(2)**2 + AEBE2C * XS(3)**2 - 1.0

        IF (IMC.NE.0) THEN

          WA = RPARMS(61)*TS

          TE = TS - RPARMS(EXPTIM)

          ROLL = ROLL + GATTgvarnv3
     +(RAAWDS,RPARMS,IPARMS,WA,TE)

          PITCH = PITCH + GATTgvarnv3
     +(PAAWDS,RPARMS,IPARMS,WA,TE)

          YAW = YAW + GATTgvarnv3
     +(YAAWDS,RPARMS,IPARMS,WA,TE)

          RMA = GATTgvarnv3
     +(RMAWDS,RPARMS,IPARMS,WA,TE)

          PMA = GATTgvarnv3
     +(PMAWDS,RPARMS,IPARMS,WA,TE)

          ROLL   = ROLL + RPARMS(IMCROL)
          PITCH  = PITCH + RPARMS(IMCPTC)
          YAW    = YAW + RPARMS(IMCYAW)
        ENDIF

        CALL INST2Egvarnv3
     +(ROLL,PITCH,YAW,B,BT)

      ELSEIF (IFUNC.EQ.2) THEN
        IF (INDEX(CLIT(IPARMS(1)),'LL').NE.0) ITYPE=1
        IF (INDEX(CLIT(IPARMS(1)),'XY').NE.0) ITYPE=2
      ENDIF
      NV3INIgvar
     +=0
      RETURN
      END

      INTEGER FUNCTION NV3SAEgvar
     +(XLIN,XELE,XDUM,XLAT,XLON,Z)

      IMPLICIT NONE

      REAL         XLIN  , XELE  , XDUM  , XLAT  , XLON  , Z
      DOUBLE PRECISION   RL    , RP    , E     , S
      REAL         YLAT  , YLON
      DOUBLE PRECISION   SUBLAT, SUBLON, EVLNgvarnv3
     +  , SCPXgvarnv3
     +  , TMPLAT, TMPLON
      INTEGER      INSTR , ITYPE , STAT, IFLIP

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER      OASIZE, PCOEFS, RMACFS, CUTOF1, CUTOF2

      PARAMETER (OASIZE = 336)
      PARAMETER (PCOEFS = 117)
      PARAMETER (RMACFS = 227)
      PARAMETER (CUTOF1 = 116)
      PARAMETER (CUTOF2 = 226)

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      COMMON /GVRCOMgvarnv3/
     + ITYPE, INSTR , SUBLAT, SUBLON, IFLIP

      RL = XLIN
      RP = XELE

      IF (INSTR.EQ.2) THEN
        RL = (RL+9.)/10.
        RP = (RP+9.)/10.
      ENDIF

      E = EVLNgvarnv3
     +(INSTR,RL)
      S = SCPXgvarnv3
     +(INSTR,RP)

      CALL LPOINTgvarnv3
     +(INSTR,IFLIP,E,S,TMPLAT,TMPLON,STAT)
      IF (STAT.NE.0) GOTO 900
      TMPLAT = TMPLAT * DEG
      TMPLON = TMPLON * DEG

      TMPLON = -TMPLON

      IF (ITYPE.EQ.2) THEN
        YLAT = TMPLAT
        YLON = TMPLON
        CALL LLCART(YLAT,YLON,XLAT,XLON,Z)
      ELSE
	XLAT = TMPLAT
	XLON = TMPLON
      ENDIF

      NV3SAEgvar
     +=0
      RETURN

 900  CONTINUE
      XLAT = TMPLAT
      XLON = -TMPLON
      NV3SAEgvar
     +=-1
      RETURN
      END

      INTEGER FUNCTION NV3EASgvar
     +(ZLAT,ZLON,Z,XLIN,XELE,XDUM)

      IMPLICIT NONE

      REAL         ZLAT  , ZLON  , Z     , XLIN  , XELE  , XDUM
      REAL         X     , Y
      DOUBLE PRECISION TMPLIN, TMPELE, E     , S     , TMPLAT, TMPLON
      DOUBLE PRECISION SUBLAT, SUBLON
      INTEGER      INSTR , ITYPE , IER, IFLIP

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER      OASIZE, PCOEFS, RMACFS, CUTOF1, CUTOF2

      PARAMETER (OASIZE = 336)
      PARAMETER (PCOEFS = 117)
      PARAMETER (RMACFS = 227)
      PARAMETER (CUTOF1 = 116)
      PARAMETER (CUTOF2 = 226)

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      COMMON /GVRCOMgvarnv3/
     + ITYPE, INSTR, SUBLAT, SUBLON, IFLIP

      NV3EASgvar
     + = 0

      IF (ITYPE.EQ.2) THEN
        X = ZLAT
        Y = ZLON
        CALL CARTLL(X,Y,Z,ZLAT,ZLON)
      ENDIF

      IF (ABS(ZLAT).GT.90.) THEN
        NV3EASgvar
     + = -1
        RETURN
      ENDIF

      TMPLAT = ZLAT
      TMPLON = ZLON

      CALL GPOINTgvarnv3
     +(INSTR,IFLIP,TMPLAT*RAD,-TMPLON*RAD,E,S,IER)

      IF (IER.NE.0) THEN
        NV3EASgvar
     + = -1
        RETURN
      ENDIF

      CALL EVSC2Lgvarnv3
     +(INSTR,E,S,TMPLIN,TMPELE)

      XLIN = TMPLIN
      XELE = TMPELE

      IF (INSTR.EQ.2) THEN
        XLIN = XLIN*10.-9.
        XELE = XELE*10.-9.
      ENDIF

      RETURN
      END

      INTEGER FUNCTION NV3OPTgvar
     +(IFUNC,XIN,XOUT)

      IMPLICIT NONE

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER      IFUNC , LIT   , ITYPE , INSTR , JDAY  , JTIME
      INTEGER      IROUND, M0ITIME, LASDAY, LASTIM, IFLIP
      REAL         FLAT  , FLON  , GHA   , XIN(*)
      REAL         DEC   , XLAT  , XLON  , XOUT(*)
      DOUBLE PRECISION AEC , FERC  , AEBE2C, AEBE3C, AEBE4C, B(3,3)
      DOUBLE PRECISION SUBLAT, SUBLON, R     , DR    , PHI

      COMMON /GVRCOMgvarnv3/
     + ITYPE , INSTR , SUBLAT, SUBLON, IFLIP
      COMMON /RADCOMgvarnv3/
     + AEC   , FERC  , AEBE2C, AEBE3C, AEBE4C
      COMMON /SAVCOMgvarnv3/
     + B     , DR    , PHI

      DATA LASDAY/-1/,LASTIM/-1/

      NV3OPTgvar
     + = -1

      IF (IFUNC.EQ.LIT('SPOS')) THEN
        XOUT(1) = SUBLAT * DEG
        XOUT(2) = -SUBLON * DEG
        XOUT(2) = AMOD(XOUT(2),360.)
        NV3OPTgvar
     + = 0

      ELSEIF (IFUNC.EQ.LIT('HGT ')) THEN
        AEC    = AE + DBLE(XIN(1))
        FERC   = 1.D0 - ((6356.7533D0 + DBLE(XIN(1))) / AEC)
        AEBE2C = 1.D0 / ((1.D0 - FERC)*(1.D0 - FERC))
        AEBE3C = AEBE2C - 1.D0
        AEBE4C = (1.D0-FERC)*(1.D0-FERC)*(1.D0-FERC)*(1.D0-FERC) - 1.D0

        SUBLAT = DATAN(AEBE2C*DTAN(PHI))
        R      = (NOMORB+DR)/AEC
        XS(1)  = -B(1,3)*R
        XS(2)  = -B(2,3)*R
        XS(3)  = -B(3,3)*R
        Q3     = XS(1)**2 + XS(2)**2 + AEBE2C * XS(3)**2 - 1.0
        NV3OPTgvar
     + = 0

      ELSEIF (IFUNC.EQ.LIT('ANG ')) THEN
        JDAY  = IROUND(XIN(1))
        JTIME = M0ITIME(XIN(2))
        FLAT  = XIN(3)
        FLON  = XIN(4)
        IF (JDAY.NE.LASDAY.OR.JTIME.NE.LASTIM) THEN
          CALL SOLARP(JDAY,JTIME,GHA,DEC,XLAT,XLON)
          LASDAY = JDAY
          LASTIM = JTIME
        ENDIF
        CALL GVRANGgvarnv3
     +(JDAY, JTIME, FLAT, FLON, GHA, DEC, XOUT(1), XOUT(2),
     &                                                          XOUT(3))
        NV3OPTgvar
     + = 0
      ENDIF

      RETURN
      END

      SUBROUTINE SETCONgvarnv3
     +(INSTR, NADNSC, NADNSI, NADEWC, NADEWI)

      IMPLICIT NONE

      INTEGER INSTR, NADNSC, NADNSI, NADEWC, NADEWI
      character*12 cfg

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      INCMAX(1)  = 6136
      INCMAX(2)  = 2805
      ELVINC(1)  = 8.E-6
      ELVINC(2)  = 17.5E-6
      SCNINC(1)  = 16.E-6
      SCNINC(2)  = 35.E-6
      ELVLN(1)   = 28.E-6
      ELVLN(2)   = 280.E-6
      SCNPX(1)   = 16.E-6
      SCNPX(2)   = 280.E-6
      ELVMAX(1)  = 0.220896
      ELVMAX(2)  = 0.22089375
      SCNMAX(1)  = 0.24544
      SCNMAX(2)  = 0.2454375
      NSNOM(1)   = 4.5*INCMAX(1)*ELVINC(1)
      NSNOM(2)   = 4.5*INCMAX(2)*ELVINC(2)
      EWNOM(1)   = 2.5*INCMAX(1)*SCNINC(1)
      EWNOM(2)   = 2.5*INCMAX(2)*SCNINC(2)

      if (nadnsc .ne. 0 .and. nadnsi .ne. 0 .and. nadewc .ne. 0
     &                                 .and. nadewi .ne. 0) then
	IF (INSTR .EQ. 1) THEN

           ELVMAX(INSTR) = (NADNSC*INCMAX(INSTR)+NADNSI)
     &                                             *ELVINC(INSTR)

        ELSE

           ELVMAX(INSTR) = ((9-NADNSC)*INCMAX(INSTR)-NADNSI)
     &                                             *ELVINC(INSTR)

	ENDIF

        SCNMAX(INSTR) = (NADEWC*INCMAX(INSTR)+NADEWI)
     &                                            *SCNINC(INSTR)
      endif

      RETURN
      END

      FUNCTION TIMEXgvarnv3
     +(NY,ND,NH,NM,S)

      IMPLICIT NONE

      INTEGER      ND    , NH    , NM    , J     , NY
      DOUBLE PRECISION       TIMEXgvarnv3
     + , S

      J = ND + 1461 * (NY + 4799) / 4 - 3 * ((NY + 4899) / 100) / 4
     &                                                        - 2465022

      TIMEXgvarnv3
     + = J * 1440.D0 + NH * 60.D0 + NM + S / 60.D0

      RETURN
      END

      FUNCTION TIME50gvarnv3
     +(I)

      IMPLICIT NONE

      INTEGER      NY    , ND    , NH    , NM    , J     , I(2)
      INTEGER      IAA   , IAB   , NBC   , IAC   , DEF
      DOUBLE PRECISION       TIME50gvarnv3
     +, S

      NY  = I(1) / 10000
      IAA = I(1) - (NY*10000)

      ND  = (I(1) - (NY*10000)) * .1
      IAB = (IAA - (ND * 10)) * 10
      NBC = I(2) / 10000000.
      IAC = I(2) - (NBC * 10000000)
      NH  = IAB + NBC
      DEF = I(2) - IAC
      NM  = IAC * .00001
      S   = (I(2) - (DEF + (NM * 100000))) * .001

      J = ND + 1461 * (NY + 4799) / 4 - 3 * ((NY + 4899) / 100) / 4
     &                                                       - 2465022

      TIME50gvarnv3
     + = J * 1440.D0 + NH * 60.D0 + NM + S / 60.D0

      RETURN
      END

      DOUBLE PRECISION FUNCTION GATTgvarnv3
     +(K0,RPARMS,IPARMS,WA,TE)

      IMPLICIT NONE

      INTEGER      MXCDSZ

      PARAMETER (MXCDSZ = 5*128)

      INTEGER K0
      REAL RPARMS(MXCDSZ)
      INTEGER IPARMS(MXCDSZ)
      DOUBLE PRECISION WA
      DOUBLE PRECISION TE

      INTEGER      KKK   , I     , J     , M     , L     , LL    , K
      DOUBLE PRECISION       IR    , JR    , MR    , ATT

      K   = K0
      ATT = RPARMS(K+2)

      IF (TE.GE.0) ATT = ATT + RPARMS(K) * DEXP(-TE / RPARMS(K+1))

      IR = REAL(IPARMS(K+3))
      I  = NINT(IR)

      DO 10 L=1,I
        ATT = ATT + RPARMS(K+2*L+2) * DCOS(WA*L+RPARMS(K+2*L+3))
 10   CONTINUE

      K = K + 34

      IR  = REAL(IPARMS(K))
      KKK = IPARMS(K)

      DO 20 L=1,KKK
        LL = K + 5 * L

        JR = REAL(IPARMS(LL-4))

        MR  = REAL(IPARMS(LL-3))
        J   = NINT(JR)
        M   = NINT(MR)
        ATT = ATT + RPARMS(LL-2) * ((WA - RPARMS(LL))**MR)
     &                                      * DCOS(JR*WA+RPARMS(LL-1))
 20   CONTINUE

      GATTgvarnv3
     + = ATT
      RETURN
      END

      SUBROUTINE EVSC2Lgvarnv3
     +(INSTR,ELEV,SCAN,RL,RP)

      IMPLICIT NONE

      INTEGER INSTR
      DOUBLE PRECISION ELEV
      DOUBLE PRECISION SCAN
      DOUBLE PRECISION RL
      DOUBLE PRECISION RP

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      RL = (ELVMAX(INSTR) - ELEV) / ELVLN(INSTR)
      IF (INSTR.EQ.1) THEN
        RL = RL + 4.5
      ELSE
        RL = RL + 2.5
      ENDIF

      RP = (SCNMAX(INSTR) + SCAN) / SCNPX(INSTR) + 1.

      RETURN
      END

      DOUBLE PRECISION FUNCTION EVLNgvarnv3
     +(INSTR,RLINE)

      IMPLICIT NONE

      INTEGER INSTR
      DOUBLE PRECISION  RLINE

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      IF (INSTR.EQ.1) THEN
        EVLNgvarnv3
     + = ELVMAX(INSTR) - (RLINE - 4.5) * ELVLN(INSTR)
      ELSE
        EVLNgvarnv3
     + = ELVMAX(INSTR) - (RLINE - 2.5) * ELVLN(INSTR)
      ENDIF

      RETURN
      END

      DOUBLE PRECISION FUNCTION SCPXgvarnv3
     +(INSTR,PIX)

      IMPLICIT NONE

      INTEGER INSTR
      DOUBLE PRECISION PIX

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      SCPXgvarnv3
     + = (PIX - 1.) * SCNPX(INSTR) - SCNMAX(INSTR)

      RETURN
      END

      SUBROUTINE INST2Egvarnv3
     +(R,P,Y,A,AT)

      IMPLICIT NONE

      DOUBLE PRECISION R
      DOUBLE PRECISION P
      DOUBLE PRECISION Y
      DOUBLE PRECISION A(3,3)
      DOUBLE PRECISION AT(3,3)

      DOUBLE PRECISION       RPY(3,3)
      INTEGER    I     , J

      RPY(1,1) = 1. - 0.5 * (P * P + Y * Y)
      RPY(1,2) = -Y
      RPY(1,3) = P
      RPY(2,1) = Y + P * R
      RPY(2,2) = 1. - 0.5 * (Y * Y + R * R)
      RPY(2,3) = -R
      RPY(3,1) = -P + R * Y
      RPY(3,2) = R + P * Y
      RPY(3,3) = 1. - 0.5 * (P * P + R * R)

      DO 20 I=1,3
        DO 10 J=1,3
          AT(I,J) = A(I,1) * RPY(1,J) + A(I,2) * RPY(2,J) + A(I,3)
     &                                                    * RPY(3,J)
 10     CONTINUE
 20   CONTINUE

      RETURN
      END

      SUBROUTINE LPOINTgvarnv3
     +(INSTR,FLIP_FLG,ALPHA0,ZETA0,RLAT,RLON,IERR)

      IMPLICIT NONE

      INTEGER*4 INSTR
      INTEGER*4 FLIP_FLG

      DOUBLE PRECISION   ALPHA0
      DOUBLE PRECISION   ALPHA
      DOUBLE PRECISION   ZETA0
      DOUBLE PRECISION   ZETA
      DOUBLE PRECISION   RLAT
      DOUBLE PRECISION   RLON
      INTEGER IERR

      DOUBLE PRECISION AEC, FERC, Q1, Q2, D, H, G1(3)
      DOUBLE PRECISION SA, CA, DA, DZ, D1, CZ, G(3)
      DOUBLE PRECISION       U(3)
      DOUBLE PRECISION       AEBE2C, AEBE3C, AEBE4C
      DOUBLE PRECISION SZ, FF, DOFF

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      COMMON /RADCOMgvarnv3/
     + AEC   , FERC  , AEBE2C, AEBE3C, AEBE4C

      IERR=1
      FF = FLIP_FLG
      IF (INSTR.EQ.2) FF = - FF
      DOFF = SCNMAX(INSTR) - EWNOM(INSTR)
      ALPHA = ALPHA0 - ALPHA0*ZETA0*DOFF
      ZETA  = ZETA0 + 0.5*ALPHA0*ALPHA0*DOFF

      CA = DCOS(ALPHA)
      SA = DSIN(ALPHA)
      CZ = DCOS(ZETA)
      DA = ALPHA-PMA*SA*(FF/CZ+DTAN(ZETA))-RMA*(1.0D0-CA/CZ)
      DZ = ZETA + FF*RMA * SA

      CZ = DCOS(DZ)

      G(1) = DSIN(DZ)
      G(2) = -CZ * DSIN(DA)
      G(3) = CZ * DCOS(DA)

      G1(1) = BT(1,1) * G(1) + BT(1,2) * G(2) + BT(1,3) * G(3)
      G1(2) = BT(2,1) * G(1) + BT(2,2) * G(2) + BT(2,3) * G(3)
      G1(3) = BT(3,1) * G(1) + BT(3,2) * G(2) + BT(3,3) * G(3)

      Q1 = G1(1)**2 + G1(2)**2 + AEBE2C * G1(3)**2
      Q2 = XS(1) * G1(1) + XS(2) * G1(2) + AEBE2C * XS(3) * G1(3)
      D  = Q2 * Q2 - Q1 * Q3
      IF (DABS(D).LT.1.D-9) D=0.

         IF (D.LT.0) THEN
            RLAT=999999.
            RLON=999999.
            RETURN
         END IF
         D=DSQRT(D)
         H=-(Q2+D)/Q1
         U(1)=XS(1)+H*G1(1)
         U(2)=XS(2)+H*G1(2)
         U(3)=XS(3)+H*G1(3)
      D1 = U(3) / DSQRT(U(1)**2 + U(2)**2 + U(3)**2)

      RLAT = DATAN(AEBE2C * D1 / DSQRT(1. - D1 * D1))
      RLON = DATAN2(U(2),U(1))
      IERR = 0

         RLAT=ATAN(AEBE2*D1/SQRT(1.-D1*D1))
         RLON=ATAN2(U(2),U(1))
         IERR=0

      RETURN
      END

      SUBROUTINE GPOINTgvarnv3
     +(INSTR,FLIP_FLG,RLAT,RLON,ALF,GAM,IERR)

      IMPLICIT NONE

      INTEGER*4 INSTR
      INTEGER*4 FLIP_FLG

      DOUBLE PRECISION   RLAT
      DOUBLE PRECISION   RLON
      DOUBLE PRECISION   ALF
      DOUBLE PRECISION   GAM
      INTEGER IERR

      DOUBLE PRECISION F(3)  , AEC   , FERC  , AEBE2C, AEBE3C, AEBE4C
      DOUBLE PRECISION FT(3) , U(3)  , SING  , SLAT  , W1    , W2

      DOUBLE PRECISION Z,CZ,SA,FF,DOFF,ALPHA,ALPHA1

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION  Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA

      INTEGER INCMAX(2)
      REAL ELVMAX(2)
      REAL SCNMAX(2)
      REAL ELVINC(2)
      REAL SCNINC(2)
      REAL ELVLN(2)
      REAL SCNPX(2)
      REAL EWNOM(2)
      REAL NSNOM(2)

      COMMON /INSTCOgvarnv3/
     + INCMAX,ELVMAX,SCNMAX,
     &   ELVINC,SCNINC,ELVLN,SCNPX,EWNOM,NSNOM

      COMMON /RADCOMgvarnv3/
     + AEC   , FERC  , AEBE2C, AEBE3C, AEBE4C

      SING = DSIN(RLAT)
      W1   = AEBE4C * SING * SING

      FF = FLIP_FLG
      IF (INSTR.EQ.2) FF = - FF
      DOFF = SCNMAX(INSTR) - EWNOM(INSTR)
      SLAT = ((0.375 * W1 - 0.5) * W1 + 1.) * SING / AEBE2C

      W2 = SLAT * SLAT
      W1 = AEBE3C * W2
      W1 = (0.375 * W1 - 0.5) * W1 + 1.

      U(3) = SLAT * W1
      W2   = W1 * DSQRT(1. - W2)
      U(1) = W2 * DCOS(RLON)
      U(2) = W2 * DSIN(RLON)

      F(1) = U(1) - XS(1)
      F(2) = U(2) - XS(2)
      F(3) = U(3) - XS(3)
      W2   = U(1) * SNGL(F(1)) + U(2) * SNGL(F(2))+ U(3) * SNGL(F(3))
     &                                                   * AEBE2C

         IF (W2.GT.0.) THEN
                   IERR=1
                   ALF=99999.
                   GAM=99999.
                   RETURN
          END IF
      FT(1) = BT(1,1) * F(1) + BT(2,1) * F(2) + BT(3,1) * F(3)
      FT(2) = BT(1,2) * F(1) + BT(2,2) * F(2) + BT(3,2) * F(3)
      FT(3) = BT(1,3) * F(1) + BT(2,3) * F(2) + BT(3,3) * F(3)

      GAM  = DATAN(FT(1) / DSQRT(FT(2)**2 + FT(3)**2))
      ALF  = -DATAN(FT(2) / FT(3))
      W1   = DSIN(ALF)
      W2   = DCOS(GAM)

      ALPHA1  = ALF + RMA * (1. - DCOS(ALF) / W2) + PMA * W1 *
     &                                   (FF / W2 + DTAN(GAM))
      GAM  = GAM - FF * RMA * W1
      ALF  = ALPHA1 + ALPHA1 * GAM * DOFF
      GAM  = GAM - 0.5 * ALPHA1 * ALPHA1 * DOFF
      IERR = 0

      RETURN
      END

      SUBROUTINE GVRANGgvarnv3
     +(JDAY,JTIME,XLAT,XLON,GHA,DEC,SATANG,SUNANG,RELAN
     &G)

      DOUBLE PRECISION PI
           PARAMETER (PI=3.141592653589793D0)
      DOUBLE PRECISION DEG
           PARAMETER (DEG=180.D0/PI)
      DOUBLE PRECISION RAD
           PARAMETER (RAD=PI/180.D0)
      DOUBLE PRECISION NOMORB
           PARAMETER (NOMORB=42164.365D0)
      DOUBLE PRECISION AE
           PARAMETER (AE=6378.137D0)
      DOUBLE PRECISION FER
           PARAMETER (FER=1.D0-(6356.7533D0/AE))
      REAL AEBE2
           PARAMETER (AEBE2=1.D0/(1.D0-FER)**2)
      REAL AEBE3
           PARAMETER (AEBE3=AEBE2-1.)
      REAL AEBE4
           PARAMETER (AEBE4=(1.D0-FER)**4-1.)

      DOUBLE PRECISION XS(3)
      DOUBLE PRECISION BT(3,3)
      DOUBLE PRECISION Q3
      DOUBLE PRECISION PITCH,ROLL,YAW
      REAL PMA,RMA
         COMMON /ELCOMMgvarnv3/
     + XS,BT,Q3,PITCH,ROLL,YAW,PMA,RMA
      DATA IDAY/0/
      DATA R/6371.221/
      RDPDG=PI/180.0
      IF(IDAY.EQ.JDAY)GO TO 1
      IDAY=JDAY
      INORB=0
 1    PICTIM=FTIME(JTIME)
      XSAT = XS(1) * AE
      YSAT = XS(2) * AE
      ZSAT = XS(3) * AE

      HEIGHT=SQRT(XSAT**2+YSAT**2+ZSAT**2)
      YLAT=RDPDG*XLAT
      YLAT=GEOLAT(YLAT,1)
      YLON=RDPDG*XLON
      SLAT=SIN(YLAT)
      CLAT=COS(YLAT)
      SLON=SIN(YLON)
      CLON=COS(YLON)
      XSAM=R*CLAT*CLON
      YSAM=R*CLAT*SLON
      ZSAM=R*SLAT
      SNLG=-PICTIM*PI/12.0-RDPDG*GHA
      SNDC=RDPDG*DEC
      COSDEC=COS(SNDC)
      US=COS(SNLG)*COSDEC
      VS=SIN(SNLG)*COSDEC
      WS=SIN(SNDC)
      SUNANG=ACOS((US*XSAM+VS*YSAM+WS*ZSAM)/R)/RDPDG
      XVEC=XSAT-XSAM
      YVEC=YSAT-YSAM
      ZVEC=ZSAT-ZSAM
      XFACT=SQRT(XVEC**2+YVEC**2+ZVEC**2)
      SATANG=ACOS((XVEC*XSAM+YVEC*YSAM+ZVEC*ZSAM)/(R*XFACT))/RDPDG
      X1=CLAT*CLON
      Y1=CLAT*SLON
      Z1=SLAT
      X2=SLON
      Y2=-CLON
      X3=-SLAT*CLON
      Y3=-SLAT*SLON
      Z3=CLAT
      XC1=US-X1
      YC1=VS-Y1
      ZC1=WS-Z1
      XC2=XSAT/HEIGHT-X1
      YC2=YSAT/HEIGHT-Y1
      ZC2=ZSAT/HEIGHT-Z1
      XAN1=XC1*X3+YC1*Y3+ZC1*Z3
      XAN2=XC2*X3+YC2*Y3+ZC2*Z3
      YAN1=XC1*X2+YC1*Y2
      YAN2=XC2*X2+YC2*Y2
      XAN3=XAN1*XAN2+YAN1*YAN2
      YAN3=-YAN1*XAN2+XAN1*YAN2
      RELANG=ATAN2(YAN3,XAN3)/RDPDG
      RELANG=ABS(RELANG)
      RETURN
      END


SUBROUTINE SEDZLJ_SLOPE
  USE GLOBAL
  IMPLICIT NONE
  ! CALCULATES slope change on shear
  !
  ! REVISION DATE :  Nov 19, 2009
  ! Craig Jones and Scott James
  !**************************************************************************
  ! Check to see if we've set a constant Tau
  INTEGER L
  DOUBLE PRECISION  XDIST,YDIST,DELZX,DELZY,VELMAG,DELX,DELY
  REAL DZBETA,DZTHETA,COSB,SINB,COST,TANT
  REAL ALPHA,AA,BB,FCO,FB,FG,TEMP1,TUNEP,TUNER
  AA=1.0             !Geometry factor (Lick, 2009, Figure 3.25)
  BB=1.0             !Geometry factor (Lick, 2009, Figure 3.25)
  ALPHA=ATAN(AA/BB)  !Geometry factor (Lick, 2009, p.96)
  FCO=0.0            !Cohesive force = 7 N/m^2 * D50(K)^2, but zero for non-cohesives (Lick, 2009, p.89)
  FB=0.0             !Binding force, but zero for non-cohesives (Lick, 2009, p.96)
  FG=1.0             !Gravitational force (Lick, 2008, Eqn. 3.8), arbitrarily set to 1 because it is irrelevant for non-cohesives
  TUNEP=1.0          !Bedload pitch tuning factor
  TUNER=1.0          !Bedload roll  tuning factor
  XDIST=1.0          !Initialize
  YDIST=1.0          !Initialize
  DO L=2,LA
  ! For Beta Angle "Pitch" and Theta Angle "Roll"
    IF(SUB(LEAST(L))/=0.AND.SUB(L)/=0.AND.SUB(LWEST(L))/=0)THEN           !Central differencing
      DELZX=BELV(LEAST(L))-BELV(LWEST(L))
      XDIST=0.5*DXP(LEAST(L))+DXP(L)+0.5*DXP(LWEST(L))                    !Across 3 cells
    ELSEIF(SUB(LEAST(L))==0.AND.SUB(L)/=0.AND.SUB(LWEST(L))/=0)THEN       !Forward differencing
      DELZX=BELV(L)-BELV(LWEST(L))
      XDIST=0.5*(DXP(L)+DXP(LWEST(L)))                               !Across 2 cells
    ELSEIF(SUB(LEAST(L))/=0.AND.SUB(L)/=0.AND.SUB(LWEST(L))==0)THEN
      DELZX=BELV(LEAST(L))-BELV(L)
      XDIST=0.5*(DXP(LEAST(L))+DXP(L))                               !Across 2 cells
    ELSE
      DELZX=0.0 !No active cells on either side
    ENDIF
    IF(SVB(LNC(L))/=0.AND.SVB(L)/=0.AND.SVB(LSC(L))/=0)THEN     !Central differencing
      DELZY=BELV(LNC(L))-BELV(LSC(L))
      YDIST=0.5*DYP(LNC(L))+DYP(L)+0.5*DYP(LSC(L))              !Across 3 cells
    ELSEIF(SVB(LNC(L))==0.AND.SVB(L)/=0.AND.SVB(LSC(L))/=0)THEN !Forward differencing
      DELZY=BELV(L)-BELV(LSC(L))
      YDIST=0.5*(DYP(L)+DYP(LSC(L)))                            !Across 2 cells
    ELSEIF(SVB(LNC(L))/=0.AND.SVB(L)/=0.AND.SVB(LSC(L))==0)THEN !Forward differencing
      DELZY=BELV(LNC(L))-BELV(L)
      YDIST=0.5*(DYP(LNC(L))+DYP(L))                            !Across 2 cells
    ELSE
      DELZY=0.0 !No active cells on either side
    ENDIF
    VELMAG=SQRT(U(L,1)**2+V(L,1)**2) !Local flow speed
    IF(VELMAG>0.0)THEN !Velocity directional vectors
      DELX=U(L,1)/VELMAG
      DELY=V(L,1)/VELMAG
    ELSE
      DELX=0.0
      DELY=0.0
    ENDIF
    DZBETA=DELX/XDIST*DELZX+DELY/YDIST*DELZY  !Change in bed elevation for the velocity pitch angle
    DZTHETA=DELY/XDIST*DELZX+DELX/YDIST*DELZY !Change in bed elevation fot the velocity roll  angle
    COSB=1.0/SQRT(1.0+DZBETA**2)              !Cosine of pitch angle
    SINB=DZBETA/SQRT(1.0+DZBETA**2)           !Sine of pitch angle
    COST=1.0/SQRT(1.0+DZTHETA**2)             !Cosine of roll angle
    TANT=DZTHETA                              !Tangent of roll angle
    TEMP1=(1.0+(FCO+FB)/(FG*COSB*COST))**2-(TANT/TAN(ALPHA))**2
!  Slope erosion from Willy Lick Work
    IF(TEMP1>0.0)THEN !Calculate shear stress and erosion scaling factor
      SH_SCALE(L)=MAX(0.1,BB/AA*SINB+COSB*COST*SQRT(TEMP1)) !Lick, 2009, Eqn.3.36
    ELSE
      SH_SCALE(L)=0.1 !Minimum value
    ENDIF
! Slope bedload factors from Lesser et al. summary
    ALPHA_PX(L)=1.0-TUNEP*(TAN(ALPHA)/(COS(ATAN(DELZX/XDIST))*(TAN(ALPHA)-DELZX/XDIST))-1.0) !Bedload velocity pitch angle x-correction
    ALPHA_RX(L,1:NSCM)=-TUNER*SQRT(TCRE(1:NSCM)/TAU(L))*DELZY/YDIST                          !Bedload velocity roll  angle x-correction
    ALPHA_PY(L)=1.0-TUNEP*(TAN(ALPHA)/(COS(ATAN(DELZY/YDIST))*(TAN(ALPHA)-DELZY/YDIST))-1.0) !Bedload velocity pitch angle y-correction
    ALPHA_RY(L,1:NSCM)=-TUNER*SQRT(TCRE(1:NSCM)/TAU(L))*DELZX/XDIST                          !Bedload velocity roll  angle y-correction
  ENDDO
  RETURN
END SUBROUTINE SEDZLJ_SLOPE


!! @file silo_converter.f90
!! @brief This module contains mathematical procedures for the program.

module mathf
    use,intrinsic :: iso_c_binding
    implicit none
    include 'fftw3.f03'

    ! FTTW
    type(C_PTR),private                     :: plan_f, plan_b
    double precision,allocatable,private    :: Kx(:), Ky(:), Kz(:), K(:,:), K2(:)
    complex(kind(0d0)),pointer,private      :: fx(:), Fk(:)
    complex(kind(0d0)),pointer,private      :: gx(:), Gk(:)

    !> FFTWで用いる\f$ f(x) \f$に対するポインタ
    type(C_PTR)                             :: pfx
    !> FFTWで用いる\f$ F(k) \f$に対するポインタ
    type(C_PTR)                             :: pFk
    !> FFTWで用いる\f$ g(x) \f$に対するポインタ
    type(C_PTR)                             :: pgx
    !> FFTWで用いる\f$ G(k) \f$に対するポインタ
    type(C_PTR)                             :: pGk

    ! CONSTANTS
    !> x軸方向の次元
    integer          :: Nx
    !> y軸方向の次元
    integer          :: Ny
    !> z軸方向の次元
    integer          :: Nz
    !> \f$ NL^2=N_x^2+N_y^2+N_z^2 \f$
    integer          :: NL

    !> 円周率
    double precision,  parameter :: pi   = acos(-1d0)  ! PI
    !> 虚数単位
    complex(kind(0d0)),parameter :: iu   = (0d0, 1d0)  ! Imaginary unit

    !> 空間の刻み幅
    double precision :: dh
    !> 空間の微小体積を格納する変数
    !! @details 1次元のときはdV=dh, 2次元のときはdV=dh^2, 3次元のときはdV=dh^3となる
    double precision                        :: dV          = 0d0

    ! MISC
    !> 全体のインデックス\f$ i \f$からx軸のインデックス\f$ ix \f$に射影する配列
    integer,allocatable                     :: i2ix(:)
    !> 全体のインデックス\f$ i \f$からy軸のインデックス\f$ iy \f$に射影する配列
    integer,allocatable                     :: i2iy(:)
    !> 全体のインデックス\f$ i \f$からz軸のインデックス\f$ iz \f$に射影する配列
    integer,allocatable                     :: i2iz(:)
    !> それぞれの軸のインデックス\f$ (ix,iy,iz) \f$から全体のインデックス\f$ i \f$に射影する配列
    integer,allocatable                     :: ixyz2i(:, :, :)

    !> FDM(有限差分法)の精度を指定する
    !! @details 係数は\f$ (2 \times N_d + 1) \f$個分使う
    integer,parameter,private               :: Nd = 3
    !> FDM(有限差分法)の係数を格納する変数
    double precision,allocatable            :: C1(:)
contains
    !> 初期化するための関数
    !! @details FFTWやFDM、座標インデックスなどの初期化を行う
    !! @param[in] dims 空間次元
    !! @param[in] step 空間の刻み幅
    subroutine initialize_mathf(dims, step)
        integer,intent(in)  :: dims(3)
        double precision    :: step
        integer             :: ix, iy, iz, i

        Nx = dims(1); Ny = dims(2); Nz = dims(3)
        NL = Nx * Ny * Nz
        dh = step
        dV = dh*dh*dh
        call new_fftw()

        allocate( C1(-Nd:Nd) )
        C1 = 0d0
        ! 1st derivative
        do i = 1, Nd
            if ( i == 1 ) then
                C1(1) = Nd / ( Nd + 1d0 )
            else
                C1(i) = -C1(i-1) * ( i - 1 ) * ( Nd - i + 1d0 ) / ( i * ( Nd + i ) )
            end if
            C1(-i) = -C1(i)
        end do
        C1 = C1 / dh

        allocate( i2ix(1:NL), i2iy(1:NL), i2iz(1:NL), ixyz2i(Nx,Ny,Nz) )
        i = 0
        do iz = 1, Nz
            do iy = 1, Ny
                do ix = 1, Nx
                    i = i + 1
                    i2ix(i) = ix
                    i2iy(i) = iy
                    i2iz(i) = iz
                    ixyz2i(ix,iy,iz) = i
                end do
            end do
        end do
    end subroutine

    !> プログラムで割り当てたメモリを開放する
    subroutine deallocate_mathf()
        deallocate( i2ix, i2iy, i2iz )
        call destroy_fftw()
    end subroutine

    !> FFTW計算のValidityを検証する
    !! @details デバッグ用
    !! @param[in] xpos x軸の座標データ
    subroutine check_validity(xpos)
        complex(kind(0d0)) :: f(1:NL), g(1:NL), h(1:NL), zgrad(1:NL,1:3), zlap(1:NL)
        integer            :: i
        double precision   :: xpos(1:NL), x
        do i = 1, NL
            x = xpos(i)
            f(i) = exp(-0.5*x**2)
            g(i) = -x*exp(-0.5*x**2)
            h(i) = (x**2-1)*exp(-0.5*x**2)
        end do
        f = transform_fftw(f)
        zgrad = gradient_fftw(f)
        zlap  = laplacian_fftw(f)

        write (*, '(X,A,F0.5,X,F0.5)') "Validity: (0,0)?=", sum( zgrad(:,1)-g(:) )
        write (*, '(X,A,F0.5,X,F0.5)') "Validity: (0,0)?=", sum( zlap-h )
    end subroutine

    !> 運動量を計算して速度場を求める
    !! @param[in] Phi 波動関数
    !! @param[out] V 速度場
    subroutine velocity_field(Phi, V)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        complex(kind(0d0))            :: temp(1:NL), zgrad(1:NL,1:3)
        complex(kind(0d0))            :: V(1:NL,3)
        ! calculate velocity and return it
        temp = transform_fftw(Phi)

        ! 1.take gradient
        zgrad = gradient_fftw(temp)

        ! 2.multiply -iu where iu denotes "imaginary unit"
        V = -iu*zgrad
    end subroutine

    !> 確率流密度(速度場)を計算する
    !! @param[in] Phi 波動関数
    !! @param[out] J 確率流密度
    subroutine probability_current(Phi, J)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        complex(kind(0d0))            :: temp(1:NL), zgrad(1:NL,1:3)
        double precision              :: J(1:NL,3)
        integer                       :: id
        ! calculate probability current and return it
        temp = transform_fftw(Phi)

        ! 1.take gradient
        zgrad = gradient_fftw(temp)

        do id = 1, 3
            J(:,id) = aimag( conjg(Phi(:))*zgrad(:,id) )
        end do
    end subroutine

    ! Need to fix
    !> 速度場から回転を計算する
    !! @param[in] V 速度場
    !! @return R 回転
    function curl_fourier(V) result(R)
        double precision,intent(in)   :: V(1:NL,3)
        complex(kind(0d0))            :: VK(1:NL,3)
        complex(kind(0d0))            :: temp(1:NL,1:3)
        complex(kind(0d0))            :: R(1:NL,3)
        integer                       :: id

        do id = 1, 3
            VK(:,id) = transform_fftw( dcmplx(V(:,id),0d0) )
        end do

        temp(:,1) = K(:,2)*VK(:,3) - K(:,3)*VK(:,2)
        temp(:,2) = K(:,3)*VK(:,1) - K(:,1)*VK(:,3)
        temp(:,3) = K(:,1)*VK(:,2) - K(:,2)*VK(:,1)

        do id = 1, 3
            R(:,id) = iu*revert_fftw( temp(:,id) )
        end do
    end function

    !> FDMを用いて\f$ dF/dX \f$を計算する
    !! @param[in] F 実数配列
    !! @return G 計算結果
    function dF_dX_REAL(F) result(G)
        double precision,intent(in) :: F(1:NL)
        double precision            :: G(1:NL)
        integer                     :: ix, iy, iz, i, id, ip
        G = 0d0

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i)
            do id = -Nd, Nd
                if ( id == 0 ) cycle
                if ( 1 <= ix + id .and. ix + id <= Nx ) then
                    ip = ixyz2i(ix + id, iy, iz)
                    G(i) = G(i) + F(ip) * C1(id)
                else
                    if ( 1 > ix + id ) then
                        ip = ixyz2i(Nx + (ix + id), iy, iz)
                        G(i) = G(i) + F(ip) * C1(id)
                    else
                        ip = ixyz2i(ix + id - Nx, iy, iz)
                        G(i) = G(i) + F(ip) * C1(id)
                    end if
                end if
            end do
        end do
    end function

    !> FDMを用いて\f$ dF/dY \f$を計算する
    !! @param[in] F 実数配列
    !! @return G 計算結果
    function dF_dY_REAL(F) result(G)
        double precision,intent(in) :: F(1:NL)
        double precision            :: G(1:NL)
        integer                     :: ix, iy, iz, i, id, ip
        G = 0d0

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i)
            do id = -Nd, Nd
                if ( id == 0 ) cycle
                if ( 1 <= iy + id .and. iy + id <= Ny ) then
                    ip = ixyz2i(ix, iy + id, iz)
                    G(i) = G(i) + F(ip) * C1(id)
                else
                    if ( 1 > iy + id ) then
                        ip = ixyz2i(ix, Ny + (iy + id), iz)
                        G(i) = G(i) + F(ip) * C1(id)
                    else
                        ip = ixyz2i(ix, iy + id - Ny, iz)
                        G(i) = G(i) + F(ip) * C1(id)
                    end if
                end if
            end do
        end do
    end function

    !> FDMを用いて\f$ dF/dZ \f$を計算する
    !! @param[in] F 実数配列
    !! @return G 計算結果
    function dF_dZ_REAL(F) result(G)
        double precision,intent(in) :: F(1:NL)
        double precision            :: G(1:NL)
        integer                     :: ix, iy, iz, i, id, ip
        G = 0d0

        do i = 1, NL
            ix = i2ix(i); iy = i2iy(i); iz = i2iz(i)
            do id = -Nd, Nd
                if ( id == 0 ) cycle
                if ( 1 <= iz + id .and. iz + id <= Nz ) then
                    ip = ixyz2i(ix, iy, iz + id)
                    G(i) = G(i) + F(ip) * C1(id)
                else
                    if ( 1 > iz + id ) then
                        ip = ixyz2i(ix, iy, Nz + (iz + id))
                        G(i) = G(i) + F(ip) * C1(id)
                    else
                        ip = ixyz2i(ix, iy, iz + id - Nz)
                        G(i) = G(i) + F(ip) * C1(id)
                    end if
                end if
            end do
        end do
    end function
    ! ---------------------------------------------------------------

    !> FDMを用いて回転を計算する
    !! @param[in] F 実数配列
    !! @return R 計算結果
    function curl_fdm(F) result (R)
        double precision,intent(in)  :: F(1:NL,3)
        double precision             :: R(1:NL,3)

        R(:,1) = dF_dY_REAL( F(:,3) ) - dF_dZ_REAL( F(:,2) )
        R(:,2) = dF_dZ_REAL( F(:,1) ) - dF_dX_REAL( F(:,3) )
        R(:,3) = dF_dX_REAL( F(:,2) ) - dF_dY_REAL( F(:,1) )
    end function

    !> 運動エネルギーの分布を計算する
    !! @param[in] Phi 波動関数
    !! @param[out] T 運動エネルギー
    subroutine kinetic_energy(Phi, T)
        complex(kind(0d0)),intent(in) :: Phi(1:NL)
        complex(kind(0d0))            :: temp(1:NL), T(1:NL), zlap(1:NL)
        ! calculate velocity and return it
        temp = transform_fftw(Phi)

        ! 1.take laplacian
        zlap = laplacian_fftw(temp)

        ! 2.multiply -1.0*conjg(Phi)
        T = -1d0*conjg(Phi)*zlap
    end subroutine

    ! FFTW Gradient
    !> FFTWを用いた勾配の計算
    !! @param[in] F 複素数配列
    !! @return 計算結果
    function gradient_fftw(F) result(G)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        complex(kind(0d0))            :: G(1:NL,1:3)
        integer                       :: id
        do id = 1, 3
            G(:,id) = iu*revert_fftw( F(:)*K(:,id) )
        end do
    end function

    ! FFTW Laplacian
    !> FFTWを用いたラプラシアンの計算
    !! @param[in] F 複素数配列
    !! @return 計算結果
    function laplacian_fftw(F) result(G)
        complex(kind(0d0)),intent(in) :: F(1:NL)
        complex(kind(0d0))            :: G(1:NL)
        G = -1d0*revert_fftw( F*K2 )
    end function

    ! FFTW Transform
    !> FFTWによる高速フーリエ変換
    !! @param[in] in 対象となる配列
    !! @return 変換結果
    function transform_fftw(in) result(out)
        complex(kind(0d0)),intent(in) :: in(1:NL)
        complex(kind(0d0))            :: out(1:NL)
        call dfftw_execute_dft( plan_f, in, out )
    end function

    ! FFTW Backward Transform
    !> FFTWによる高速フーリエ逆変換
    !! @param[in] in 対象となる配列
    !! @return 変換結果
    function revert_fftw(in) result(out)
        complex(kind(0d0)),intent(in) :: in(1:NL)
        complex(kind(0d0))            :: out(1:NL)
        call dfftw_execute_dft( plan_b, in, out )
        out = out / NL
    end function

    ! FFTW Instantiate
    !> FFTWの初期化
    !! @details FFTWを用いる操作（微分計算）を行う前に一度は実行しなければならない
    subroutine new_fftw()
        integer             :: ix, iy, iz, i
        ! This way calculation runs 1.43x times faster
        pfx = fftw_alloc_complex(int(NL, C_SIZE_T))
        pFk = fftw_alloc_complex(int(NL, C_SIZE_T))
        pgx = fftw_alloc_complex(int(NL, C_SIZE_T))
        pGk = fftw_alloc_complex(int(NL, C_SIZE_T))
        call c_f_pointer( pfx, fx, [NL] )
        call c_f_pointer( pFk, Fk, [NL] )
        call c_f_pointer( pgx, gx, [NL] )
        call c_f_pointer( pGk, Gk, [NL] )
        call dfftw_plan_dft_3d(plan_f, Nx, Ny, Nz, fx, Fk, FFTW_FORWARD, FFTW_MEASURE)
        call dfftw_plan_dft_3d(plan_b, Nx, Ny, Nz, Fk, fx, FFTW_BACKWARD, FFTW_MEASURE)
        allocate( K(1:NL,3), K2(1:NL) )
        allocate( Kx(1:Nx), Ky(1:Ny), Kz(1:Nz) )
        Kx = create_wavenumber(Nx)
        Ky = create_wavenumber(Ny)
        Kz = create_wavenumber(Nz)
        i = 1
        do iz = 1, Nz
            do iy = 1, Ny
                do ix = 1, Nx
                    K(i, 1) = Kx(ix)
                    K(i, 2) = Ky(iy)
                    K(i, 3) = Kz(iz)
                    K2(i)   = Kx(ix)**2 + Ky(iy)**2 + Kz(iz)**2
                    i = i + 1
                end do
            end do
        end do
    end subroutine

    ! FFTW Wavenumbers
    !> FFTWで用いる波数ベクトルを初期化する
    !! @param[in] N 波数ベクトルの次元
    !! @return K_ 波数ベクトル
    function create_wavenumber(N) result(K_)
        integer,intent(in)  :: N
        double precision    :: K_(1:N)
        double precision    :: coe
        integer             :: i
        coe = 2d0 * PI / ( N * dh )
        if ( N > 1 ) then
            do i = 1, N
                if (i <= N / 2) then
                    K_(i) = i - 1
                else
                    K_(i) = i - N - 1
                end if
            end do
            K_ = K_ * coe
        else
            K_ = 0d0
        end if
    end function

    ! Destroy FFTW Instances
    !> FFTWで確保したメモリを開放する
    subroutine destroy_fftw()
        call dfftw_destroy_plan( plan_f )
        call dfftw_destroy_plan( plan_b )
        call fftw_free( pfx )
        call fftw_free( pFk )
    end subroutine
end module


      subroutine runF_00(i1,f,Gr,Shat2,N0)
C---  Expression for rearrangement of Eq. 5.66
C---  Calculates D00
C---  Small terms of order f(i)*Di,Gr(i,j)*Dij
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      include 'pvweenumber.f'
      integer ep,N0,i1,np
      parameter(np=3)
      double precision f(np),Gr(np,np)
      double complex Shat2(np,np,-2:0)

      do ep=-2,0
      Dv(dd00+N0,ep)=
     . (Shat2(i1,i1,ep)
     . -f(i1)*Dv(di(i1)+N0,ep)
     . -Gr(i1,1)*Dv(dii(z2(1,i1))+N0,ep)
     . -Gr(i1,2)*Dv(dii(z2(2,i1))+N0,ep)
     . -Gr(i1,3)*Dv(dii(z2(3,i1))+N0,ep))/2d0

      enddo

      return
      end


!!model in arXiv: 0902.2197

module model
  use define_fields
  implicit none

#include "configure.h"

!!*******************define the couplings etc. for your model *************
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!the predefined constants that you can use: GeV, MPl (the reduced Planck Mass), PlanckMass (the Planck Mass), Mplsq (square of the reduced Planck Mass)
  real(dl),parameter:: m_s = 100._dl * GeV
  real(dl),parameter:: M_cutoff = Mpl
  real(dl),parameter:: K_run = -0.1
  real(dl),parameter:: phi0 = 1.e16_dl*GeV
  real(dl),parameter:: EpsilonPlus = 1.e-8_dl !!this number is used to avoid log(0) glitches.
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************define macros here;************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
#define REPHI f(1)
#define IMPHI f(2)
#define PHI2 (REPHI **2 + IMPHI **2)
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

!!***************** define initial conditions ******************************
!!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!!HLattice always treat the first field as the inflaton \phi.
!!To be self consistent you may want to get the background \phi and \dot\phi by solving the background equations from inflation. HLattice will do that for you.
!!Just define where you want to start the background evolution. Note this is NOT where you start the lattice simulation, which is defined in a subroutine "start_box_simulation" in this file.
 !!initial field values
 real(dl),dimension(ns)::init_fields=(/ &
       phi0, 0._dl &
       /)

!!Initial field momenta
 !! if set to be greater than or equal to Mplsq (square of reduced Planck Mass), the initial field momenta will be determined by slow-roll inflationary attractor
  !! Note again these are NOT the initial field momenta where you start the lattice simulation, the are the initial values that HLattice take to evolve the inflaton.
  real(dl),dimension(ns):: init_momenta = 0.

!!put initial random Gaussian perturbations in the fields when you starts lattice simulation;
!!the amplitude of fluctuations are defined in subroutine model_Power
  logical,dimension(ns)::do_init = (/ .true., .true. /)

!!Important note: init_fields and init_momenta will be changed after the initialization. After the subroutine init() is called, they will equal to the the fields and field momenta AT THE BEGINNING OF LATTICE SIMULATION. In addition, the Hubble parameter at the beginning of lattice simulation will be saved to a global variable "init_Hubble".
!!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

contains

!! the potential of the scalar fields
  function potential(f)
    real(dl) f(ns)
    real(dl) potential
    potential = (m_s**2/2._dl) * PHI2 * (1._dl + K_run * log(PHI2/(2._dl*M_cutoff**2)+EpsilonPlus)) !!I use a epsilon+ to avoid log(zero) numerical instability.
  end function potential

!! the derivative of pential w.r.t. to the fields
!! return an array (dV/df1, dV/df2, ...)
  function dVdf(f)
    real(dl) f(ns)
    real(dl),dimension(ns):: dVdf
    dVdf = (m_s**2)*(1._dl +  K_run * (1.-EpsilonPlus/(PHI2/(2._dl*M_cutoff**2)+EpsilonPlus)+log(PHI2/(2._dl*M_cutoff**2)+EpsilonPlus))) * f
  end function dVdf

!!d^2 V / d f_{fld}^2,, here fld can be 1,2,..., ns
  function mass_sq(f,fld)
    real(dl) f(ns)
    real(dl):: mass_sq
    integer fld
    select case(fld)
    case(1)
       mass_sq = (m_s**2) * (1._dl +  K_run * (1.+ 2.*REPHI**2/PHI2 + log(PHI2/(2._dl*M_cutoff**2))))
    case(2)
       mass_sq = (m_s**2) * (1._dl +  K_run * (1.+ 2.*IMPHI**2/PHI2 + log(PHI2/(2._dl*M_cutoff**2))))
    case default
       stop "wrong argument fld in mass_sq"
    end select
  end function mass_sq

!!define the condition to start the lattice simulation
  function start_box_simulation(f,p)
    logical start_box_simulation
    real(dl),dimension(ns)::f,p
    start_box_simulation = .true.
    !!immediately start the lattice simulation
  end function start_box_simulation

!!define the time step;
  function model_dt_per_step()
    real(dl) model_dt_per_step
    model_dt_per_step = metric%dx/50._dl

  end function model_dt_per_step

!!return an array (|f_k|^2, |f'_k|^2) for fields initialization.
!!remember always set them to be zero for k=0.
  function model_Power(fld,k)
    real(dl),dimension(2):: model_Power
    real(dl) k,omega
    integer(IB) fld
    if(n*k*metric%dx .lt. const_pi) then
       model_Power =0._dl
       return
    endif
    model_Power(1) = (const_pi**2 * 2._dl)/k*((5.e-5*phi0)/k)**2
    model_Power(2) = 0._dl
  end function model_Power

!!model outputs
  subroutine model_output(i)
    !! i = 1; called before initialization
    !! i = 2; called after initialization
    !! i = 3; called in output_to_screen()
    !! i = 4; called at the end of simulation
    integer(IB) i
    type(file_pointer) fp
    select case(i)
    case(1)
#if USE_CONFORMAL_TIME
       stop "you may want to turn off USE_CONFORMAL_TIME in configure.h"
#endif
    case(2)
       fp = open_file("data/"//trim(run_name)//"_model.info", "w")
       write(fp%unit,*) "flat direction arXiv: 0902.2197"
       write(fp%unit,*) "reduced Planck Mass M_p = ", Mpl
       write(fp%unit,*) "m_{3/2} = ",m_s
       write(fp%unit,*) "M = ", M_cutoff
       write(fp%unit,*) "K = ", K_run
       write(fp%unit,*) "n = ",n
       write(fp%unit,*) "dx=",metric%dx
       write(fp%unit,*) "m_{3/2} / Hubble = ", m_s/Init_Hubble
       write(fp%unit,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(fp%unit,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
       call close_file(fp)
       write(*,*) "m_{3/2} / Hubble = ", m_s/Init_Hubble
       write(*,*) "effective k_min / Hubble = ", k_unit/metric%physdx/Init_Hubble
       write(*,*) "effective k_max / Hubble = ", fft_numk*k_unit/metric%physdx/Init_Hubble
    case(3)
    case(4)
    case default
       write(*,*) "Unknow option in model_output"
       stop
    end select
  end subroutine model_output

end module model


      SUBROUTINE G0SHAD(XPOS,YPOS,INDST,INDEND,XADDPT,YADDPT,INDADD,
     &                  SXPT,SYPT,SZPT)
C
C          ------------------------------------------------
C          ROUTINE NO. ( 362)   VERSION (A9.1)    05:MAY:92
C          ------------------------------------------------
C
C          THIS ROUTINE CALCULATES THE REFLECTIVITY OF
C          A SHADED POLYGON.
C
      REAL    XPOS(*),YPOS(*),XADDPT(*),YADDPT(*),SXPT(4),SYPT(4),
     &        SZPT(4),ACOEFF(4),BCOEFF(4),CCOEFF(4),RDATA(1)
      INTEGER IDATA(1)
C
      COMMON /T0SKOL/ HUESHD,JKOLS,KOLSTA
      COMMON /T0SLIT/ ALIGHT,BLIGHT,CLIGHT
      COMMON /T0SREF/ AMBINT,DIFFUS,SPECT
C
      DATA RDATA /0.0/
C
C
C          CALCULATE THE NORMAL TO THE FACET BY AVERAGING
C          THE NORMALS OF THE FOUR TRIANGLES THAT CAN BE
C          FORMED FROM THE FOUR LINES OF THE FACET.
C
      DO 100 I= 1,4
        J= MOD(I,4)+1
        K= MOD(J,4)+1
        ACOEFF(I)= SYPT(I)*(SZPT(J)-SZPT(K))+
     &             SYPT(J)*(SZPT(K)-SZPT(I))+
     &             SYPT(K)*(SZPT(I)-SZPT(J))
        BCOEFF(I)= SZPT(I)*(SXPT(J)-SXPT(K))+
     &             SZPT(J)*(SXPT(K)-SXPT(I))+
     &             SZPT(K)*(SXPT(I)-SXPT(J))
        CCOEFF(I)= SXPT(I)*(SYPT(J)-SYPT(K))+
     &             SXPT(J)*(SYPT(K)-SYPT(I))+
     &             SXPT(K)*(SYPT(I)-SYPT(J))
C
C          NORMALISE THE COEFFICIENTS.
C
        SQR= SQRT(ACOEFF(I)*ACOEFF(I)+
     &            BCOEFF(I)*BCOEFF(I)+
     &            CCOEFF(I)*CCOEFF(I))
        ACOEFF(I)= ACOEFF(I)/SQR
        BCOEFF(I)= BCOEFF(I)/SQR
        CCOEFF(I)= CCOEFF(I)/SQR
  100 CONTINUE
C
C          AVERAGE THE NORMALS.
C
      ACOEFN= (ACOEFF(1)+ACOEFF(2)+ACOEFF(3)+ACOEFF(4))*0.25
      BCOEFN= (BCOEFF(1)+BCOEFF(2)+BCOEFF(3)+BCOEFF(4))*0.25
      CCOEFN= (CCOEFF(1)+CCOEFF(2)+CCOEFF(3)+CCOEFF(4))*0.25
C
C          NORMALISE THE COEFFICIENTS.
C
      SQR= SQRT(ACOEFN*ACOEFN+BCOEFN*BCOEFN+CCOEFN*CCOEFN)
      ACOEFN= ACOEFN/SQR
      BCOEFN= BCOEFN/SQR
      CCOEFN= CCOEFN/SQR
C
C          CALCULATE THE DOT PRODUCT BETWEEN THE
C          NORMAL AND THE LIGHT VECTOR.
C
      PRODNL= ACOEFN*ALIGHT+BCOEFN*BLIGHT+CCOEFN*CLIGHT
C
C          ADD THE AMBIENT LIGHT TO THE DIFFUSE LIGHT.
C
      PRODIF= AMBINT+DIFFUS*MIN(MAX(PRODNL,0.0),1.0)
C
C          CALCULATE THE SPECTURALLY REFLECTED LIGHT.
C
C          LET N BE THE NORMAL TO THE FACET.
C          LET E BE THE VECTOR TO THE VIEWER, (0,0,-1.0).
C          LET L BE THE LIGHT VECTOR.
C          LET H BE THE VECTOR THAT IS THE MEAN OF E AND L.
C          LET R BE THE REFLECTED VECTOR FROM THE FACET.
C          LET a BE THE ANGLE BETWEEN N AND H.
C          LET b BE THE ANGLE BETWEEN L AND H.
C          THIS IS ALSO THE ANGLE BETWEEN E AND H.
C          FROM GEOMETRY 2a IS THE ANGLE BETWEEN E AND R.
C
C          THEN
C
C          E.N= cos(b-a)
C          L.N= cos(b+a)
C          E.L= cos(2.0*b)= 2.0*cos(b)*cos(b)-1.0
C          THEREFORE cos(b)= sqrt((E.L)+1.0)/2.0)
C
C          NOW cos(b-a)= cos(a)*cos(b)-sin(a)*sin(b)
C          AND cos(b+a)= cos(a)*cos(b)+sin(a)*sin(b)
C          THEREFORE 2.0*cos(a)*cos(b)= cos(b-a)+cos(b+a)
C                                     = E.N+L.N
C          cos(a)= (E.N+L.N)/sqrt(2.0*(E.L+1.0))
C          cos(2.0*a)= (E.N+L.N)*(E.N+L.N)/(E.L+1.0)-1.0
C
      IF (PRODNL.GT.0.0) THEN
        IF (CLIGHT.LT.0.999) THEN
          COS2AL= (PRODNL-CCOEFN)*(PRODNL-CCOEFN)/(1.0-CLIGHT)-1.0
        ELSE
          COS2AL= 1.0
        ENDIF
C
        COS2AL= MIN(MAX(COS2AL,0.0),1.0)
        PRODSP= SPECT*COS2AL**3
      ELSE
        PRODSP= 0.0
      ENDIF
C
C          ADD IN THE SPECTURALLY REFLECTED LIGHT.
C
      PROD= PRODIF+PRODSP
      PROD= MIN(MAX(PROD,0.0),1.0)
      IDATA(1)= 0
      CALL G3LINK(5,13,-1,IDATA,RDATA)
      IDATA(1)= NINT(PROD*JKOLS)+KOLSTA
      CALL G3LINK(5,3,-1,IDATA,RDATA)
      IPFLAG= 0
      IF (INDST.LE.INDEND) THEN
        XSAV= XPOS(INDST)
        YSAV= YPOS(INDST)
        CALL POSITN(XSAV,YSAV)
        IPFLAG= 1
        IF (INDST.LT.INDEND) THEN
C
          DO 200 IND= INDST+1,INDEND
            CALL JOIN(XPOS(IND),YPOS(IND))
  200     CONTINUE
C
        ENDIF
      ENDIF
C
      IF (INDADD.GT.0) THEN
        INDLST= INDADD
        IF (IPFLAG.EQ.0) THEN
          XSAV= XADDPT(INDADD)
          YSAV= YADDPT(INDADD)
          CALL POSITN(XSAV,YSAV)
          INDLST= INDADD-1
        ENDIF
C
        IF (INDLST.GT.0) THEN
C
          DO 300 IND= INDLST,1,-1
            CALL JOIN(XADDPT(IND),YADDPT(IND))
  300     CONTINUE
C
        ENDIF
      ENDIF
C
      CALL JOIN(XSAV,YSAV)
      CALL G3LINK(5,4,0,IDATA,RDATA)
C
      RETURN
      END


c     Subroutine to find basic stats for month values
c     AJ_Kettle, Nov30/2017

      SUBROUTINE calc_basic_stats_mon(f_ndflag,l_monrec_common,
     +  f_monrec_airt_k,f_monrec_wspd_ms,
     +  f_monrec_slpres_hpa,f_monrec_ppt_mm,

     +  f_monavg_airt_ngood,f_monavg_airt_nbad,
     +  f_monavg_airt_min_k,f_monavg_airt_max_k,
     +  f_monavg_airt_avg_k,
     +  f_monavg_wspd_ngood,f_monavg_wspd_nbad,
     +  f_monavg_wspd_min_ms,f_monavg_wspd_max_ms,
     +  f_monavg_wspd_avg_ms,
     +  f_monavg_slpres_ngood,f_monavg_slpres_nbad,
     +  f_monavg_slpres_min_hpa,f_monavg_slpres_max_hpa,
     +  f_monavg_slpres_avg_hpa,
     +  f_monavg_ppt_ngood,f_monavg_ppt_nbad,
     +  f_monavg_ppt_min_mm,f_monavg_ppt_max_mm,
     +  f_monavg_ppt_avg_mm)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_ndflag
      INTEGER             :: l_monrec_common

      REAL                :: f_monrec_airt_k(5000)
      REAL                :: f_monrec_wspd_ms(5000)
      REAL                :: f_monrec_slpres_hpa(5000)
      REAL                :: f_monrec_ppt_mm(5000)

      REAL                :: f_monavg_airt_ngood
      REAL                :: f_monavg_airt_nbad
      REAL                :: f_monavg_airt_min_k
      REAL                :: f_monavg_airt_max_k
      REAL                :: f_monavg_airt_avg_k

      REAL                :: f_monavg_wspd_ngood
      REAL                :: f_monavg_wspd_nbad
      REAL                :: f_monavg_wspd_min_ms
      REAL                :: f_monavg_wspd_max_ms
      REAL                :: f_monavg_wspd_avg_ms

      REAL                :: f_monavg_slpres_ngood
      REAL                :: f_monavg_slpres_nbad
      REAL                :: f_monavg_slpres_min_hpa
      REAL                :: f_monavg_slpres_max_hpa
      REAL                :: f_monavg_slpres_avg_hpa

      REAL                :: f_monavg_ppt_ngood
      REAL                :: f_monavg_ppt_nbad
      REAL                :: f_monavg_ppt_min_mm
      REAL                :: f_monavg_ppt_max_mm
      REAL                :: f_monavg_ppt_avg_mm

      INTEGER             :: ii,jj,kk,i,j,k
c************************************************************************
c     Find stats dayavg_airt
      CALL dwd_mon_stat_package(l_monrec_common,f_ndflag,
     + f_monrec_airt_k,
     + f_monavg_airt_min_k,f_monavg_airt_max_k,
     + f_monavg_airt_avg_k,
     + f_monavg_airt_ngood,f_monavg_airt_nbad)

c     Find stats dayavg_wspd
      CALL dwd_mon_stat_package(l_monrec_common,f_ndflag,
     + f_monrec_wspd_ms,
     + f_monavg_wspd_min_ms,f_monavg_wspd_max_ms,
     + f_monavg_wspd_avg_ms,
     + f_monavg_wspd_ngood,f_monavg_wspd_nbad)

c     Find stats dayavg_slpres
      CALL dwd_mon_stat_package(l_monrec_common,f_ndflag,
     + f_monrec_slpres_hpa,
     + f_monavg_slpres_min_hpa,f_monavg_slpres_max_hpa,
     + f_monavg_slpres_avg_hpa,
     + f_monavg_slpres_ngood,f_monavg_slpres_nbad)

c     Find stats dayavg_ppt
      CALL dwd_mon_stat_package(l_monrec_common,f_ndflag,
     + f_monrec_ppt_mm,
     + f_monavg_ppt_min_mm,f_monavg_ppt_max_mm,
     + f_monavg_ppt_avg_mm,
     + f_monavg_ppt_ngood,f_monavg_ppt_nbad)
c************************************************************************
c      print*,'airt_k=',f_monavg_airt_min_k,f_monavg_airt_max_k,
c     + f_monavg_airt_avg_k,
c     + f_monavg_airt_ngood,f_monavg_airt_nbad
c      print*,'wspd_ms=',f_monavg_wspd_min_ms,f_monavg_wspd_max_ms,
c     + f_monavg_wspd_avg_ms,
c     + f_monavg_wspd_ngood,f_monavg_wspd_nbad
c      print*,'slpres_hpa=',
c     + f_monavg_slpres_min_hpa,f_monavg_slpres_max_hpa,
c     + f_monavg_slpres_avg_hpa,
c     + f_monavg_slpres_ngood,f_monavg_slpres_nbad
c      print*,'ppt_mm=',f_monavg_ppt_min_mm,f_monavg_ppt_max_mm,
c     + f_monavg_ppt_avg_mm,
c     + f_monavg_ppt_ngood,f_monavg_ppt_nbad

      RETURN
      END


      SUBROUTINE TRI3 (M,A,B,C,K,Y1,Y2,Y3,TCOS,D,W1,W2,W3)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,K(4)       ,
     1                TCOS(1)    ,Y1(1)      ,Y2(1)      ,Y3(1)      ,
     2                D(1)       ,W1(1)      ,W2(1)      ,W3(1)
C
C     SUBROUTINE TO SOLVE THREE LINEAR SYSTEMS WHOSE COMMON COEFFICIENT
C     MATRIX IS A RATIONAL FUNCTION IN THE MATRIX GIVEN BY
C
C                  TRIDIAGONAL (...,A(I),B(I),C(I),...)
C
      MM1 = M-1
      K1 = K(1)
      K2 = K(2)
      K3 = K(3)
      K4 = K(4)
      F1 = K1+1
      F2 = K2+1
      F3 = K3+1
      F4 = K4+1
      K2K3K4 = K2+K3+K4
      IF (K2K3K4 .EQ. 0) GO TO 101
      L1 = F1/F2
      L2 = F1/F3
      L3 = F1/F4
      LINT1 = 1
      LINT2 = 1
      LINT3 = 1
      KINT1 = K1
      KINT2 = KINT1+K2
      KINT3 = KINT2+K3
  101 CONTINUE
      DO 115 N=1,K1
         X = TCOS(N)
         IF (K2K3K4 .EQ. 0) GO TO 107
         IF (N .NE. L1) GO TO 103
         DO 102 I=1,M
            W1(I) = Y1(I)
  102    CONTINUE
  103    IF (N .NE. L2) GO TO 105
         DO 104 I=1,M
            W2(I) = Y2(I)
  104    CONTINUE
  105    IF (N .NE. L3) GO TO 107
         DO 106 I=1,M
            W3(I) = Y3(I)
  106    CONTINUE
  107    CONTINUE
         Z = 1./(B(1)-X)
         D(1) = C(1)*Z
         Y1(1) = Y1(1)*Z
         Y2(1) = Y2(1)*Z
         Y3(1) = Y3(1)*Z
         DO 108 I=2,M
            Z = 1./(B(I)-X-A(I)*D(I-1))
            D(I) = C(I)*Z
            Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z
            Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z
            Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z
  108    CONTINUE
         DO 109 IP=1,MM1
            I = M-IP
            Y1(I) = Y1(I)-D(I)*Y1(I+1)
            Y2(I) = Y2(I)-D(I)*Y2(I+1)
            Y3(I) = Y3(I)-D(I)*Y3(I+1)
  109    CONTINUE
         IF (K2K3K4 .EQ. 0) GO TO 115
         IF (N .NE. L1) GO TO 111
         I = LINT1+KINT1
         XX = X-TCOS(I)
         DO 110 I=1,M
            Y1(I) = XX*Y1(I)+W1(I)
  110    CONTINUE
         LINT1 = LINT1+1
         L1 = (FLOAT(LINT1)*F1)/F2
  111    IF (N .NE. L2) GO TO 113
         I = LINT2+KINT2
         XX = X-TCOS(I)
         DO 112 I=1,M
            Y2(I) = XX*Y2(I)+W2(I)
  112    CONTINUE
         LINT2 = LINT2+1
         L2 = (FLOAT(LINT2)*F1)/F3
  113    IF (N .NE. L3) GO TO 115
         I = LINT3+KINT3
         XX = X-TCOS(I)
         DO 114 I=1,M
            Y3(I) = XX*Y3(I)+W3(I)
  114    CONTINUE
         LINT3 = LINT3+1
         L3 = (FLOAT(LINT3)*F1)/F4
  115 CONTINUE
      RETURN
      END


c--- This is just a wrapping routine that calls ovDtensor or pvDtensor
      subroutine doDtensor(q1,q2,q3,m1s,m2s,m3s,m4s,
     . FD0,FD1,FD2,FD3,FD4,FD5,FD6)
      implicit none
C     q1,q2,q3 are the loop offset momenta
C     m1s,m2s,m3s,m4s are the squares of the masses in the propagators
      include 'TRconstants.f'
      include 'TRydef.f'
      include 'TRtensorcontrol.f'
      double complex FD0(-2:0),FD1(y1max,-2:0),FD2(y2max,-2:0),
     . FD3(y3max,-2:0),FD4(y4max,-2:0),FD5(y5max,-2:0),FD6(y6max,-2:0)
      double precision p2(4),p3(4),q1(4),q2(4),q3(4),m1s,m2s,m3s,m4s

      if (doovred) then
        p3(:)=q3(:)-q2(:)
        p2(:)=q2(:)-q1(:)
        call ovDtensor(q1,p2,p3,m1s,m2s,m3s,m4s,FD0,FD1,FD2,FD3,FD4)
        FD5=czip
        FD6=czip
      endif

      if (dopvred) then
        call pvDtensor(q1,q2,q3,m1s,m2s,m3s,m4s,
     &   FD0,FD1,FD2,FD3,FD4,FD5,FD6)
      endif

      return
      end