MODULE module_bl_gfs2011

CONTAINS

   SUBROUTINE BL_GFS2011(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, &
                  RUBLTEN,RVBLTEN,RTHBLTEN, &
                  RQVBLTEN,RQCBLTEN,RQIBLTEN, &
                  CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR, &
                  dz8w,z,PSFC, &
                  UST,PBL,PSIM,PSIH, &
                  HFX,QFX,TSK,GZ1OZ0,WSPD,BR, &
                  DT,KPBL2D,EP1,KARMAN, &

                  RTHRATEN, &
                  HPBL2D, EVAP2D, HEAT2D, &
                  ids,ide, jds,jde, kds,kde, &
                  ims,ime, jms,jme, kms,kme, &
                  its,ite, jts,jte, kts,kte )

      USE MODULE_GFS_MACHINE , ONLY : kind_phys

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
                                        its,ite, jts,jte, kts,kte, &
                                        P_QI,P_FIRST_SCALAR
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: RTHRATEN
      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: &
                                        HPBL2D, &
                                        EVAP2D, &
                                        HEAT2D
      REAL, INTENT(IN) :: &
                                        CP, &
                                        DT, &
                                        EP1, &
                                        G, &
                                        KARMAN, &
                                        R, &
                                        ROVCP, &
                                        ROVG
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: &
                                        DZ8W, &
                                        P3D, &
                                        PI3D, &
                                        QC3D, &
                                        QI3D, &
                                        QV3D, &
                                        T3D, &
                                        TH3D, &
                                        U3D, &
                                        V3D, &
                                        Z
      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: &
                                        RTHBLTEN, &
                                        RQCBLTEN, &
                                        RQIBLTEN, &
                                        RQVBLTEN, &
                                        RUBLTEN, &
                                        RVBLTEN
      REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: &
                                        BR, &
                                        GZ1OZ0, &
                                        HFX, &
                                        PSFC, &
                                        PSIM, &
                                        PSIH, &
                                        QFX, &
                                        TSK
      REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: &
                                        PBL, &
                                        UST, &
                                        WSPD
      INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: &
                                        KPBL2D
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte) :: &
                                        DEL, &
                                        DU, &
                                        DV, &
                                        PHIL, &
                                        PRSL, &
                                        PRSLK, &
                                        T1, &
                                        TAU, &
                                        dishx, &
                                        THRATEN, &
                                        U1, &
                                        V1
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) :: &
                                        PHII, &
                                        PRSI
      REAL (kind=kind_phys), DIMENSION(its:ite, kts:kte, 3) :: &
                                        Q1, &
                                        RTG
      REAL (kind=kind_phys), DIMENSION(its:ite) :: &
                                        DQSFC, &
                                        DTSFC, &
                                        DUSFC, &
                                        DVSFC, &
                                        EVAP, &
                                        FH, &
                                        FM, &
                                        HEAT, &
                                        HGAMQ, &
                                        HGAMT, &
                                        HPBL, &
                                        PSK, &
                                        QSS, &
                                        RBSOIL, &
                                        RCL, &
                                        SPD1, &
                                        STRESS, &
                                        TSEA
      REAL (kind=kind_phys) :: &
                                        CPM, &
                                        cpmikj, &
                                        DELTIM, &
                                        FMTMP, &
                                        RRHOX
      INTEGER, DIMENSION( its:ite ) :: &
                                        KPBL
      INTEGER :: &
                                        I, &
                                        IM, &
                                        J, &
                                        K, &
                                        KM, &
                                        KTEM, &
                                        KTEP, &
                                        KX, &
                                        L, &
                                        NTRAC
   IM=ITE-ITS+1
   KX=KTE-KTS+1
   KTEM=KTE-1
   KTEP=KTE+1
   NTRAC=2
   DELTIM=DT
   IF (P_QI.ge.P_FIRST_SCALAR) NTRAC=3
   DO J=jts,jte
      DO i=its,ite
        RRHOX=(R*T3D(I,KTS,J)*(1.+EP1*QV3D(I,KTS,J)))/PSFC(I,J)
        CPM=CP*(1.+0.8*QV3D(i,kts,j))
        FMTMP=GZ1OZ0(i,j)-PSIM(i,j)
        PSK(i)=(PSFC(i,j)*.00001)**ROVCP
        FM(i)=FMTMP
        FH(i)=GZ1OZ0(i,j)-PSIH(i,j)
        TSEA(i)=TSK(i,j)
        QSS(i)=QV3D(i,kts,j)
        HEAT(i)=HFX(i,j)/CPM*RRHOX
        EVAP(i)=QFX(i,j)*RRHOX
        HEAT2D(i,j)=HFX(i,j)/CPM*RRHOX
        EVAP2D(i,j)=QFX(i,j)*RRHOX
        STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
        SPD1(i)=WSPD(i,j)
        PRSI(i,kts)=PSFC(i,j)*.001
        PHII(I,kts)=0.
        RCL(i)=1.
        RBSOIL(I)=BR(i,j)
      ENDDO
      DO k=kts,kte
        DO i=its,ite
          DV(I,K) = 0.
          DU(I,K) = 0.
          TAU(I,K) = 0.
          U1(I,K) = U3D(i,k,j)
          V1(I,K) = V3D(i,k,j)
          T1(I,K) = T3D(i,k,j)
          THRATEN(I,K) = RTHRATEN(I,K,J)
          Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j))
          Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j))
          PRSL(I,K)=P3D(i,k,j)*.001
        ENDDO
      ENDDO
      DO k=kts,kte
        DO i=its,ite
          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
        ENDDO
      ENDDO
      DO k=kts+1,kte
        km=k-1
        DO i=its,ite
          DEL(i,km)=PRSL(i,km)/ROVG*dz8w(i,km,j)/T3D(i,km,j)
          PRSI(i,k)=PRSI(i,km)-DEL(i,km)
          PHII(I,K)=(Z(i,k,j)-Z(i,kts,j))*G
          PHIL(I,KM)=0.5*(Z(i,k,j)+Z(i,km,j)-2.*Z(i,kts,j))*G
        ENDDO
      ENDDO
      DO i=its,ite
        DEL(i,kte)=DEL(i,ktem)
        PRSI(i,ktep)=PRSI(i,kte)-DEL(i,ktem)
        PHII(I,KTEP)=PHII(I,KTE)+dz8w(i,kte,j)*G
        PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE)
      ENDDO
      IF (P_QI.ge.P_FIRST_SCALAR) THEN
        DO k=kts,kte
          DO i=its,ite
            Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j))
          ENDDO
        ENDDO
      ENDIF
      DO l=1,ntrac
        DO k=kts,kte
          DO i=its,ite
            RTG(I,K,L) = 0.
          ENDDO
        ENDDO
      ENDDO
      call moninq(im,im,km,ntrac,dv,du,tau,rtg, &
     & u1,v1,t1,q1,thraten, &
     & psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl, &
     & prsi,del,prsl,prslk,phii,phil,rcl,deltim, &
     & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq)
      DO k=kts,kte
        DO i=its,ite
          RVBLTEN(I,K,J)=DV(I,K)
          RUBLTEN(I,K,J)=DU(I,K)
          RTHBLTEN(I,K,J)=TAU(I,K)/PI3D(I,K,J)
          RQVBLTEN(I,K,J)=RTG(I,K,1)/(1.-Q1(I,K,1))**2
          RQCBLTEN(I,K,J)=RTG(I,K,2)/(1.-Q1(I,K,2))**2
        ENDDO
      ENDDO
      IF (P_QI.ge.P_FIRST_SCALAR) THEN
        DO k=kts,kte
          DO i=its,ite
            RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2
          ENDDO
        ENDDO
      ENDIF
      DO i=its,ite
        UST(i,j)=SQRT(STRESS(i))
        WSPD(i,j)=SQRT(U3D(I,KTS,J)*U3D(I,KTS,J)+ &
                       V3D(I,KTS,J)*V3D(I,KTS,J))+1.E-9
        PBL(i,j)=HPBL(i)
        HPBL2D(i,j)=HPBL(i)
        KPBL2D(i,j)=kpbl(i)
      ENDDO
    ENDDO
   END SUBROUTINE BL_GFS2011
   SUBROUTINE gfs2011init(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, &
                      RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR, &
                      restart, &
                      allowed_to_read, &
                      ids, ide, jds, jde, kds, kde, &
                      ims, ime, jms, jme, kms, kme, &
                      its, ite, jts, jte, kts, kte )
   IMPLICIT NONE
   LOGICAL , INTENT(IN) :: allowed_to_read,restart
   INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
                                     ims, ime, jms, jme, kms, kme, &
                                     its, ite, jts, jte, kts, kte
   INTEGER , INTENT(IN) :: P_QI,P_FIRST_SCALAR
   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: &
                                                         RUBLTEN, &
                                                         RVBLTEN, &
                                                         RTHBLTEN, &
                                                         RQVBLTEN, &
                                                         RQCBLTEN, &
                                                         RQIBLTEN
   INTEGER :: i, j, k, itf, jtf, ktf
   jtf=min0(jte,jde-1)
   ktf=min0(kte,kde-1)
   itf=min0(ite,ide-1)
   IF(.not.restart)THEN
     DO j=jts,jtf
     DO k=kts,ktf
     DO i=its,itf
        RUBLTEN(i,k,j)=0.
        RVBLTEN(i,k,j)=0.
        RTHBLTEN(i,k,j)=0.
        RQVBLTEN(i,k,j)=0.
        RQCBLTEN(i,k,j)=0.
     ENDDO
     ENDDO
     ENDDO
   ENDIF
   IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN
      DO j=jts,jtf
      DO k=kts,ktf
      DO i=its,itf
         RQIBLTEN(i,k,j)=0.
      ENDDO
      ENDDO
      ENDDO
   ENDIF
   IF (P_QI .ge. P_FIRST_SCALAR) THEN
      DO j=jts,jtf
      DO k=kts,ktf
      DO i=its,itf
         RQIBLTEN(i,k,j)=0.
      ENDDO
      ENDDO
      ENDDO
   ENDIF
   END SUBROUTINE gfs2011init
      subroutine moninq(ix,im,km,ntrac,dv,du,tau,rtg, &
     & uo,vo,t1,q1,thraten, &
     & psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl, &
     & prsi,del,prsl,prslk,phii,phil,rcs,deltim, &
     & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      USE MODULE_GFS_PHYSCONS, grav => con_g, rd => con_rd, &
     & cp => con_cp, hvap => con_hvap, fv => con_fvirt
      implicit none
      integer ix, im, km, ntrac, kpbl(im), kpblx(im)
      real(kind=kind_phys) deltim
      real(kind=kind_phys) dv(im,km), du(im,km), &
     & tau(im,km), rtg(im,km,ntrac), &
     & uo(ix,km), vo(ix,km), &
     & t1(ix,km), q1(ix,km,ntrac), &
     & swh(ix,km), hlw(ix,km), &
     & xmu(im), &
     & psk(im), rbsoil(im), &
     & fm(im), fh(im), &
     & tsea(im), qss(im), &
     & spd1(im), &
     & prsi(ix,km+1), del(ix,km), &
     & prsl(ix,km), prslk(ix,km), &
     & phii(ix,km+1), phil(ix,km), &
     & rcs(im), dusfc(im), &
     & dvsfc(im), dtsfc(im), &
     & dqsfc(im), hpbl(im), hpblx(im), &
     & hgamt(im), hgamq(im)
      integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond
      integer lcld(im),icld(im),kcld(im),krad(im)
      integer kemx(im)
      real(kind=kind_phys) evap(im), heat(im), phih(im), &
     & phim(im), rbdn(im), rbup(im), &
     & stress(im),beta(im), &
     & ustar(im), wscale(im), thermal(im), &
     & wstar3(im)
      real(kind=kind_phys) thvx(im,km), thlvx(im,km),thraten(im,km), &
     & qlx(im,km), thetae(im,km), &
     & qtx(im,km), bf(im,km-1), &
     & u1(im,km), v1(im,km), radx(im,km-1), &
     & govrth(im), hrad(im), cteit(im), &
     & radmin(im), vrad(im), &
     & zd(im), zdd(im), thlvx1(im)
      real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),dkux(im,km-1), &
     & zi(im,km+1), zl(im,km), xkzo(im,km-1), &
     & dku(im,km-1), dkt(im,km-1),xkzmo(im,km-1), &
     & cku(im,km-1), ckt(im,km-1), &
     & al(im,km-1), ad(im,km), &
     & au(im,km-1), a1(im,km), &
     & a2(im,km*ntrac), theta(im,km)
      real(kind=kind_phys) prinv(im), rent(im)
      logical pblflg(im), sfcflg(im), scuflg(im), flg(im)
      real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, &
     & cfac, conq, cont, conw, &
     & dk, dkmax, dkmin, &
     & dq1, dsdz2, dsdzq, dsdzt, &
     & dsdzu, dsdzv, sfac, &
     & dsig, dt, dthe1, dtodsd, &
     & dtodsu, dw2, dw2min, g, &
     & gamcrq, gamcrt, gocp, gor, gravi, &
     & hol, hol1, pfac, prmax, prmin, &
     & prnum, qmin, tdzmin, qtend, rbcr, &
     & rbint, rdt, rdz, qlmin, &
     & ri, rimin, rl2, rlam, rlamun, &
     & rone, rzero, sfcfrac,sflux, &
     & shr2, spdk2, sri, &
     & tem, ti, ttend, tvd, &
     & tvu, utend, vk, vk2, &
     & vtend, zfac, vpert, cpert, &
     & rentf1, rentf2, radfac, &
     & zfmin, zk, tem1, tem2, &
     & xkzm, xkzmu, xkzminv, &
     & ptem, ptem1, ptem2
      real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, &
     & cldtime, u01, v01, delu, delv
      parameter(gravi=1.0/grav)
      parameter(g=grav)
      parameter(gor=g/rd,gocp=g/cp)
      parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g)
      parameter(rlam=30.0,vk=0.4,vk2=vk*vk)
      parameter(prmin=0.25,prmax=4.)
      parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.)
      parameter(rbcr=0.25,wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1)
      parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.)
      parameter(tdzmin=1.e-3,qlmin=1.e-12,cpert=0.25,sfac=5.4)
      parameter(h1=0.33333333,h2=0.66666667)
      parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3)
      parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0)
      parameter(rentf1=0.2,rentf2=1.0,radfac=0.85)
      parameter(iun=84)
      parameter (zstblmax = 2500., qlcr=3.5e-5)
      parameter (actei = 0.7)
 601 format(1x,' moninp lat lon step hour ',3i6,f6.1)
 602 format(1x,'    k','        z','        t','       th', &
     & '      tvh','        q','        u','        v', &
     & '       sp')
 603 format(1x,i5,8f9.1)
 604 format(1x,'  sfc',9x,f9.1,18x,f9.1)
 605 format(1x,'    k      zl    spd2   thekv   the1v' &
     & ,' thermal    rbup')
 606 format(1x,i5,6f8.2)
 607 format(1x,' kpbl    hpbl      fm      fh   hgamt', &
     & '   hgamq      ws   ustar      cd      ch')
 608 format(1x,i5,9f8.2)
 609 format(1x,' k pr dkt dku ',i5,3f8.2)
 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', &
     & ' sr2  ',2f8.2,2e10.2)
      if (ix .lt. im) stop
      dt = 2. * deltim
      rdt = 1. / dt
      km1 = km - 1
      kmpbl = km / 2
      do k=1,km
        do i=1,im
          zi(i,k) = phii(i,k) * gravi
          zl(i,k) = phil(i,k) * gravi
          u1(i,k) = uo(i,k) * rcs(i)
          v1(i,k) = vo(i,k) * rcs(i)
        enddo
      enddo
      do i=1,im
         zi(i,km+1) = phii(i,km+1) * gravi
      enddo
      do k = 1,km1
        do i=1,im
          rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k))
        enddo
      enddo
      do k = 1,km1
        do i=1,im
          tem1 = 1.0 - prsi(i,k+1) / prsi(i,1)
          tem1 = tem1 * tem1 * 10.0
          xkzo(i,k) = xkzm * min(real(1.0,kind=kind_phys), exp(-tem1))
        enddo
      enddo
      do k = 1,km1
        do i=1,im
          ptem = prsi(i,k+1) / prsi(i,1)
          if(ptem.ge.0.2) then
            xkzmo(i,k) = xkzmu
            ptem1 = prsi(i,k+1)
          else
            tem1 = 1.0 - prsi(i,k+1) / ptem1
            tem1 = tem1 * tem1 * 5.0
            xkzmo(i,k) = xkzmu * min(real(1.0,kind=kind_phys), exp(-tem1))
          endif
        enddo
      enddo
      do k = 1,kmpbl
        do i=1,im
          if(zi(i,k+1).gt.250.) then
            tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k)
            if(tem1 .gt. 1.e-5) then
               xkzo(i,k) = min(xkzo(i,k),xkzminv)
            endif
          endif
        enddo
      enddo
      do i = 1,im
         dusfc(i) = 0.
         dvsfc(i) = 0.
         dtsfc(i) = 0.
         dqsfc(i) = 0.
         hgamt(i) = 0.
         hgamq(i) = 0.
         wscale(i)= 0.
         kpbl(i) = 1
         kpblx(i) = 1
         hpbl(i) = zi(i,1)
         hpblx(i) = zi(i,1)
         pblflg(i)= .true.
         sfcflg(i)= .true.
         if(rbsoil(i).gt.0.0) sfcflg(i) = .false.
         scuflg(i)= .true.
         if(scuflg(i)) then
           radmin(i)= 0.
           cteit(i) = 0.
           rent(i) = rentf1
           hrad(i) = zi(i,1)
           krad(i) = 1
           icld(i) = 0
           lcld(i) = km1
           kcld(i) = km1
           zd(i) = 0.
        endif
      enddo
      do k = 1,km
        do i = 1,im
          theta(i,k) = t1(i,k) * psk(i) / prslk(i,k)
          qlx(i,k) = max(q1(i,k,ntrac),qlmin)
          qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k)
          ptem = qlx(i,k)
          ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k))
          thetae(i,k)= theta(i,k)*(1.+ptem1)
          thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem)
          ptem2 = theta(i,k)-(hvap/cp)*ptem
          thlvx(i,k) = ptem2*(1.+fv*qtx(i,k))
        enddo
      enddo
      do k = 1,km1
        do i = 1,im
          dku(i,k) = 0.
          dkt(i,k) = 0.
          dktx(i,k) = 0.
          dkux(i,k) = 0.
          cku(i,k) = 0.
          ckt(i,k) = 0.
          tem = zi(i,k+1)-zi(i,k)
          radx(i,k) = tem*thraten(i,k)
        enddo
      enddo
      do i=1,im
         flg(i) = scuflg(i)
      enddo
      do k = 1, km1
        do i=1,im
          if(flg(i).and.zl(i,k).ge.zstblmax) then
             lcld(i)=k
             flg(i)=.false.
          endif
      enddo
      enddo
      do k = 1, km1
      do i = 1, im
         bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdzt(i,k)
      enddo
      enddo
      do i = 1,im
        govrth(i) = g/theta(i,1)
      enddo
      do i=1,im
         beta(i) = dt / (zi(i,2)-zi(i,1))
      enddo
      do i=1,im
         ustar(i) = sqrt(stress(i))
         thermal(i) = thvx(i,1)
      enddo
      do i=1,im
         flg(i) = .false.
         rbup(i) = rbsoil(i)
      enddo
      do k = 2, kmpbl
      do i = 1, im
        if(.not.flg(i)) then
          rbdn(i) = rbup(i)
          spdk2 = max((u1(i,k)**2+v1(i,k)**2),real(1.0,kind=kind_phys))
          rbup(i) = (thvx(i,k)-thermal(i))* &
     & (g*zl(i,k)/thvx(i,1))/spdk2
          kpbl(i) = k
          flg(i) = rbup(i).gt.rbcr
        endif
      enddo
      enddo
      do i = 1,im
         k = kpbl(i)
         if(rbdn(i).ge.rbcr) then
           rbint = 0.
         elseif(rbup(i).le.rbcr) then
           rbint = 1.
         else
           rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i))
         endif
         hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
         if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
         hpblx(i) = hpbl(i)
         kpblx(i) = kpbl(i)
      enddo
      do i=1,im
         sflux = heat(i) + evap(i)*fv*theta(i,1)
         if(sfcflg(i).and.sflux.gt.0.) then
           hol = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin)
           hol = min(hol,-zfmin)
           hol1 = hol*hpbl(i)/zl(i,1)*sfcfrac
           tem = 1.0 / (1. - aphi16*hol1)
           phih(i) = sqrt(tem)
           phim(i) = sqrt(phih(i))
           wstar3(i) = govrth(i)*sflux*hpbl(i)
           tem1 = ustar(i)**3.
           wscale(i) = (tem1+wfac*vk*wstar3(i)*sfcfrac)**h1
           wscale(i) = min(wscale(i),ustar(i)*aphi16)
           wscale(i) = max(wscale(i),ustar(i)/aphi5)
         else
           pblflg(i)=.false.
         endif
      enddo
      do i = 1,im
         if(pblflg(i)) then
           hgamt(i) = min(cfac*heat(i)/wscale(i),gamcrt)
           hgamq(i) = min(cfac*evap(i)/wscale(i),gamcrq)
           vpert = hgamt(i) + hgamq(i)*fv*theta(i,1)
           vpert = min(vpert,gamcrt)
           thermal(i)= thermal(i)+max(vpert,real(0.0,kind=kind_phys))
           hgamt(i) = max(hgamt(i),real(0.0,kind=kind_phys))
           hgamq(i) = max(hgamq(i),real(0.0,kind=kind_phys))
         endif
      enddo
      do i=1,im
         flg(i) = .true.
         if(pblflg(i)) then
           flg(i) = .false.
           rbup(i) = rbsoil(i)
         endif
      enddo
      do k = 2, kmpbl
      do i = 1, im
        if(.not.flg(i)) then
          rbdn(i) = rbup(i)
          spdk2 = max((u1(i,k)**2+v1(i,k)**2),real(1.0,kind=kind_phys))
          rbup(i) = (thvx(i,k)-thermal(i))* &
     & (g*zl(i,k)/thvx(i,1))/spdk2
          kpbl(i) = k
          flg(i) = rbup(i).gt.rbcr
        endif
      enddo
      enddo
      do i = 1,im
        if(pblflg(i)) then
           k = kpbl(i)
           if(rbdn(i).ge.rbcr) then
              rbint = 0.
           elseif(rbup(i).le.rbcr) then
              rbint = 1.
           else
              rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i))
           endif
           hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
           if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
           if(kpbl(i).le.1) pblflg(i) = .false.
        endif
      enddo
      do i = 1, im
        flg(i)=scuflg(i)
      enddo
      do k = kmpbl,1,-1
      do i = 1, im
        if(flg(i).and.k.le.lcld(i)) then
          if(qlx(i,k).ge.qlcr) then
             kcld(i)=k
             flg(i)=.false.
          endif
        endif
      enddo
      enddo
      do i = 1, im
        if(scuflg(i).and.kcld(i).eq.km1) scuflg(i)=.false.
      enddo
      do i = 1, im
        flg(i)=scuflg(i)
      enddo
      do k = kmpbl,1,-1
      do i = 1, im
        if(flg(i).and.k.le.kcld(i)) then
          if(qlx(i,k).ge.qlcr) then
            if(radx(i,k).lt.radmin(i)) then
              radmin(i)=radx(i,k)
              krad(i)=k
            endif
          else
            flg(i)=.false.
          endif
        endif
      enddo
      enddo
      do i = 1, im
        if(scuflg(i).and.krad(i).le.1) scuflg(i)=.false.
        if(scuflg(i).and.radmin(i).ge.0.) scuflg(i)=.false.
      enddo
      do i = 1, im
        flg(i)=scuflg(i)
      enddo
      do k = kmpbl,2,-1
      do i = 1, im
        if(flg(i).and.k.le.krad(i)) then
          if(qlx(i,k).ge.qlcr) then
            icld(i)=icld(i)+1
          else
            flg(i)=.false.
          endif
        endif
      enddo
      enddo
      do i = 1, im
        if(scuflg(i).and.icld(i).lt.1) scuflg(i)=.false.
      enddo
      do i = 1, im
        if(scuflg(i)) then
           hrad(i) = zi(i,krad(i)+1)
        endif
      enddo
      do i = 1, im
        if(scuflg(i).and.hrad(i).lt.zi(i,2)) scuflg(i)=.false.
      enddo
      do i = 1, im
        if(scuflg(i)) then
          k = krad(i)
          tem = zi(i,k+1)-zi(i,k)
          tem1 = cldtime*radmin(i)/tem
          thlvx1(i) = thlvx(i,k)+tem1
        endif
      enddo
      do i = 1, im
         flg(i)=scuflg(i)
      enddo
      do k = kmpbl,1,-1
      do i = 1, im
        if(flg(i).and.k.le.krad(i))then
          if(thlvx1(i).le.thlvx(i,k))then
             tem=zi(i,k+1)-zi(i,k)
             zd(i)=zd(i)+tem
          else
             flg(i)=.false.
          endif
        endif
      enddo
      enddo
      do i = 1, im
        if(scuflg(i))then
          kk = max(1, krad(i)+1-icld(i))
          zdd(i) = hrad(i)-zi(i,kk)
        endif
      enddo
      do i = 1, im
        if(scuflg(i))then
          zd(i) = max(zd(i),zdd(i))
          zd(i) = min(zd(i),hrad(i))
          tem = govrth(i)*zd(i)*(-radmin(i))
          vrad(i)= tem**h1
        endif
      enddo
      do i = 1, im
        if(pblflg(i)) then
          tem = phih(i)/phim(i)+cfac*vk*sfcfrac
          prinv(i) = 1.0 / tem
          prinv(i) = min(prinv(i),prmax)
          prinv(i) = max(prinv(i),prmin)
        endif
      enddo
      do k = 1, kmpbl
      do i=1,im
         if(pblflg(i).and.k.lt.kpbl(i)) then
            zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin)
            tem = wscale(i)*vk*zi(i,k+1)*zfac**pfac
            dku(i,k) = xkzmo(i,k) + tem
            dkt(i,k) = xkzo(i,k) + tem * prinv(i)
            dku(i,k) = min(dku(i,k),dkmax)
            dkt(i,k) = min(dkt(i,k),dkmax)
            dktx(i,k)= dkt(i,k)
            dkux(i,k)= dku(i,k)
         endif
      enddo
      enddo
      do i = 1, im
        if(.not.pblflg(i)) then
          kpbl(i) = 1
        endif
      enddo
      do k = 1, km1
         do i=1,im
            if(k.ge.kpbl(i)) then
               rdz = rdzt(i,k)
               ti = 2./(t1(i,k)+t1(i,k+1))
               dw2 = (u1(i,k)-u1(i,k+1))**2 &
     & +(v1(i,k)-v1(i,k+1))**2
               shr2 = max(dw2,dw2min)*rdz*rdz
               bvf2 = g*bf(i,k)*ti
               ri = max(bvf2/shr2,rimin)
               zk = vk*zi(i,k+1)
               if(ri.lt.0.) then
                  rl2 = zk*rlamun/(rlamun+zk)
                  dk = rl2*rl2*sqrt(shr2)
                  sri = sqrt(-ri)
                  dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri))
                  dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri))
               else
                  rl2 = zk*rlam/(rlam+zk)
                  dk = rl2*rl2*sqrt(shr2)
                  tem1 = dk/(1+5.*ri)**2
                  if(k.ge.kpblx(i)) then
                    prnum = 1.0 + 2.1*ri
                    prnum = min(prnum,prmax)
                  else
                    prnum = 1.0
                  endif
                  dkt(i,k) = xkzo(i,k) + tem1
                  dku(i,k) = xkzmo(i,k) + tem1 * prnum
               endif
               dku(i,k) = min(dku(i,k),dkmax)
               dkt(i,k) = min(dkt(i,k),dkmax)
            endif
         enddo
      enddo
      do i = 1, im
        if(scuflg(i)) then
           k = krad(i)
           tem = thetae(i,k) - thetae(i,k+1)
           tem1 = qtx(i,k) - qtx(i,k+1)
           if (tem.gt.0..and.tem1.gt.0.) then
             cteit(i)= cp*tem/(hvap*tem1)
             if(cteit(i).gt.actei) rent(i) = rentf2
           endif
        endif
      enddo
      do i = 1, im
        if(scuflg(i)) then
           k = krad(i)
           tem1 = max(bf(i,k),tdzmin)
           ckt(i,k) = -rent(i)*radmin(i)/tem1
           cku(i,k) = ckt(i,k)
        endif
      enddo
      do k = 1, kmpbl
         do i=1,im
            if(scuflg(i).and.k.lt.krad(i)) then
               tem1=hrad(i)-zd(i)
               tem2=zi(i,k+1)-tem1
               if(tem2.gt.0.) then
                  ptem= tem2/zd(i)
                  if(ptem.ge.1.) ptem= 1.
                  ptem= tem2*ptem*sqrt(1.-ptem)
                  ckt(i,k) = radfac*vk*vrad(i)*ptem
                  cku(i,k) = 0.75*ckt(i,k)
                  ckt(i,k) = max(ckt(i,k),dkmin)
                  ckt(i,k) = min(ckt(i,k),dkmax)
                  cku(i,k) = max(cku(i,k),dkmin)
                  cku(i,k) = min(cku(i,k),dkmax)
               endif
            endif
         enddo
      enddo
      do k = 1, kmpbl
        do i=1,im
          if(scuflg(i)) then
             dkt(i,k) = dkt(i,k)+ckt(i,k)
             dku(i,k) = dku(i,k)+cku(i,k)
             dkt(i,k) = min(dkt(i,k),dkmax)
             dku(i,k) = min(dku(i,k),dkmax)
          endif
        enddo
      enddo
      do i=1,im
         ad(i,1) = 1.
         a1(i,1) = t1(i,1) + beta(i) * heat(i)
         a2(i,1) = q1(i,1,1) + beta(i) * evap(i)
      enddo
      if(ntrac.ge.2) then
        do k = 2, ntrac
          is = (k-1) * km
          do i = 1, im
            a2(i,1+is) = q1(i,1,k)
          enddo
        enddo
      endif
      do k = 1,km1
        do i = 1,im
          dtodsd = dt/del(i,k)
          dtodsu = dt/del(i,k+1)
          dsig = prsl(i,k)-prsl(i,k+1)
          rdz = rdzt(i,k)
          tem1 = dsig * dkt(i,k) * rdz
          if(pblflg(i).and.k.lt.kpbl(i)) then
             ptem1 = dsig * dktx(i,k) * rdz
             tem = 1.0 / hpbl(i)
             dsdzt = tem1 * gocp - ptem1*hgamt(i)*tem
             dsdzq = ptem1 * (-hgamq(i)*tem)
             a2(i,k) = a2(i,k)+dtodsd*dsdzq
             a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq
          else
             dsdzt = tem1 * gocp
             a2(i,k+1) = q1(i,k+1,1)
          endif
          dsdz2 = tem1 * rdz
          au(i,k) = -dtodsd*dsdz2
          al(i,k) = -dtodsu*dsdz2
          ad(i,k) = ad(i,k)-au(i,k)
          ad(i,k+1) = 1.-al(i,k)
          a1(i,k) = a1(i,k)+dtodsd*dsdzt
          a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt
        enddo
      enddo
      if(ntrac.ge.2) then
        do kk = 2, ntrac
          is = (kk-1) * km
          do k = 1, km1
            do i = 1, im
              a2(i,k+1+is) = q1(i,k+1,kk)
            enddo
          enddo
        enddo
      endif
      call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2)
      do k = 1,km
         do i = 1,im
            ttend = (a1(i,k)-t1(i,k))*rdt
            qtend = (a2(i,k)-q1(i,k,1))*rdt
            tau(i,k) = tau(i,k)+ttend
            rtg(i,k,1) = rtg(i,k,1)+qtend
            dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend
            dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend
         enddo
      enddo
      if(ntrac.ge.2) then
        do kk = 2, ntrac
          is = (kk-1) * km
          do k = 1, km
            do i = 1, im
              qtend = (a2(i,k+is)-q1(i,k,kk))*rdt
              rtg(i,k,kk) = rtg(i,k,kk)+qtend
            enddo
          enddo
        enddo
      endif
      do i=1,im
         ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i)
         a1(i,1) = u1(i,1)
         a2(i,1) = v1(i,1)
      enddo
      do k = 1,km1
        do i=1,im
          dtodsd = dt/del(i,k)
          dtodsu = dt/del(i,k+1)
          dsig = prsl(i,k)-prsl(i,k+1)
          rdz = rdzt(i,k)
          tem1 = dsig*dku(i,k)*rdz
            a1(i,k+1) = u1(i,k+1)
            a2(i,k+1) = v1(i,k+1)
          dsdz2 = tem1*rdz
          au(i,k) = -dtodsd*dsdz2
          al(i,k) = -dtodsu*dsdz2
          ad(i,k) = ad(i,k)-au(i,k)
          ad(i,k+1) = 1.-al(i,k)
        enddo
      enddo
      call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2)
      do k = 1,km
         do i = 1,im
            ptem = 1./rcs(i)
            utend = (a1(i,k)-u1(i,k))*rdt
            vtend = (a2(i,k)-v1(i,k))*rdt
            du(i,k) = du(i,k)+utend*ptem
            dv(i,k) = dv(i,k)+vtend*ptem
            dusfc(i) = dusfc(i)+conw*del(i,k)*utend
            dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend
         enddo
      enddo
      do i = 1, im
         hpbl(i) = hpblx(i)
         kpbl(i) = kpblx(i)
      enddo
      return
      end subroutine moninq
      SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer k,n,l,i
      real(kind=kind_phys) fk
      real(kind=kind_phys) CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), &
     & AU(L,N-1),A1(L,N),A2(L,N)
      DO I=1,L
        FK = 1./CM(I,1)
        AU(I,1) = FK*CU(I,1)
        A1(I,1) = FK*R1(I,1)
        A2(I,1) = FK*R2(I,1)
      ENDDO
      DO K=2,N-1
        DO I=1,L
          FK = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FK*CU(I,K)
          A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
          A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
        ENDDO
      ENDDO
      DO I=1,L
        FK = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
        A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
        A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
      ENDDO
      DO K=N-1,1,-1
        DO I=1,L
          A1(I,K) = A1(I,K)-AU(I,K)*A1(I,K+1)
          A2(I,K) = A2(I,K)-AU(I,K)*A2(I,K+1)
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDI2
      SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer is,k,kk,n,nt,l,i
      real(kind=kind_phys) fk(L)
      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), &
     & R1(L,N), R2(L,N*nt), &
     & AU(L,N-1), A1(L,N), A2(L,N*nt), &
     & FKK(L,2:N-1)
      DO I=1,L
        FK(I) = 1./CM(I,1)
        AU(I,1) = FK(I)*CU(I,1)
        A1(I,1) = FK(I)*R1(I,1)
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          a2(i,1+is) = fk(I) * r2(i,1+is)
        enddo
      enddo
      DO K=2,N-1
        DO I=1,L
          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FKK(I,K)*CU(I,K)
          A1(I,K) = FKK(I,K)*(R1(I,K)-CL(I,K)*A1(I,K-1))
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=2,N-1
          DO I=1,L
            A2(I,K+is) = FKK(I,K)*(R2(I,K+is)-CL(I,K)*A2(I,K+is-1))
          ENDDO
        ENDDO
      ENDDO
      DO I=1,L
        FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
        A1(I,N) = FK(I)*(R1(I,N)-CL(I,N)*A1(I,N-1))
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          A2(I,N+is) = FK(I)*(R2(I,N+is)-CL(I,N)*A2(I,N+is-1))
        enddo
      enddo
      DO K=N-1,1,-1
        DO I=1,L
          A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1)
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=n-1,1,-1
          DO I=1,L
            A2(I,K+is) = A2(I,K+is) - AU(I,K)*A2(I,K+is+1)
          ENDDO
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDIN
      SUBROUTINE TRIDIT(L,N,nt,CL,CM,CU,RT,AU,AT)
      USE MODULE_GFS_MACHINE, ONLY : kind_phys
      implicit none
      integer is,k,kk,n,nt,l,i
      real(kind=kind_phys) fk(L)
      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1), &
     & RT(L,N*nt), &
     & AU(L,N-1), AT(L,N*nt), &
     & FKK(L,2:N-1)
      DO I=1,L
        FK(I) = 1./CM(I,1)
        AU(I,1) = FK(I)*CU(I,1)
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          at(i,1+is) = fk(I) * rt(i,1+is)
        enddo
      enddo
      DO K=2,N-1
        DO I=1,L
          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
          AU(I,K) = FKK(I,K)*CU(I,K)
        ENDDO
      ENDDO
      do kk = 1, nt
        is = (kk-1) * n
        DO K=2,N-1
          DO I=1,L
            AT(I,K+is) = FKK(I,K)*(RT(I,K+is)-CL(I,K)*AT(I,K+is-1))
          ENDDO
        ENDDO
      ENDDO
      DO I=1,L
        FK(I) = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
      ENDDO
      do k = 1, nt
        is = (k-1) * n
        do i = 1, l
          AT(I,N+is) = FK(I)*(RT(I,N+is)-CL(I,N)*AT(I,N+is-1))
        enddo
      enddo
      do kk = 1, nt
        is = (kk-1) * n
        DO K=n-1,1,-1
          DO I=1,L
            AT(I,K+is) = AT(I,K+is) - AU(I,K)*AT(I,K+is+1)
          ENDDO
        ENDDO
      ENDDO
      RETURN
      END SUBROUTINE TRIDIT
      END MODULE module_bl_gfs2011


	SUBROUTINE DIFFFK(XN,YN,ZN,BX,BY,BZ,D,XT,YT,ZT,XI,YI,ZI,IN)
C
	IMPLICIT REAL*4 (A-H)
	IMPLICIT INTEGER*4 (I-N)
	IMPLICIT REAL*4 (O-Z)
C
C	CALCULATES DIFF TO BOW SHOCK, ALGEBRA IN WIND VOL 4 P 89-90
C		D IS DIFF, XT,YT,ZT ARE COORDINATES OF TANGENT POINT
C		XI,YI,ZI ARE COORDINATES OF INTERSECION WITH SHOCK
C		INPUT XN, ETC ARE IN EARTH RADII, B IN nT
C		IN = 1, INSIDE SHOCK, 2 FORESHOCK, 3 FREE SW
C		positive d means field intersects bow shock
C
	DATA XNOSE,RS /14.6,25.6/
C
	IF(BX.EQ.0.) THEN
	  D = -(XN-XNOSE)
	  RETURN
	ENDIF
C
	RS2 = RS**2
	BX2 = BX**2
	BY2 = BY**2
	BZ2 = BZ**2
C	print*,'in diff,X,B',xn,bx,by,bz
C
	a = -(BY2 + BZ2)/BX2/RS2
C	print*,'a=',a
	ZXN = ZN - XN*BZ/BX
	YXN = YN - XN*BY/BX
	b0 = 1./XNOSE +2.*(BZ*ZXN/BX + BY*YXN/BX)/RS2
	b0 = -b0
	b1 = -2.*a
	c0 = 1. - (YXN**2 + ZXN**2)/RS2
	c1 = 2.*(BZ*ZXN/BX + BY*YXN/BX)/RS2
	c2 = a
	BB = 2.*b0*b1 - 4.*a*c1
	CC = b0**2 - 4.*a*c0
	D = 0.
	IF(BB.NE.0.) D = -CC/BB
C
	IF(D.GE.0.) THEN
C
C	  CALCULATE TANGENT POINT IF DIFF IS POSITIVE
C
	  AT = a
	  BT = b0 + b1*d
	  CT = c0 + c1*d + c2*d**2
	  XT = -.5*BT/AT
	  YT = YN + BY*(XT - XN - D)/BX
	  ZT = ZN + BZ*(XT - XN - D)/BX
C
C	  CALCULATE INTERSECTION IF DIFF IS POSITIVE
C	    THERE ARE TWO SOLUTIONS, XI1 AND XI2, OF
C	    AI X**2 + BI X + CI = 0
C
	  AI = a
	  BI = b0
	  CI = c0
	  TEST = BI**2-4.*AI*CI
	  IF(TEST.GE.0.) THEN
	    XI1 = .5*(-BI + SQRT(BI**2-4.*AI*CI))/AI
	    YI1 = YN + BY*(XI1-XN)/BX
	    ZI1 = ZN + BZ*(XI1-XN)/BX
	    XI2 = .5*(-BI - SQRT(BI**2-4.*AI*CI))/AI
	    YI2 = YN + BY*(XI2-XN)/BX
	    ZI2 = ZN + BZ*(XI2-XN)/BX
	    D1SQ = (XN-XI1)**2 + (YN-YI1)**2 + (ZN-ZI1)**2
	    D2SQ = (XN-XI2)**2 + (YN-YI2)**2 + (ZN-ZI2)**2
	    IF(D1SQ.LT.D2SQ) THEN
	      XI = XI1
	      YI = YI1
	      ZI = ZI1
	    ELSE
	      XI = XI2
	      YI = YI2
	      ZI = ZI2
	    ENDIF
	  ELSE
	    IN = 2
	  ENDIF
	  IF(XN.LE.XI1.AND.XN.GE.XI2) IN = 1
	  IF(XN.LE.XI2.AND.XN.GE.XI1) IN = 1
C
	ELSE
	  XT = 0.
	  YT = 0.
	  ZT = 0.
	  XI = 0.
	  YI = 0.
	  ZI = 0.
	  IN = 3
	ENDIF
C
	RETURN
	END


module pmmf_fic_case2
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FOUR, FIVE, EIGHT, PI
    use type_prescribed_mesh_motion_function,  only: prescribed_mesh_motion_function_t
    implicit none
    private

    !>  Flow In Cylinder - Case2 prescribed motion.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------------
    type, extends(prescribed_mesh_motion_function_t), public :: fic_case2_pmmf
        private

    contains

        procedure   :: init
        procedure   :: compute_pos
        procedure   :: compute_vel

    end type fic_case2_pmmf
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(fic_case2_pmmf),  intent(inout)  :: self

        ! Set function name
        call self%set_name("Flow In Cylinder - Case2")

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_pos(self,time,node) result(val)
        class(fic_case2_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik) :: ivar
        real(rk)    :: val(3)

        real(rk)    :: alpha, Atheta, x0, y0, x_ale, y_ale, &
                       xc, yc, height, theta

        Atheta = PI
        alpha = time**TWO*(THREE-time)/FOUR

        ! Case 2
        height = ZERO
        theta  = Atheta*alpha

        ! Center of motion nodeinates
        xc = ZERO
        yc = ZERO

        ! Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        ! Rotation about center
        x_ale =  cos(theta)*(x0-xc)+sin(theta)*(y0-yc) + xc
        y_ale = -sin(theta)*(x0-xc)+cos(theta)*(y0-yc) + yc

        ! Translation
        y_ale = y_ale + height

        val(1) = x_ale
        val(2) = y_ale
        val(3) = node(3)

    end function compute_pos
    !**********************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   10/02/2019
    !!
    !!
    !-----------------------------------------------------------------------------------------
    function compute_vel(self,time,node) result(val)
        class(fic_case2_pmmf),  intent(inout)   :: self
        real(rk),               intent(in)      :: time
        real(rk),               intent(in)      :: node(3)

        integer(ik) :: ivar
        real(rk)    :: val(3)
        real(rk)    :: alpha, dalphadt, &
                       Atheta, x0, y0, vx_ale, vy_ale, &
                       xc, yc, height, theta, dheightdt, dthetadt

        Atheta   = PI
        alpha    = time**TWO*(THREE-time)/FOUR
        dalphadt = TWO*time*(THREE-time)/FOUR - (time**TWO)/FOUR

        !Case 2
        height    = ZERO
        theta     = Atheta*alpha
        dheightdt = ZERO
        dthetadt  = Atheta*dalphadt

        !Center of motion nodeinates
        xc = ZERO
        yc = ZERO

        !Get the reference frame nodeinates of the grid point
        x0 = node(1)
        y0 = node(2)

        ! Rotation about (xc,yc)
        vx_ale = -sin(theta)*dthetadt*(x0-xc)+cos(theta)*dthetadt*(y0-yc)
        vy_ale = -cos(theta)*dthetadt*(x0-xc)-sin(theta)*dthetadt*(y0-yc)

        !Translate vertically
        vy_ale = vy_ale + dheightdt

        val(1) = vx_ale
        val(2) = vy_ale
        val(3) = ZERO

    end function compute_vel
    !**********************************************************************************

end module pmmf_fic_case2


module PROCESSING
! Description:
!    Contains the RESIDUALS subroutine for computing residuals (= numerical
!    errors wrt the reference integration).
!
! Author:
!    Davide Amato
!    Space Dynamics Group - Technical University of Madrid
!    d.amato@upm.es
!
! ==============================================================================

use KINDS, only: dk,qk
implicit none

contains

subroutine RESIDUALS(npts,ref,test,AU_km,mu,RSw,dR_abs,dR_rel,dV_abs,dV_rel,dEn_rel,&
&dSMA_abs,RSw_eff,RSw_diff_max)
! Description:
!    Computes absolute and relative position residuals, relative energy residuals
!    and absolute SMA residuals for the current integration.
!
! ==============================================================================

! VARIABLES
implicit none
! Arguments IN
integer,intent(in)    ::  npts              ! Number of points to evaluate
real(qk),intent(in)   ::  ref(1:npts,1:7)   ! Heliocentric reference state [s,km,km/s]
real(qk),intent(in)   ::  test(1:npts,1:7)  ! Heliocentric test state      [s,km,km/s]
real(qk),intent(in)   ::  AU_km,mu,RSw
real(dk),intent(in)   ::  RSw_eff(1:2)
! Arguments OUT
real(dk),intent(out)  ::  dR_abs(1:npts),dR_rel(1:npts)     ! Heliocentric position residuals [AU,-]
real(dk),intent(out)  ::  dV_abs(1:npts),dV_rel(1:npts)     ! Heliocentric velocity residuals [km/s,-]
real(dk),intent(out)  ::  dEn_rel(1:npts)                   ! Energy residuals [(km/s)^2,-]
real(dk),intent(out)  ::  dSMA_abs(1:npts)                  ! SMA residuals [AU]
real(dk),intent(out)  ::  RSw_diff_max

! Locals
! QUAD
real(qk)     ::  dR_vec(1:3),dV_vec(1:3)
real(qk)     ::  r_ref,v_ref
! DOUBLE
real(dk)     ::  r_test,v_test
real(dk)     ::  En_ref,En_test
real(dk)     ::  sma_ref,sma_test
real(dk)     ::  dEn_abs
real(dk)     ::  RSw_diff(1:2)

integer  ::  i

! ==============================================================================

do i=1,npts
  r_ref = sqrt(dot_product(ref(i,2:4),ref(i,2:4)))
  v_ref = sqrt(dot_product(ref(i,5:7),ref(i,5:7)))
  r_test = sqrt(dot_product(test(i,2:4),test(i,2:4)))
  v_test = sqrt(dot_product(test(i,5:7),test(i,5:7)))

  ! 1. POSITION RESIDUALS
  dR_vec = ref(i,2:4)/AU_km - test(i,2:4)/AU_km
  dR_abs(i) = sqrt(dot_product(dR_vec,dR_vec))
  dR_rel(i) = dR_abs(i)/(r_ref/AU_km)

  ! 2. VELOCITY RESIDUALS
  dV_vec = ref(i,5:7) - test(i,5:7)
  dV_abs(i) = sqrt(dot_product(dV_vec,dV_vec))
  dV_rel(i) = dV_abs(i)/v_ref

  ! 3. ENERGY RESIDUALS
  En_ref = 0.5_qk*v_ref**2 - mu/r_ref
  En_test = 0.5_dk*v_test**2 - mu/r_test
  dEn_abs = abs(En_test - En_ref)
  dEn_rel(i) = dEn_abs/En_ref

  ! 4. SMA RESIDUALS
  sma_ref = -mu/(v_ref**2 - 2._qk*mu/r_ref)  ! Note: we compute it in quad
  sma_test = -0.5_dk*mu/En_test
  dSMA_abs(i) = (sma_test - sma_ref)/AU_km

end do

! Check on the effective switch radius
RSw_diff = abs((RSw_eff - RSw)/RSw)
RSw_diff_max = maxval(RSw_diff)

end subroutine RESIDUALS

end module PROCESSING


!>  \file radiation_astronomy.f
!!  This file sets up astronomical quantities for solar radiation
!!  calculations.

!  ==========================================================  !!!!!
!          'module_radiation_astronomy'  description           !!!!!
!  ==========================================================  !!!!!
!                                                                      !
!   set up astronomy quantities for solar radiation calculations.      !
!                                                                      !
!   in module 'module_radiation_astronomy', externally accessable      !
!   subroutines are listed below:                                      !
!                                                                      !
!      'sol_init'   -- initialization                                  !
!         input:                                                       !
!           ( me )                                                     !
!         output:                                                      !
!           ( none )                                                   !
!                                                                      !
!      'sol_update' -- update astronomy related quantities             !
!         input:                                                       !
!           ( jdate,kyear,deltsw,deltim,lsol_chg, me )                 !
!         output:                                                      !
!           ( slag,sdec,cdec,solcon )                                  !
!                                                                      !
!      'coszmn'     -- compute cosin of zenith angles                  !
!         input:                                                       !
!           ( xlon,sinlat,coslat,solhr,IM, me )                        !
!         output:                                                      !
!           ( coszen,coszdg )                                          !
!                                                                      !
!                                                                      !
!   external modules referenced:                                       !
!       'module physparam'                  in 'physparam.f'           !
!       'module physcons'                   in 'physcons.f'            !
!                                                                      !
!   program history log:                                               !
!   - a collection of programs to track solar-earth position           !
!     may  1977  ---  ray orzol    (gfdl) created program compjd to    !
!          computes julian day and fraction from year,month,dayand,time!
!     jun  1977  ---  robert white (gfdl) created program cdate to     !
!          computes calendar month, day, year from julian day value.   !
!     jul  1977  ---  robert white (gfdl) created program solar to     !
!          computes radius vector, declination and right ascension of  !
!          sun, equation of time, hour angle, fractional daylight, and !
!          latitudinal mean zenith angle.                              !
!     fall 1988  ---  hualu pan,  updated to limit the iterations in   !
!          newton method and also ccr reduced to avoid non-convergence.!
!     jul  1989  ---  kenneth campana  modified subr solar and created !
!          subr zenith for computations of effective mean cosz and     !
!          daylight fraction.                                          !
!     oct  1990  ---  yu-tai hou      created subr coszmn to replace   !
!          the latitudinal mean cosz by time mean cosz at grid points. !
!     may  1998  ---  mark iredell    y2k compliance                   !
!     dec  2003  ---  yu-tai hou      combined compjd and fcstim and   !
!          rewritten programs in fortran 90 compatable modular form.   !
!     feb  2006  ---  yu-tai hou      add 11-yr solar constant cycle   !
!     mar  2009  ---  yu-tai hou      modified solinit for climate     !
!          hindcast situation responding to ic time.                   !
!     aug  2012  ---  yu-tai hou      modified coszmn to allows sw     !
!          radiation calling interval less than 1 hr limit and linked  !
!          model time step with numb of cosz evaluations. also changed !
!          the initialization subroutine 'solinit' into two parts:     !
!          'sol_init' is called at the start of run to set up module   !
!          parameters; and 'sol_update' is called within the time      !
!          loop to check and update data sets.                         !
!     nov  2012  ---  yu-tai hou      modified control parameters thru !
!          model 'physparam'.                                          !
!     jan  2013  ---  yu-tai hou      modified to include new solar    !
!          constant tables (noaa_a0, noaa_an, cmip_an, cmip_mn)        !
!                                                                      !
!!!!!  ==========================================================  !!!!!
!!!!!                       end descriptions                       !!!!!
!!!!!  ==========================================================  !!!!!

! \ingroup RRTMG
!> \defgroup module_radiation_astronomy RRTMG Astronomy Module
!> \brief This module sets up astronomical quantities for solar radiation
!!  calculations.
!! \version NCEP-Radiation_astronomy v5.2  Jan 2013
!========================================!
      module module_radiation_astronomy  !
!........................................!
!
      use physparam,         only : isolar, solar_file, kind_phys
      use physcons,          only : con_solr, con_solr_old, con_pi
      use module_iounitdef,  only : NIRADSF
!
      implicit   none
!
      private

!  ---  version tag and last revision date
      character(40), parameter ::                                       &
     &   VTAGAST='NCEP-Radiation_astronomy v5.2  Jan 2013 '
!    &   VTAGAST='NCEP-Radiation_astronomy v5.1  Nov 2012 '

!>\name Parameter constants
      real (kind=kind_phys), parameter :: degrad = 180.0/con_pi
      real (kind=kind_phys), parameter :: tpi    = 2.0 * con_pi
      real (kind=kind_phys), parameter :: hpi    = 0.5 * con_pi
      real (kind=kind_phys), parameter :: f12    = 12.0
      real (kind=kind_phys), parameter :: f3600  = 3600.0
      real (kind=kind_phys), parameter :: czlimt = 0.0001      ! ~ cos(89.99427)
!     real (kind=kind_phys), parameter :: pid12  = con_pi/f12  ! angle per hour
      real (kind=kind_phys), parameter :: pid12  = (2.0*asin(1.0))/f12

! \name Module variable (to be set in module_radiation_astronomy::sol_init):
      real (kind=kind_phys), public    :: solc0 = con_solr
      integer   :: isolflg = 10
      character(26) :: solar_fname = ' '

! \name Module variables (to be set in module_radiation_astronomy::sol_update)

! equation of time
      real (kind=kind_phys) :: sollag=0.0
! sine of the solar declination angle
      real (kind=kind_phys) :: sindec=0.0
! cosine of the solar declination angle
      real (kind=kind_phys) :: cosdec=0.0
! solar angle increment per interation of cosz calc
      real (kind=kind_phys) :: anginc=0.0
! saved monthly solar constants (isolflg=4 only)
      real (kind=kind_phys) :: smon_sav(12)
      data smon_sav(1:12) / 12*con_solr /

! saved year  of data used
      integer               :: iyr_sav =0
! total number of zenith angle iterations
      integer               :: nstp    =6

      public  sol_init, sol_update, coszmn

! =================
      contains
! =================

!>\ingroup module_radiation_astronomy
!> This subroutine initializes astronomy process, and set up module
!! constants.
!!\param me         print message control flag
!>\section sol_init_gen sol_init General Algorithm
!! @{
      subroutine sol_init                                               &
     &     ( me ) !  ---  inputs
!  ---  outputs: ( none )

!  ===================================================================  !
!                                                                       !
!  initialize astronomy process, set up module constants.               !
!                                                                       !
!  inputs:                                                              !
!     me      - print message control flag                              !
!                                                                       !
!  outputs:  (to module variable)                                       !
!     ( none )                                                          !
!                                                                       !
!  external module variable: (in physparam)                             !
!   isolar    - = 0: use the old fixed solar constant in "physcon"      !
!               =10: use the new fixed solar constant in "physcon"      !
!               = 1: use noaa ann-mean tsi tbl abs-scale with cyc apprx !
!               = 2: use noaa ann-mean tsi tbl tim-scale with cyc apprx !
!               = 3: use cmip5 ann-mean tsi tbl tim-scale with cyc apprx!
!               = 4: use cmip5 mon-mean tsi tbl tim-scale with cyc apprx!
!   solar_file- external solar constant data table                      !
!                                                                       !
!  internal module variable:                                            !
!   isolflg   - internal solar constant scheme control flag             !
!   solc0     - solar constant  (w/m**2)                                !
!   solar_fname-file name for solar constant table assigned based on    !
!               the scheme control flag, isolflg.                       !
!                                                                       !
!  usage:    call sol_init                                              !
!                                                                       !
!  subprograms called:  none                                            !
!                                                                       !
!  ===================================================================  !
!
      implicit none

!  ---  input:
      integer,  intent(in) :: me

!  ---  output: ( none )

!  ---  local:
      logical :: file_exist
!
!===>  ...  begin here
!
      if ( me == 0 ) print *, VTAGAST    !print out version tag

!  ---  initialization
      isolflg = isolar
      solc0   = con_solr
      solar_fname = solar_file
      iyr_sav = 0
      nstp    = 6

      if ( isolar == 0 ) then
        solc0   = con_solr_old
        if ( me == 0 ) then
          print *,' - Using old fixed solar constant =', solc0
        endif
      elseif ( isolar == 10 ) then
        if ( me == 0 ) then
          print *,' - Using new fixed solar constant =', solc0
        endif
      elseif ( isolar == 1 ) then        ! noaa ann-mean tsi in absolute scale
        solar_fname(15:26) = 'noaa_a0.txt'

        if ( me == 0 ) then
          print *,' - Using NOAA annual mean TSI table in ABS scale',   &
     &            ' with cycle approximation (old values)!'
        endif

        inquire (file=solar_fname, exist=file_exist)
        if ( .not. file_exist ) then
          isolflg = 10

          if ( me == 0 ) then
            print *,'   Requested solar data file "',solar_fname,       &
     &              '" not found!'
            print *,'   Using the default solar constant value =',solc0,&
     &              ' reset control flag isolflg=',isolflg
          endif
        endif
      elseif ( isolar == 2 ) then        ! noaa ann-mean tsi in tim scale
        solar_fname(15:26) = 'noaa_an.txt'

        if ( me == 0 ) then
          print *,' - Using NOAA annual mean TSI table in TIM scale',   &
     &            ' with cycle approximation (new values)!'
        endif

        inquire (file=solar_fname, exist=file_exist)
        if ( .not. file_exist ) then
          isolflg = 10

          if ( me == 0 ) then
            print *,'   Requested solar data file "',solar_fname,       &
     &              '" not found!'
            print *,'   Using the default solar constant value =',solc0,&
     &              ' reset control flag isolflg=',isolflg
          endif
        endif
      elseif ( isolar == 3 ) then        ! cmip5 ann-mean tsi in tim scale
        solar_fname(15:26) = 'cmip_an.txt'

        if ( me == 0 ) then
          print *,' - Using CMIP5 annual mean TSI table in TIM scale',  &
     &            ' with cycle approximation'
        endif

        inquire (file=solar_fname, exist=file_exist)
        if ( .not. file_exist ) then
          isolflg = 10

          if ( me == 0 ) then
            print *,'   Requested solar data file "',solar_fname,       &
     &              '" not found!'
            print *,'   Using the default solar constant value =',solc0,&
     &              ' reset control flag isolflg=',isolflg
          endif
        endif
      elseif ( isolar == 4 ) then        ! cmip5 mon-mean tsi in tim scale
        solar_fname(15:26) = 'cmip_mn.txt'

        if ( me == 0 ) then
          print *,' - Using CMIP5 monthly mean TSI table in TIM scale', &
     &            ' with cycle approximation'
        endif

        inquire (file=solar_fname, exist=file_exist)
        if ( .not. file_exist ) then
          isolflg = 10

          if ( me == 0 ) then
            print *,'   Requested solar data file "',solar_fname,       &
     &              '" not found!'
            print *,'   Using the default solar constant value =',solc0,&
     &              ' reset control flag isolflg=',isolflg
          endif
        endif
      else                               ! selection error
        isolflg = 10

        if ( me == 0 ) then
          print *,' - !!! ERROR in selection of solar constant data',   &
     &            ' source, ISOL =',isolar
          print *,'   Using the default solar constant value =',solc0,  &
     &              ' reset control flag isolflg=',isolflg
        endif
      endif       ! end if_isolar_block
!
      return
!...................................
      end subroutine sol_init
!! @}
!-----------------------------------

!>\ingroup module_radiation_astronomy
!> This subroutine computes solar parameters at forecast time.
!!\param jdate     ncep absolute date and time at fcst time
!!                 (yr, mon, day, t-zone, hr, min, sec, mil-sec)
!!\param kyear     usually kyear=jdate(1). if not, it is for hindcast
!!                 mode, and it is usually the init cond time and
!!                 serves as the upper limit of data can be used.
!!\param deltsw    time duration in seconds per sw calculation
!!\param deltim    timestep in seconds
!!\param lsol_chg  logical flags for change solar constant
!!\param me        print message control flag
!!\param slag               equation of time in radians
!!\param sdec, cdec         sin and cos of the solar declination angle
!!\param solcon             sun-earth distance adjusted solar constant
!!                           \f$(w/m^2)\f$
!>\section gen_sol_update sol_update General Algorithm
!! @{
!-----------------------------------
      subroutine sol_update                                             &
     &     ( jdate,kyear,deltsw,deltim,lsol_chg, me,                    &     !  ---  inputs
     &       slag, sdec, cdec, solcon                                   &     !  ---  outputs
     &      )

!  ===================================================================  !
!                                                                       !
!  sol_update computes solar parameters at forecast time                !
!                                                                       !
!  inputs:                                                              !
!     jdate(8)- ncep absolute date and time at fcst time                !
!                (yr, mon, day, t-zone, hr, min, sec, mil-sec)          !
!     kyear   - usually kyear=jdate(1). if not, it is for hindcast mode,!
!               and it is usually the init cond time and serves as the  !
!               upper limit of data can be used.                        !
!     deltsw  - time duration in seconds per sw calculation             !
!     deltim  - timestep in seconds                                     !
!     lsol_chg- logical flags for change solar constant                 !
!     me      - print message control flag                              !
!                                                                       !
!  outputs:                                                             !
!    slag          - equation of time in radians                        !
!    sdec, cdec    - sin and cos of the solar declination angle         !
!    solcon        - sun-earth distance adjusted solar constant (w/m2)  !
!                                                                       !
!                                                                       !
!  module variable:                                                     !
!   solc0   - solar constant  (w/m**2) not adjusted by earth-sun dist   !
!   isolflg - solar constant control flag                               !
!             = 0: use the old fixed solar constant                     !
!             =10: use the new fixed solar constant                     !
!             = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx !
!             = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx !
!             = 3: use cmip5 ann-mean tsi tbl tim-scale with cycle apprx!
!             = 4: use cmip5 mon-mean tsi tbl tim-scale with cycle apprx!
!   solar_fname-external solar constant data table                      !
!   sindec  - sine of the solar declination angle                       !
!   cosdec  - cosine of the solar declination angle                     !
!   anginc  - solar angle increment per iteration for cosz calc         !
!   nstp    - total number of zenith angle iterations                   !
!   smon_sav- saved monthly solar constants (isolflg=4 only)            !
!   iyr_sav - saved year  of data previously used                       !
!                                                                       !
!  usage:    call sol_update                                            !
!                                                                       !
!  subprograms called:  solar, prtime                                   !
!                                                                       !
!  external functions called: iw3jdn                                    !
!                                                                       !
!  ===================================================================  !
!
      implicit none

!  ---  input:
      integer, intent(in) :: jdate(:), kyear, me
      logical, intent(in) :: lsol_chg

      real (kind=kind_phys), intent(in) :: deltsw, deltim

!  ---  output:
      real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon

!  ---  locals:
      real (kind=kind_phys), parameter :: hrday = 1.0/24.0    ! frc day/hour
      real (kind=kind_phys), parameter :: minday= 1.0/1440.0  ! frc day/minute
      real (kind=kind_phys), parameter :: secday= 1.0/86400.0 ! frc day/second

      real (kind=kind_phys) :: smean, solc1, dtswh, smon(12)
      real (kind=kind_phys) :: fjd, fjd1, dlt, r1, alp

      integer :: jd, jd1, iyear, imon, iday, ihr, imin, isec
      integer :: iw3jdn
      integer :: i, iyr, iyr1, iyr2, jyr, nn, nswr, icy1, icy2, icy

      logical :: file_exist
      character :: cline*60
!
!===>  ...  begin here
!
!  --- ...  forecast time
      iyear = jdate(1)
      imon  = jdate(2)
      iday  = jdate(3)
      ihr   = jdate(5)
      imin  = jdate(6)
      isec  = jdate(7)

      if ( lsol_chg ) then   ! get solar constant from data table

        if ( iyr_sav == iyear ) then   ! same year, no new reading necessary
          if ( isolflg==4 ) then
            solc0 = smon_sav(imon)
          endif
        else                           ! need to read in new data
          iyr_sav = iyear

!  --- ...  check to see if the solar constant data file existed

          inquire (file=solar_fname, exist=file_exist)
          if ( .not. file_exist ) then
            print *,' !!! ERROR! Can not find solar constant file!!!'
            stop
          else
            iyr = iyear

            close(NIRADSF)
            open (NIRADSF,file=solar_fname,form='formatted',            &
     &                    status='old')
            rewind NIRADSF

            read (NIRADSF, * ) iyr1,iyr2,icy1,icy2,smean,cline(1:60)
!           read (NIRADSF, 24) iyr1,iyr2,icy1,icy2,smean,cline
! 24        format(4i5,f8.2,a60)

            if ( me == 0 ) then
              print *,'  Updating solar constant with cycle approx'
              print *,'   Opened solar constant data file: ',solar_fname
!check        print *, iyr1, iyr2, icy1, icy2, smean, cline
            endif

!  --- ...  check if there is a upper year limit put on the data table

!           if ( iyear /= kyear ) then
!             icy = icy1 - iyr1 + 1    ! range of the earlest cycle in data table
!             if ( kyear-iyr1 < icy ) then ! need data range at least icy years
                                           ! to perform cycle approximation
!               if ( me == 0 ) then
!                 print *,'  *** the requested year',iyear,' and upper',&
!    &                  'limit',kyear,' do not fit the range of data ', &
!    &                  'table of iyr1, iyr2 =',iyr1,iyr2
!                 print *,'      USE FIXED SOLAR CONSTANT=',con_solr
!               endif
!               solc0 = con_solr
!               isolflg = 10

!             elseif ( kyear < iyr2 ) then

!  --- ...  because the usage limit put on the historical data table,
!           skip those unused data records at first

!               i = iyr2
!               Lab_dowhile0 : do while ( i > kyear )
!                 read (NIRADSF,26) jyr, solc1
! 26              format(i4,f10.4)
!                 read (NIRADSF,*) jyr, solc1
!                 i = i - 1
!               enddo Lab_dowhile0

!               iyr2 = kyear   ! next record will serve the upper limit

!             endif   ! end if_kyear_block
!           endif   ! end if_iyear_block

!  --- ...  checking the cycle range

            if ( iyr < iyr1 ) then
              icy = icy1 - iyr1 + 1    ! range of the earlest cycle in data table
              Lab_dowhile1 : do while ( iyr < iyr1 )
                iyr = iyr + icy
              enddo Lab_dowhile1

              if ( me == 0 ) then
                print *,'   *** Year',iyear,' out of table range!',     &
     &                  iyr1, iyr2
                print *,'       Using the closest-cycle year (',iyr,')'
              endif
            elseif ( iyr > iyr2 ) then
              icy = iyr2 - icy2 + 1    ! range of the latest cycle in data table
              Lab_dowhile2 : do while ( iyr > iyr2 )
                iyr = iyr - icy
              enddo Lab_dowhile2

              if ( me == 0 ) then
                print *,'   *** Year',iyear,' out of table range!',     &
     &                  iyr1, iyr2
                print *,'       Using the closest-cycle year (',iyr,')'
              endif
            endif

!  --- ...  locate the right record for the year of data

            if ( isolflg < 4 ) then        ! use annual mean data tables
              i = iyr2
              Lab_dowhile3 : do while ( i >= iyr1 )
!               read (NIRADSF,26) jyr, solc1
! 26            format(i4,f10.4)
                read (NIRADSF,*) jyr, solc1

                if ( i == iyr .and. iyr == jyr ) then
                  solc0  = smean + solc1

                  if (me == 0) then
                    print *,' CHECK: Solar constant data used for year',&
     &                       iyr, solc1, solc0
                  endif
                  exit Lab_dowhile3
                else
!check            if(me == 0) print *,'  Skip solar const data for yr',i
                  i = i - 1
                endif
              enddo   Lab_dowhile3
            elseif ( isolflg == 4 ) then   ! use monthly mean data tables
              i = iyr2
              Lab_dowhile4 : do while ( i >= iyr1 )
!               read (NIRADSF,26) jyr, smon(:)
! 26            format(i4,12f10.4)
                read (NIRADSF,*) jyr, smon(1:12)

                if ( i == iyr .and. iyr == jyr ) then
                  do nn = 1, 12
                    smon_sav(nn) = smean + smon(nn)
                  enddo
                  solc0  = smean + smon(imon)

                  if (me == 0) then
                    print *,' CHECK: Solar constant data used for year',&
     &                      iyr,' and month',imon
                  endif
                  exit Lab_dowhile4
                else
!check            if(me == 0) print *,'  Skip solar const data for yr',i
                  i = i - 1
                endif
              enddo   Lab_dowhile4
            endif    ! end if_isolflg_block

            close ( NIRADSF )
          endif      ! end if_file_exist_block

        endif    ! end if_iyr_sav_block
      endif   ! end if_lsol_chg_block

!  --- ...  calculate forecast julian day and fraction of julian day

      jd1 = iw3jdn(iyear,imon,iday)

!  --- ...  unlike in normal applications, where day starts from 0 hr,
!           in astronomy applications, day stats from noon.

      if (ihr < 12) then
        jd1 = jd1 - 1
        fjd1= 0.5 + float(ihr)*hrday + float(imin)*minday               &
     &            + float(isec)*secday
      else
        fjd1= float(ihr - 12)*hrday + float(imin)*minday                &
     &            + float(isec)*secday
      endif

      fjd1  = fjd1 + jd1

      jd  = int(fjd1)
      fjd = fjd1 - jd

!> -# Call solar()
      call solar                                                        &
!  ---  inputs:
     &     ( jd, fjd,                                                   &
!  ---  outputs:
     &       r1, dlt, alp                                               &
     &     )

!  --- ...  calculate sun-earth distance adjustment factor appropriate to date
      solcon = solc0 / (r1*r1)

      slag   = sollag
      sdec   = sindec
      cdec   = cosdec

!  --- ...  diagnostic print out

      if (me == 0) then

!> -# Call prtime()
        call prtime                                                     &
!  ---  inputs:
     &     ( jd, fjd, dlt, alp, r1, solcon )
!  ---  outputs: ( none )

      endif

!  --- ...  setting up calculation parameters used by subr coszmn

      nswr  = nint(deltsw / deltim)         ! number of mdl t-step per sw call
      dtswh = deltsw / f3600                ! time length in hours

      if ( deltsw >= f3600 ) then           ! for longer sw call interval
        nn   = max(6, min(12, nint(f3600/deltim) ))   ! num of calc per hour
        nstp = nint(dtswh) * nn + 1                   ! num of calc per sw call
      else                                  ! for shorter sw sw call interval
        nstp = max(2, min(20, nswr)) + 1
!       nn   = nint( float(nstp-1)/dtswh )
      endif

      anginc = pid12 * dtswh / float(nstp-1)          ! solar angle inc during each calc step

      if ( me == 0 ) then
        print *,'   for cosz calculations: nswr,deltim,deltsw,dtswh =', &
     &          nswr,deltim,deltsw,dtswh,'  anginc,nstp =',anginc,nstp
      endif

!     if (me == 0) print*,'in sol_update completed sr solar'
!
      return
!...................................
      end subroutine sol_update
!-----------------------------------
!! @}

!>\ingroup module_radiation_astronomy
!> This subroutine computes radius vector, declination and right
!! ascension of sun, and equation of time.
!!\param[in] jd   julian day
!!\param[in] fjd  fraction of the julian day
!!\param[out] r1  earth-sun radius vector
!!\param[out] dlt declination of sun in radians
!!\param[out] alp right ascension of sun in radians
!>\section solar_gen solar General Algorithm
!! @{
!-----------------------------------
      subroutine solar                                                  &
     &     ( jd, fjd,                                                   &       !  ---  inputs
     &       r1, dlt, alp                                               &       !  ---  outputs
     &     )

!  ===================================================================  !
!                                                                       !
!  solar computes radius vector, declination and right ascension of     !
!  sun, and equation of time.                                           !
!                                                                       !
!  inputs:                                                              !
!    jd       - julian day                                              !
!    fjd      - fraction of the julian day                              !
!                                                                       !
!  outputs:                                                             !
!    r1       - earth-sun radius vector                                 !
!    dlt      - declination of sun in radians                           !
!    alp      - right ascension of sun in radians                       !
!                                                                       !
!  module variables:                                                    !
!    sollag   - equation of time in radians                             !
!    sindec   - sine of declination angle                               !
!    cosdec   - cosine of declination angle                             !
!                                                                       !
!  usage:    call solar                                                 !
!                                                                       !
!  external subroutines called: none                                    !
!                                                                       !
!  ===================================================================  !
!
      implicit none

!  ---  inputs:
      real (kind=kind_phys), intent(in) :: fjd
      integer,               intent(in) :: jd

!  ---  outputs:
      real (kind=kind_phys), intent(out) :: r1, dlt, alp

!  ---  locals:
      real (kind=kind_phys), parameter :: cyear = 365.25   ! days of year
      real (kind=kind_phys), parameter :: ccr   = 1.3e-6   ! iteration limit
      real (kind=kind_phys), parameter :: tpp   = 1.55     ! days between epoch and
                                                           ! perihelion passage of 1900
      real (kind=kind_phys), parameter :: svt6  = 78.035   ! days between perihelion passage
                                                           ! and march equinox of 1900
      integer,               parameter :: jdor  = 2415020  ! jd of epoch which is january
                                                           ! 0, 1900 at 12 hours ut

      real (kind=kind_phys) :: dat, t1, year, tyear, ec, angin, ador,   &
     &       deleqn, sni, tini, er, qq, e1, ep, cd, eq, date, em,       &
     &       cr, w1, tst, sun

      integer               :: jdoe, iter

!===>  ...  begin here

! --- ...  computes time in julian centuries after epoch

      t1 = float(jd - jdor) / 36525.0

! --- ...  computes length of anomalistic and tropical years (minus 365 days)

      year = 0.25964134e0 + 0.304e-5 * t1
      tyear= 0.24219879E0 - 0.614e-5 * t1

! --- ...  computes orbit eccentricity and angle of earth's inclination from t

      ec   = 0.01675104e0 - (0.418e-4 + 0.126e-6 * t1) * t1
      angin= 23.452294e0 - (0.0130125e0 + 0.164e-5 * t1) * t1

      ador = jdor
      jdoe = ador + (svt6 * cyear) / (year - tyear)

! --- ...  deleqn is updated svt6 for current date

      deleqn= float(jdoe - jd) * (year - tyear) / cyear
      year  = year + 365.0
      sni   = sin( angin / degrad )
      tini  = 1.0 / tan( angin / degrad )
      er    = sqrt( (1.0 + ec) / (1.0 - ec) )
      qq    = deleqn * tpi / year

! --- ...  determine true anomaly at equinox

      e1    = 1.0
      cd    = 1.0
      iter  = 0

      lab_do_1 : do while ( cd > ccr )

        ep    = e1 - (e1 - ec*sin(e1) - qq) / (1.0 - ec*cos(e1))
        cd    = abs(e1 - ep)
        e1    = ep
        iter  = iter + 1

        if (iter > 10) then
          write(6,*) ' ITERATION COUNT FOR LOOP 32 =', iter
          write(6,*) ' E, EP, CD =', e1, ep, cd
          exit lab_do_1
        endif

      enddo  lab_do_1

      eq   = 2.0 * atan( er * tan( 0.5*e1 ) )

! --- ...  date is days since last perihelion passage

      dat  = float(jd - jdor) - tpp + fjd
      date = mod(dat, year)

! --- ...  solve orbit equations by newton's method

      em   = tpi * date / year
      e1   = 1.0
      cr   = 1.0
      iter = 0

      lab_do_2 : do while ( cr > ccr )

        ep   = e1 - (e1 - ec*sin(e1) - em) / (1.0 - ec*cos(e1))
        cr   = abs(e1 - ep)
        e1   = ep
        iter = iter + 1

        if (iter > 10) then
          write(6,*) ' ITERATION COUNT FOR LOOP 31 =', iter
          exit lab_do_2
        endif

      enddo  lab_do_2

      w1   = 2.0 * atan( er * tan( 0.5*e1 ) )

      r1   = 1.0 - ec*cos(e1)

      sindec = sni * sin(w1 - eq)
      cosdec = sqrt( 1.0 - sindec*sindec )

      dlt  = asin( sindec )
      alp  = asin( tan(dlt)*tini )

      tst  = cos( w1 - eq )
      if (tst < 0.0) alp = con_pi - alp
      if (alp < 0.0) alp = alp + tpi

      sun  = tpi * (date - deleqn) / year
      if (sun < 0.0) sun = sun + tpi
      sollag = sun - alp - 0.03255e0
!
      return
!...................................
      end subroutine solar
!! @}
!-----------------------------------

!>\ingroup module_radiation_astronomy
!> This subroutine computes mean cos solar zenith angle over SW calling
!! interval.
!!\param xlon       grids' longitudes in radians, work both on
!!                  zonal, 0->2pi and -pi->+pi arrangements
!!\param sinlat     sine of the corresponding latitudes
!!\param coslat     cosine of the corresponding latitudes
!!\param solhr      time after 00z in hours
!!\param IM         num of grids in horizontal dimension
!!\param me         print message control flag
!!\param coszen     average of cosz for daytime only in sw call
!!                  interval
!!\param coszdg     average of cosz over entire sw call interval
!>\section coszmn_gen coszmn General Algorithm
!! @{
!-----------------------------------
      subroutine coszmn                                                 &
     &     ( xlon,sinlat,coslat,solhr, IM, me,                          &     !  ---  inputs
     &       coszen, coszdg                                             &     !  ---  outputs
     &     )

!  ===================================================================  !
!                                                                       !
!  coszmn computes mean cos solar zenith angle over sw calling interval !
!                                                                       !
!  inputs:                                                              !
!    xlon  (IM)    - grids' longitudes in radians, work both on zonal   !
!                    0->2pi and -pi->+pi arrangements                   !
!    sinlat(IM)    - sine of the corresponding latitudes                !
!    coslat(IM)    - cosine of the corresponding latitudes              !
!    solhr         - time after 00z in hours                            !
!    IM            - num of grids in horizontal dimension               !
!    me            - print message control flag                         !
!                                                                       !
!  outputs:                                                             !
!    coszen(IM)    - average of cosz for daytime only in sw call interval
!    coszdg(IM)    - average of cosz over entire sw call interval       !
!                                                                       !
!  module variables:                                                    !
!    sollag        - equation of time                                   !
!    sindec        - sine of the solar declination angle                !
!    cosdec        - cosine of the solar declination angle              !
!    anginc        - solar angle increment per iteration for cosz calc  !
!    nstp          - total number of zenith angle iterations            !
!                                                                       !
!  usage:    call comzmn                                                !
!                                                                       !
!  external subroutines called: none                                    !
!                                                                       !
!  ===================================================================  !
!
      implicit none

!  ---  inputs:
      integer, intent(in) :: IM, me

      real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:),        &
     &       xlon(:), solhr

!  ---  outputs:
      real (kind=kind_phys), intent(out) :: coszen(:), coszdg(:)

!  ---  locals:
      real (kind=kind_phys) :: coszn, cns, ss, cc, solang, rstp

      integer :: istsun(IM), i, it, j, lat

!===>  ...  begin here

      solang = pid12 * (solhr - f12)         ! solar angle at present time
      rstp = 1.0 / float(nstp)

      do i = 1, IM
        coszen(i) = 0.0
        istsun(i) = 0
      enddo

      do it = 1, nstp
        cns = solang + float(it-1)*anginc + sollag

        do i = 1, IM
          ss  = sinlat(i) * sindec
          cc  = coslat(i) * cosdec

          coszn = ss + cc * cos(cns + xlon(i))
          coszen(i) = coszen(i) + max(0.0, coszn)
          if (coszn > czlimt) istsun(i) = istsun(i) + 1
        enddo
      enddo

!  --- ...  compute time averages

      do i = 1, IM
        coszdg(i) = coszen(i) * rstp
        if (istsun(i) > 0) coszen(i) = coszen(i) / istsun(i)
      enddo
!
      return
!...................................
      end subroutine coszmn
!! @}
!-----------------------------------

!>\ingroup module_radiation_astronomy
!> This subroutine prints out forecast date, time, and astronomy
!! quantities.
!!\param[in] jd    forecast julian day
!!\param[in] fjd   forecast fraction of julian day
!!\param[in] dlt   declination angle of sun in radians
!!\param[in] alp   right ascension of sun in radians
!!\param[in] r1    earth-sun radius vector in meter
!!\param[in] solc  solar constant in \f$w/m^2\f$
!>\section prtime_gen prtime General Algorithm
!! @{
!-----------------------------------
      subroutine prtime                                                 &
     &     ( jd, fjd, dlt, alp, r1, solc                                &    !  ---  inputs
     &     )                                                            !  ---  outputs: ( none )

!  ===================================================================  !
!                                                                       !
!  prtime prints out forecast date, time, and astronomy quantities.     !
!                                                                       !
!  inputs:                                                              !
!    jd       - forecast julian day                                     !
!    fjd      - forecast fraction of julian day                         !
!    dlt      - declination angle of sun in radians                     !
!    alp      - right ascension of sun in radians                       !
!    r1       - earth-sun radius vector in meter                        !
!    solc     - solar constant in w/m^2                                 !
!                                                                       !
!  outputs:   ( none )                                                  !
!                                                                       !
!  module variables:                                                    !
!    sollag   - equation of time in radians                             !
!                                                                       !
!  usage:    call prtime                                                !
!                                                                       !
!  external subroutines called: w3fs26                                  !
!                                                                       !
!  ===================================================================  !
!
      implicit none

!  ---  inputs:
      integer, intent(in) :: jd

      real (kind=kind_phys), intent(in) :: fjd, dlt, alp, r1, solc

!  ---  outputs: ( none )

!  ---  locals:
      real (kind=kind_phys), parameter :: sixty  = 60.0

      character(LEN=1),     parameter :: sign   = '-'
      character(LEN=1),     parameter :: sigb   = ' '

      character(LEN=1)     :: dsig
      character(LEN=4)     :: month(12)

      data month / 'JAN.','FEB.','MAR.','APR.','MAY ','JUNE',           &
     &             'JULY','AUG.','SEP.','OCT.','NOV ','DEC.' /

      integer               :: iday, imon, iyear, ihr, ltd, ltm,        &
     &                         ihalp, iyy, jda, mfjd, idaywk, idayyr
      real (kind=kind_phys) :: xmin, dltd, dltm, dlts, halp, ymin,      &
     &                         asec, eqt, eqsec

!===>  ...  begin here

!  --- ...  get forecast hour and minute from fraction of julian day

      if (fjd >= 0.5) then
        jda = jd + 1
        mfjd= nint( fjd*1440.0 )
        ihr = mfjd / 60 - 12
        xmin= float(mfjd) - (ihr + 12)*sixty
      else
        jda = jd
        mfjd= nint( fjd*1440.0 )
        ihr = mfjd / 60 + 12
        xmin= float(mfjd) - (ihr - 12)*sixty
      endif

!  --- ...  get forecast year, month, and day from julian day

      call w3fs26(jda, iyear,imon,iday, idaywk,idayyr)

!  -- ...  compute solar parameters

      dltd = degrad * dlt
      ltd  = dltd
      dltm = sixty * (abs(dltd) - abs(float(ltd)))
      ltm  = dltm
      dlts = sixty * (dltm - float(ltm))

      if ((dltd < 0.0) .and. (ltd == 0.0)) then
        dsig = sign
      else
        dsig = sigb
      endif

      halp = 6.0 * alp / hpi
      ihalp= halp
      ymin = abs(halp - float(ihalp)) * sixty
      iyy  = ymin
      asec = (ymin - float(iyy)) * sixty

      eqt  = 228.55735 * sollag
      eqsec= sixty * eqt

      print 101, iday, month(imon), iyear, ihr, xmin, jd, fjd
 101  format('0 FORECAST DATE',9x,i3,a5,i6,' AT',i3,' HRS',f6.2,' MINS'/&
     &       '  JULIAN DAY',12x,i8,2x,'PLUS',f11.6)

      print 102, r1, halp, ihalp, iyy, asec
 102  format('  RADIUS VECTOR',9x,f10.7/'  RIGHT ASCENSION OF SUN',     &
     &       f12.7,' HRS, OR',i4,' HRS',i4,' MINS',f6.1,' SECS')

      print 103, dltd, dsig, ltd, ltm, dlts, eqt, eqsec, sollag, solc
 103  format('  DECLINATION OF THE SUN',f12.7,' DEGS, OR ',a1,i3,       &
     &       ' DEGS',i4,' MINS',f6.1,' SECS'/'  EQUATION OF TIME',6x,   &
     &       f12.7,' MINS, OR',f10.2,' SECS, OR',f9.6,' RADIANS'/       &
     &       '  SOLAR CONSTANT',8X,F12.7,' (DISTANCE AJUSTED)'//)

!
      return
!...................................
      end subroutine prtime
!! @}
!-----------------------------------

!
!...........................................!
      end module module_radiation_astronomy !
!===========================================!