      SUBROUTINE DEREQ
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 MPRIME,NSUBX,JARRAY,ISUBD
      INTEGER*4 ACNTRL
C
C     SUBROUTINE DEREQ1 IS THE CENTER OF THE FSD PROGRAM. IT SETS
C     UP THE EQUATIONS OF MOTION AND DIRECTS THE CALCULATION OF
C     THE DERIVATIVES OF THE STATE VARIABLES, CALL ROUTINES TO
C     COMPUTE THE CONTROL AND EXTERNAL TORQUES
C
C     IT IS CALL BY  ADMIMP  THE ADAMS-MOULTON FOURTH ORDER
C     PREDICTOR AND CORRECTOR INTEGRATOR
C     DEREQ1 IS ORIGINALLY WRITTEN BY E.A. LAWLOR OF AVCO SYSTEM
C     DIVISION.  MODIFIED BY K. YONG OF COMPUTER SCIENCES CORP.
C     FOR VARIOUS ADDITIONAL CAPABILITIES
C
C
      COMMON/CONDMP/ IDPHLD
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/CRATIO/ RATIO
C
      COMMON/DEBUG2/ IOUT,JOUT,KLUGE
C
      COMMON/DMMNT1/ ZKBM(6),FMAK(10),FMBK(10),ARTETA(3),CMTORK(3),
     .               ITORK,IBENDM,ITENSE,ITNS1
C
      COMMON/GRNTST/ ALFAEG,DELTAG,PHASEG,ALTUDE,OMGY(3),
     *               GACC(3),GLOCAT(3),IGRUND,IALTUD,IGASBR
C
      COMMON/HVCOMP/ YBAR(3),YBARD(3),CIN(3,3),CID,CIND(3)
C
      COMMON/IMAIN1/ IDATE,LSAVE,INOPT,IPLOT,NUMEQS,IPLTPE,IORB,ITAPE
C
      COMMON/INEWR / NKT(10),ICP,ICPS
C
      COMMON/INTTRP/ ITPROT,NUMTIP(10),IRDBUG
C
      COMMON/IPOOL1/ IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10),
     .               LK(10),LLK(10)
C
      COMMON/ITCNTL/ IPULSE,ISPLSE,KPULSE,ITSW,IOTSW
C
      COMMON/ITW   / ITWIST,ITWST1
C
C
      COMMON/MOMENT/ ACNTRL,IVISCS,IATTDE,IMGMTS,IWHEEL,NPULSE
C
      COMMON/NODER / NDER,NOPT
C
      COMMON/OUTFOR/ SUMMTS(3)
C
      COMMON/RATTDE/ DTMXA,PXI,PXO,EIT,REFTIM,TMX1,TMX2,CMX,ISW
C
      COMMON/RMAIN1/ DELTAT,FACTOR,FREQ,TSTOP,DELMIT,
     .               UPBND(150),DNBND(150)
C
      COMMON/RPOOL1/ RHOK(10),TIM1,SA(3,3),FM1(3,3),ZLK(10),OMEG(3),
     .               ZLKP(10),ZLKDP(10),CMAT(3,3),GBAR(3,3),YBCM(3),
     .               ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL2/ PO,SD(3),DAN(3,10),DBN(3,10),CFMT(3,3),DIY1(3),
     .               SD1(3),DT1,P1,AERO,DTO1,YIZK(3),PO1
C
      COMMON/RPOOL9/ RT1(7),RT2(10,9),ALP(7,7),GAM(10,9,7),DEL(10,9,9)
C
      COMMON/RVISCS/ NSUBX(3),YARRAY(3),RADTBE,VISCTY,RADRNG,DENSTY,
     .               JARRAY(3),SSUBY,OMEGL,ISUBD
C
      COMMON/SATPOS/ TLAST,TFRST,XLAST(3),XFRST(3),XDLAST(3),XDFRST(3),
     .               SDLAST(3),SDFRST(3),ADLAST(3),ADFRST(3),XDT
C
      COMMON/TRQOUT/ OUTTRQ(150)
C
      COMMON/VARBLS/ DEPEND(150),DERIV(150)
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
      COMMON/ZSPINR/ DTZMA,PZDT,CMZO,ISPIN3,JSPIN
C
C
      DIMENSION DDEL(9,9),DELINV(10,9,9),ETA(7),ZML(7,7),RT(9)
C
      DIMENSION C(10),DUM(7,9),MT(10),VPRIME(3,2)
C
      DIMENSION OMEGDT(3),RWHEEL(3),XMB(3),MPRIME(3),YDOT(3)
C
      DIMENSION GAME(9,7)
C
      DIMENSION RVEC(28),AMAT(28),AUX(7)
C
      REAL*4 EPS/1.0E-6/
C
C        SPECIAL DEBUGGING OUTPUT
C
      NDER=NDER+1
      IF(NOPT.EQ.1) WRITE(6,302) NDER
  302 FORMAT(15X,' NDEREQ1 = ',I5)
      IF(JOUT.NE.2) GO TO 4
      IOUT=1
      TOUT=DMOD(TIM1,8.64D4)
      IF(TOUT.GT.FREQ) TOUT=DMOD(TOUT,FREQ)
      IF(TOUT.EQ.FREQ.OR.(FREQ-TOUT).LE.DELTAT) IOUT=2
    4 IF(JOUT.EQ.3) IOUT=2
C
C        SETUP FOR CONTROL FORCES,WHEELS,ATTITUDE CONTROL,VISCOUS
C        NUTATION DAMPING,SPIN UP TORQUEING
C
      N=NUMEQS - 4
      CMXO=0.D0
      DO 5 I=1,3
      RWHEEL(I)=0.D0
      XMB(I)=0.D0
      MPRIME(I)=0.D0
      VPRIME(I,1)=0.0D0
      VPRIME(I,2)=0.0D0
      IF(IVISCS.EQ.0) GO TO 5
      LL=N+I
      YARRAY(I)=DEPEND(LL)
    5 CONTINUE
      IF(IVISCS.EQ.1) SSUBY=DEPEND(NUMEQS)
      CMZO1=0.D0
      IF(ISPIN3.NE.0.AND.JSPIN.NE.0) CMZO1=CMZO
C
      DO 15 I=1,7
      DO 14 J=1,7
      ZML(I,J)=0.0D0
   14 CONTINUE
      ETA(I)=0.0D0
   15 CONTINUE
C
      IF(IOUT.EQ.1) GO TO 16
      WRITE(6,7001) ZLK
      WRITE(6,7002) ZLKP
 7001 FORMAT('0',1X,'ZLK(K)  1 ',1P10E12.4)
 7002 FORMAT('0',1X,'ZLKP(K) 1 ',1P10E12.4)
C
   16 CONTINUE
C
C        OBTAIN ORBITAL DATA
C
      CALL SETVAL(2)
C
C        ITIM IS SWITCH FOR CALCULATING - NEEDED AT TIME ZERO ONLY
C
      IF(ITIM.EQ.2) GO TO 20
      CALL COMBNZ
      GO TO 40
C
C        IF LENGTH IS CHANGING AFTER  TIME ZERO COMBNZ IS CALLED AT
C        EACH TIME
C
   20 DO 30 K=1,IK
      IF(ZLKP(K).EQ.0.D0) GO TO 30
      CALL COMBNZ
      GO TO 40
   30 CONTINUE
C
   40 IF(IOUT.EQ.1) GO TO 17
      WRITE(6,7003) ZLK
      WRITE(6,7004) ZLKP
 7003 FORMAT('0',1X,'ZLK(K)  2 ',1P10E12.4)
 7004 FORMAT('0',1X,'ZLKP(K) 2 ',1P10E12.4)
C
   17 CONTINUE
C
      CALL FINDGB
C
      CALL THERME
C
      CALL FNDALP
C
      IF(ITWIST.NE.0.OR.ITPROT.NE.0) CALL DEREQT(DEPEND)
C
      DO 35 I=1,3
      I3=I+3
      DO 35 J=1,3
      J3=J+3
      CIN(I,J)=ALP(I3,J3)
   35 CONTINUE
C
      IF(IOUT.EQ.1) GO TO 41
C
C        DEBUGGING OUTPUT FOR IOUT=2
C                       TEMPORARY WRITE'S
      WRITE(6,7005) ZLK
      WRITE(6,7006) ZLKP
 7005 FORMAT('0',1X,'ZLK(K)  3 ',1P10E12.4)
 7006 FORMAT('0',1X,'ZLKP(K) 3 ',1P10E12.4)
C
      T=DMOD(TIM1,8.64D4)
      WRITE(6,8000)
 8000 FORMAT(15X,'DEBUGGING OUTPUT FROM DEREQ1')
      WRITE(6,8001)
 8001 FORMAT(15X,' SA MATRIX')
      WRITE(6,9000) ((SA(I,J),J=1,3),I=1,3)
 9000 FORMAT(' ',2X,1P9E14.6//)
      WRITE(6,9001) (RT1(I),I=1,7)
 9001 FORMAT(' ',2X,'RT1',7E16.8/)
      WRITE(6,8002)
 8002 FORMAT(15X,' RT2 ARRAY ')
      WRITE(6,9002) ((RT2(I,J),J=1,9),I=1,10)
 9002 FORMAT(9E14.6)
      WRITE(6,8003)
 8003 FORMAT(15X,'DEPEND ARRAY FROM DEREQ1')
      WRITE(6,9002) (DEPEND(I),I=1,150)
      WRITE(6,8004)
 8004 FORMAT(15X,'DERIV ARRAY FROM DEREQ1')
      WRITE(6,9002) (DERIV(I),I=1,150)
      WRITE(6,9003) T,LSAVE,DELTAT
 9003 FORMAT('0',2X,'DEREQ - T=',E20.8,2X,'LLL=',I2,2X,'DELTAT=',E20.8)
      WRITE(6,8006)
 8006 FORMAT(15X,' FM1 ARRAY ')
      WRITE(6,9000) ((FM1(I,J),J=1,3),I=1,3)
C
   41 CONTINUE
      DO 50 I=1,7
      ETA(I)=RT1(I)
      DO 50 J=1,7
   50 ZML(I,J)=ALP(I,J)
C
      MAXD=9
      NALP=6
      IF(IDAMP.EQ.1) NALP=7
C
      DO 42 I=1,28
      RVEC(I)=0.0D0
   42 CONTINUE
C
      NRHS=1
      I1=NALP
      IF(IDPHLD.EQ.0) GO TO 43
      NRHS=NRHS+1
      I1=I1+NALP
      RVEC(I1)=1.0D0
   43 CONTINUE
      IF(IGRUND.EQ.0.OR.IGASBR.EQ.0) GO TO 44
      NRHS=NRHS+2
      I1AX=I1+4
      I2AX=I1AX+NALP+1
      RVEC(I1AX)=1.0D0
      RVEC(I2AX)=1.0D0
   44 CONTINUE
C
      CALL ACTFLT(1,TIM1,ETA)
C
      DO 130 K=1,IK
C
      CON=RHOK(K)*ZLK(K)
C
      NKB=NK(K)
      NTW=NKT(K)
      NSZ=2*NKB+NTW
C
      IF(NSZ.EQ.0) GO TO 130
C
      DO 60 I=1,NSZ
      DO 58 J=1,NSZ
      DDEL(I,J)=DEL(K,I,J)
   58 CONTINUE
      DO 59 J=1,7
      GAME(I,J)=GAM(K,I,J)
   59 CONTINUE
   60 CONTINUE
C
      IF(IOUT.EQ.1) GO TO 62
C
      WRITE(6,6010) ((DDEL(I,J),J=1,9),I=1,NSZ)
 6010 FORMAT(' DELTA         ',1P9E13.6)
      WRITE(6,6011) ((GAME(I,J),J=1,7),I=1,NSZ)
 6011 FORMAT(' GAMMA         ',1P7E13.6)
C
   62 CONTINUE
C
C     INVERSE OF DELTA MATRIX
C
      CALL INVERT(DDEL,NSZ,MAXD,IND,C,MT)
C
C
C
      IF(IOUT.EQ.1) GO TO 64
      WRITE(6,6012) ((DDEL(I,J),J=1,9),I=1,NSZ)
 6012 FORMAT(' DELTA INVERSE ',1P9E13.6)
C
   64 CONTINUE
C
C     STORE DELTA INVERSE
C
      DO 70 I=1,NSZ
      DO 70 J=1,NSZ
      DELINV(K,I,J)=DDEL(I,J)
   70 CONTINUE
C
      DO 80 I=1,NALP
      DO 80 J=1,NSZ
      DUM(I,J)=0.D0
      DO 80 L=1,NSZ
   80 DUM(I,J)=DUM(I,J) + GAM(K,L,I)*DDEL(L,J)
C
C
      DO 100 I=1,NALP
      DO 100 J=1,NALP
      SUM1=0.D0
      DO 90 L=1,NSZ
   90 SUM1=SUM1 + DUM(I,L)*GAM(K,L,J)
  100 ZML(I,J)=ZML(I,J) - SUM1*CON
C
C
      DO 120 I=1,NALP
      SUM2=0.D0
      DO 110 L=1,NSZ
  110 SUM2=SUM2 + DUM(I,L)*RT2(K,L)
  120 ETA(I)=ETA(I) - SUM2*CON
  130 CONTINUE
C
C
      IF(KPULSE.NE.IPULSE) CALL PULSER(ETA)
C
C     CALL GRDFCE TO OBTAIN THE GRAVITATIONAL FORCE ON THE GROUND
C
      IF(IGRUND.EQ.1) CALL GRDFCE(ETA)
C
C
      IF(IOUT.EQ.1)GO TO 131
      WRITE(6,7007) ZLK
      WRITE(6,7008) ZLKP
 7007 FORMAT('0',1X,'ZLK(K)  4 ',1P10E12.4)
 7008 FORMAT('0',1X,'ZLKP(K) 4 ',1P10E12.4)
C
      WRITE(6,9500) (ETA(I),I=1,7)
      WRITE(6,9501)
      WRITE(6,9502) ((ZML(I,J),J=1,7),I=1,7)
 9500 FORMAT('0','ETA=',7E17.8)
 9501 FORMAT('0','ZML')
 9502 FORMAT(' ',5X,7E17.8)
      WRITE(6,8005)
 8005 FORMAT(15X,' END OF DEBUGGING OUTPUT FROM DEREQ1')
C
  131 CONTINUE
C
C
C                       TEST FOR ADDING MOMENTUM WHEELS
C
      IF(IWHEEL.EQ.1) CALL WHEELS(1,RWHEEL)
C
      CALL WHREAC(ETA)
      CALL AWREAC(ETA)
C
      OUTTRQ(1)=RWHEEL(1)
      OUTTRQ(2)=RWHEEL(2)
      OUTTRQ(3)=RWHEEL(3)
C
C                       TEST FOR MAGNETIC MOMENTS
C
      IF(IMGMTS.NE.0) CALL MAGNTS(XMB,SA)
C
C                       TEST FOR ATTITUDE CONTROL
C
      IF(NPULSE.EQ.0) GO TO 140
      IF(IATTDE.EQ.1) CALL XACM(CMXO)
C
C
C                       TEST FOR VISCOUS DAMPER
C
  140 CONTINUE
      IF(IVISCS.EQ.1) CALL VISCUS(1,ZML,OMEG,OMEGDT,SYDOT,YDOT,MPRIME)
C
      CALL VISCS2(1,ZML,OMEG,OMEGDT,DEPEND,DERIV,VPRIME)
C
C
C                       ADD ATTITUDE CONTROL MOMENT TO X-AXIS(ETA(4))
C
      ETA(4)=ETA(4) + CMXO
      ETA(6)=ETA(6) + CMZO1
C
C                       ADD OTHER MOMENTS TO ETA
C
      ETA(4)=ETA(4) + VPRIME(1,1) + VPRIME(1,2)
      ETA(5)=ETA(5) + VPRIME(2,1) + VPRIME(2,2)
      ETA(6)=ETA(6) + VPRIME(3,1) + VPRIME(3,2)
C
      ETA(4)=ETA(4) + RWHEEL(1) + XMB(1) + MPRIME(1)
      ETA(5)=ETA(5) + RWHEEL(2) + XMB(2) + MPRIME(2)
      ETA(6)=ETA(6) + RWHEEL(3) + XMB(3) + MPRIME(3)
C
C                       SAVE THE TOTAL MOMENTS FOR OUTPUT
C
      SUMMTS(1)=SUMMTS(1)+XMB(1)+CMXO
      SUMMTS(2)=SUMMTS(2)+XMB(2)
      SUMMTS(3)=SUMMTS(3)+XMB(3)+CMZO1
C
      DO 150 I=1,NALP
      IF(ZML(I,I).EQ.0.D0) GO TO 150
      DO 150 J=1,NALP
      IF(DABS(ZML(I,J)/ZML(I,I)).LT.RATIO) ZML(I,J)=0.D0
  150 CONTINUE
C
      IF(ITORK.EQ.0) GO TO 759
      ETA(4)=ETA(4)+CMTORK(1)
      ETA(5)=ETA(5)+CMTORK(2)
      ETA(6)=ETA(6)+CMTORK(3)
      SUMMTS(1)=SUMMTS(1)+CMTORK(1)
      SUMMTS(2)=SUMMTS(2)+CMTORK(2)
      SUMMTS(3)=SUMMTS(3)+CMTORK(3)
  759 CONTINUE
C
      CALL SECBD2(1,ZML,ETA,NALP)
C
      CALL PCSNSR
C
      CALL DCSNSR
C
      CALL SACSNR
C
      CALL GIMBL2(1,ZML,ETA,NALP)
C
      CALL GMBLD2(1,ZML,ETA)
C
      CALL SAGIM2(1,ZML,ETA,NALP)
C
C
      K=0
      DO 152 I=1,NALP
      DO 151 J=1,I
      K=K+1
      AMAT(K)=ZML(J,I)
  151 CONTINUE
      RVEC(I)=ETA(I)
  152 CONTINUE
C
C
      CALL DGELS(RVEC,AMAT,NALP,NRHS,EPS,IER,AUX)
C
      IF(IER.GE.0) GO TO 153
      WRITE(6,8010) IER
 8010 FORMAT('0 ERROR RETURN FROM DGELS. IER=',I4)
      CALL EXIT
C
  153 CONTINUE
      IF(NRHS.LT.3) GO TO 156
      I1=I1AX
      I2=NALP+I1
      C11=RVEC(I1)
      C21=RVEC(I1+1)
      C12=RVEC(I2)
      C22=RVEC(I2+1)
      R1=RVEC(4)
      R2=RVEC(5)
      DEN=C11*C22-C12*C21
      IF(DEN.EQ.0.0D0) GO TO 155
      GIM1=(C12*R2-C22*R1)/DEN
      GIM2=(C21*R1-C11*R2)/DEN
      DO 154 I=1,NALP
      I1=I1AX-4+I
      I2=NALP+I1
      RVEC(I)=RVEC(I)+RVEC(I1)*GIM1+RVEC(I2)*GIM2
  154 CONTINUE
  155 CONTINUE
      IF(RVEC(4).NE.0.0D0) RVEC(4)=0.0D0
      IF(RVEC(5).NE.0.0D0) RVEC(5)=0.0D0
  156 CONTINUE
C
      IF(IDPHLD.EQ.0) GO TO 702
      IDM=NALP+NALP
      DC=-RVEC(NALP)/RVEC(IDM)
      DO 701 I=1,NALP
      I1=NALP+I
      RVEC(I)=RVEC(I)+DC*RVEC(I1)
  701 CONTINUE
  702 CONTINUE
C
      DO 157 I=1,NALP
      ETA(I)=RVEC(I)
  157 CONTINUE
C
      ARTETA(1)=ETA(1)
      ARTETA(2)=ETA(2)
      ARTETA(3)=ETA(3)
C
C
       DERIV(7)=ETA(4)
       DERIV(8)=ETA(5)
       DERIV(9)=ETA(6)
C
      OMEGDT(1)=ETA(4)
      OMEGDT(2)=ETA(5)
      OMEGDT(3)=ETA(6)
C
      CALL SECBD2(2,ZML,ETA,NALP)
C
      CALL GIMBL2(2,ZML,ETA,NALP)
C
      CALL GMBLD2(2,ZML,ETA)
C
      CALL SAGIM2(2,ZML,ETA,NALP)
C
      IF(IVISCS.EQ.1) CALL VISCUS(2,ZML,OMEG,OMEGDT,SYDOT,YDOT,MPRIME)
C
      CALL VISCS2(2,ZML,OMEG,OMEGDT,DEPEND,DERIV,VPRIME)
C
      IF(IVISCS.EQ.0) GO TO 170
C
      N=NUMEQS - 4
      DO 160 I=1,3
      LL=N+I
  160  DERIV(LL)=YDOT(I)
       DERIV(NUMEQS)=SYDOT
  170 IF(IDAMP.EQ.0) GO TO 180
       DERIV(10)=DEPEND(11)
       DERIV(11)=ETA(7)
  180 CONTINUE
C
C     LOAD QDERIV ARRAY FOR FLEXIBLE ELEMENTS
C
      IA=IAB-1
      IB=IBB-1
      IC=ICP-1
C
      DO 240 K=1,IK
C
      NKB=NK(K)
      NTW=NKT(K)
C
      NSZ=2*NKB+NTW
C
      IF(NSZ.EQ.0) GO TO 240
C
      DO 220 I=1,NSZ
C
      SUM=0.D0
C
      DO 190 J=1,NSZ
  190 SUM=SUM + DELINV(K,I,J)*RT2(K,J)
C
      SUM2=0.D0
C
      DO 210 L=1,NALP
      SUM1=0.D0
C
      DO 200 J=1,NSZ
  200 SUM1=SUM1 + DELINV(K,I,J)*GAM(K,J,L)
C
  210 SUM2=SUM2 + SUM1*ETA(L)
C
  220 RT(I)=SUM - SUM2
C
C
      NKB2=2*NKB
C
      IF(NKB.EQ.0) GO TO 225
      DO 222 I=1,NKB
      I1=IA+I
      I2=I1+NKB
      I3=IB+I
      I4=I3+NKB
C
       DERIV(I1)=DEPEND(I2)
       DERIV(I2)=RT(I)
       DERIV(I3)=DEPEND(I4)
       DERIV(I4)=RT(I+NKB)
C
  222 CONTINUE
C
      IA=IA+NKB2
      IB=IB+NKB2
C
  225 CONTINUE
C
      IF(NTW.EQ.0) GO TO 240
C
      DO 230 I=1,NTW
C
      I1=IC+I
      I2=I1+NTW
C
       DERIV(I1)=DEPEND(I2)
       DERIV(I2)=RT(I+NKB2)
C
  230 CONTINUE
C
      IC=IC+2*NTW
C
  240 CONTINUE
C
      CALL ACTFLT(2,TIM1,ETA)
C
C
      IF(IOUT.EQ.1) GO TO 260
      WRITE(6,7009) ZLK
      WRITE(6,7010) ZLKP
 7009 FORMAT('0',1X,'ZLK(K)  5 ',1P10E12.4)
 7010 FORMAT('0',1X,'ZLKP(K) 5 ',1P10E12.4)
C
      WRITE(6,8000)
      WRITE(6,9002) DERIV
      WRITE(6,9002) P1,XMB,MPRIME
  260 CONTINUE
C
      RETURN
      END


!> ----------------------------------------------------------------------------
!!  Main time stepping module.
!!  Calculates a stable time step (dt) and loops over physics calls
!!  Also updates boundaries every time step.
!!
!!  @author
!!  Ethan Gutmann (gutmann@ucar.edu)
!!
!! ----------------------------------------------------------------------------
module time_step
    use data_structures             ! *_type  types and kCONSTANTS
    use icar_constants,             only : Rd
    use microphysics,               only : mp
    use advection,                  only : advect
    use mod_atm_utilities,          only : exner_function
    use convection,                 only : convect
    use land_surface,               only : lsm
    use planetary_boundary_layer,   only : pbl
    use radiation,                  only : rad

    use domain_interface,           only : domain_t
    use options_interface,          only : options_t
    use debug_module,               only : domain_check
    use string,                     only : str

    implicit none
    private
    public :: step

    !  temporary variables used to update the w_real state. This should move to mod_atm_utilities
    real, allocatable :: lastw(:,:)
    real, allocatable :: currw(:,:)
    real, allocatable :: uw(:,:)
    real, allocatable :: vw(:,:)

contains

    !>------------------------------------------------------------
    !! Update model diagnostic fields
    !!
    !! Calculates most model diagnostic fields such as Psfc, 10m height winds and ustar
    !!
    !! @param domain    Model domain data structure to be updated
    !! @param options   Model options (not used at present)
    !!
    !!------------------------------------------------------------
    subroutine diagnostic_update(domain, options)
        implicit none
        type(domain_t),  intent(inout)   :: domain
        type(options_t), intent(in)      :: options
        integer :: z

        logical :: use_delta_terrain

        associate(ims => domain%ims, ime => domain%ime,                         &
                  jms => domain%jms, jme => domain%jme,                         &
                  kms => domain%kms, kme => domain%kme,                         &
                  exner                 => domain%exner%data_3d,                &
                  pressure              => domain%pressure%data_3d,             &
                  pressure_i            => domain%pressure_interface%data_3d,   &
                  dz_interface          => domain%dz_interface%data_3d,         &
                  psfc                  => domain%surface_pressure%data_2d,     &
                  density               => domain%density%data_3d,              &
                  temperature           => domain%temperature%data_3d,          &
                  u                     => domain%u%data_3d,                    &
                  v                     => domain%v%data_3d,                    &
                  w                     => domain%w%data_3d,                    &
                  w_real                => domain%w_real%data_3d,               &
                  u_mass                => domain%u_mass%data_3d,               &
                  v_mass                => domain%v_mass%data_3d,               &
                  potential_temperature => domain%potential_temperature%data_3d )

        exner = exner_function(pressure)

        ! domain%p_inter=domain%p
        ! call update_pressure(domain%p_inter, domain%z, domain%z_inter, domain%t)
        pressure_i(:,kms+1:kme, :) = (pressure(:,kms:kme-1, :) + pressure(:,kms+1:kme, :)) / 2
        pressure_i(:, kms, :) = pressure(:, kms, :) + (pressure(:, kms, :) - pressure(:, kms+1, :)) / 2
        ! this isn't correct, we should be using update_pressure or similar to solve this
        ! domain%ptop = 2*domain%p(:,nz,:) - domain%p(:,nz-1,:)
        if (associated(domain%surface_pressure%data_2d)) then
            psfc = pressure_i(:, kms, :)
        endif

        temperature = potential_temperature * exner

        if (associated(domain%density%data_3d)) then
            density =  pressure / &
                        (Rd * temperature) ! kg/m^3
        endif
        if (associated(domain%u_mass%data_3d)) then
            u_mass = (u(ims+1:ime+1,:,:) + u(ims:ime,:,:)) / 2
        endif
        if (associated(domain%v_mass%data_3d)) then
            v_mass = (v(:,:,jms+1:jme+1) + v(:,:,jms:jme)) / 2
        endif

    ! NOTE: all code below is not implemented in ICAR 2.0 yet
    ! it is left as a reminder of what needs to be done, and example when the time comes
    !
    !     ! update mut
    !
    !     domain%p_inter=domain%p
    !     call update_pressure(domain%p_inter, domain%z, domain%z_inter, domain%t)
    !     domain%psfc = domain%p_inter(:,1,:)
    !     ! technically this isn't correct, we should be using update_pressure or similar to solve this
    !     domain%ptop = 2*domain%p(:,nz,:) - domain%p(:,nz-1,:)
    !
    !     ! dry mass in the gridcell is equivalent to the difference in pressure from top to bottom
    !     domain%mut(:,1:nz-1,:) = domain%p_inter(:,1:nz-1,:) - domain%p_inter(:,2:nz,:)
    !     domain%mut(:,nz,:) = domain%p_inter(:,nz,:) - domain%ptop
    !
        if (.not.allocated(lastw)) then
            allocate( lastw( ims+1:ime-1, jms+1:jme-1))
            allocate( currw( ims+1:ime-1, jms+1:jme-1))
            allocate(    uw( ims+1:ime,   jms+1:jme-1))
            allocate(    vw( ims+1:ime-1, jms+1:jme  ))
        endif

        ! temporary constant
        if (associated(domain%roughness_z0%data_2d)) then
            ! use log-law of the wall to convert from first model level to surface
            currw = karman / log((domain%z%data_3d(ims+1:ime-1,kms,jms+1:jme-1) - domain%terrain%data_2d(ims+1:ime-1,jms+1:jme-1)) / domain%roughness_z0%data_2d(ims+1:ime-1,jms+1:jme-1))
            ! use log-law of the wall to convert from surface to 10m height
            lastw = log(10.0 / domain%roughness_z0%data_2d(ims+1:ime-1,jms+1:jme-1)) / karman
        endif

        if (associated(domain%u_10m%data_2d)) then
            domain%ustar        (ims+1:ime-1,jms+1:jme-1) = u_mass      (ims+1:ime-1,kms,jms+1:jme-1) * currw
            domain%u_10m%data_2d(ims+1:ime-1,jms+1:jme-1) = domain%ustar(ims+1:ime-1,jms+1:jme-1)     * lastw
            domain%ustar        (ims+1:ime-1,jms+1:jme-1) = v_mass      (ims+1:ime-1,kms,jms+1:jme-1) * currw
            domain%v_10m%data_2d(ims+1:ime-1,jms+1:jme-1) = domain%ustar(ims+1:ime-1,jms+1:jme-1)     * lastw
        endif

        if (allocated(domain%ustar)) then
            ! now calculate master ustar based on U and V combined in quadrature
            domain%ustar(ims+1:ime-1,jms+1:jme-1) = sqrt(u_mass(ims+1:ime-1,kms,jms+1:jme-1)**2 + v_mass(ims+1:ime-1,kms,jms+1:jme-1)**2) * currw
        endif

        ! finally, calculate the real vertical motions (including U*dzdx + V*dzdy)
        lastw = 0
        do z = kms, kme

            ! ! if(options%parameters%use_terrain_difference) then
            !                 ! compute the U * dz/dx component of vertical motion
            !     uw    = u(ims+1:ime,   z, jms+1:jme-1) * domain%delta_dzdx(:,z,jms+1:jme-1)
            !     ! compute the V * dz/dy component of vertical motion
            !     vw    = v(ims+1:ime-1, z, jms+1:jme  ) * domain%delta_dzdy(ims+1:ime-1,z,:)
            ! else
                ! compute the U * dz/dx component of vertical motion
                uw    = u(ims+1:ime,   z, jms+1:jme-1) * domain%dzdx(ims+1:ime,z,jms+1:jme-1)
                ! compute the V * dz/dy component of vertical motion
                vw    = v(ims+1:ime-1, z, jms+1:jme  ) * domain%dzdy(ims+1:ime-1,z,jms+1:jme)
            ! endif
            ! ! convert the W grid relative motion to m/s
            ! currw = w(ims+1:ime-1, z, jms+1:jme-1) * dz_interface(ims+1:ime-1, z, jms+1:jme-1) / domain%dx

            ! the W grid relative motion
            currw = w(ims+1:ime-1, z, jms+1:jme-1)

            ! if (options%physics%convection>0) then
            !     currw = currw + domain%w_cu(2:nx-1,z,2:ny-1) * domain%dz_inter(2:nx-1,z,2:ny-1) / domain%dx
            ! endif

            ! compute the real vertical velocity of air by combining the different components onto the mass grid
            ! includes vertical interpolation between w_z-1/2 and w_z+1/2
            w_real(ims+1:ime-1, z, jms+1:jme-1) = (uw(ims+1:ime-1,:) + uw(ims+2:ime,:))*0.5 &
                                                 +(vw(:,jms+1:jme-1) + vw(:,jms+2:jme))*0.5 &
                                                 +domain%jacobian(ims+1:ime-1,z,jms+1:jme-1)*(lastw + currw) * 0.5
            lastw = currw ! could avoid this memcopy cost using pointers or a single manual loop unroll
        end do

        end associate

    end subroutine diagnostic_update

    !>------------------------------------------------------------
    !!  Calculate the maximum stable time step given some CFL criteria
    !!
    !!  For each grid cell, find the mean of the wind speeds from each
    !!  direction * sqrt(3) for the 3D advection CFL limited time step
    !!  Also find the maximum wind speed anywhere in the domain to check
    !!  against a 1D advection limit.
    !!
    !! @param dx  [ scalar ]        horizontal grid cell width  [m]
    !! @param u   [nx+1 x nz x ny]  east west wind speeds       [m/s]
    !! @param v   [nx x nz x ny+1]  North South wind speed      [m/s]
    !! @param w   [nx x nz x ny]    vertical wind speed         [m/s]
    !! @param CFL [ scalar ]        CFL limit to use (e.g. 1.0)
    !! @return dt [ scalar ]        Maximum stable time step    [s]
    !!
    !!------------------------------------------------------------
    function compute_dt(dx, u, v, w, rho, dz, CFL, cfl_strictness, use_density) result(dt)
        real,       intent(in)                   :: dx
        real,       intent(in), dimension(:,:,:) :: u, v, w, rho
        real,       intent(in), dimension(:)     :: dz
        real,       intent(in)                   :: CFL
        integer,    intent(in)                   :: cfl_strictness
        logical,    intent(in)                   :: use_density
        ! output value
        real :: dt
        ! locals
        real :: three_d_cfl = 0.577350269 ! = sqrt(3)/3
        integer :: i, j, k, nx, nz, ny, zoffset
        real :: maxwind3d, maxwind1d, current_wind, sqrt3

        sqrt3 = sqrt(3.0) * 1.001 ! with a safety factor

        maxwind1d = 0
        maxwind3d = 0

        nx = size(w,1)
        nz = size(w,2)
        ny = size(w,3)

        if (cfl_strictness==1) then
            ! to ensure we are stable for 1D advection:
            if (use_density) then
                !maxwind1d = max( maxval(abs(u(2:,:,:) / (rho*dz*dx) )), maxval(abs(v(:,:,2:) / (rho*dz*dx))) )
                !maxwind1d = max( maxwind1d, maxval(abs(w/(rho*dz*dx))) )
            else
                maxwind1d = max( maxval(abs(u)), maxval(abs(v)))
                maxwind1d = max( maxwind1d, maxval(abs(w)))
            endif

            maxwind3d = maxwind1d * sqrt3
        else if (cfl_strictness==5) then

            if (use_density) then
                !maxwind1d = maxval(abs(u(2:,:,:) / (rho*dz*dx) )) &
                !          + maxval(abs(v(:,:,2:) / (rho*dz*dx) )) &
                !          + maxval(abs(w(:,:, :) / (rho*dz*dx) ))
            else
                maxwind3d = maxval(abs(u)) + maxval(abs(v)) + maxval(abs(w))
            endif

        else
            ! to ensure we are stable for 3D advection we'll use the average "max" wind speed
            ! but that average has to be divided by sqrt(3) for stability in 3 dimensional advection
            do j=1,ny
                do k=1,nz
                    if (k==1) then
                        zoffset = 0
                    else
                        zoffset = -1
                    endif

                    do i=1,nx
                        ! just compute the sum of the wind speeds, but take the max over the two
                        ! faces of the grid cell (e.g. east and west sides)
                        ! this will be divided by 3 later by three_d_cfl
                        if (use_density) then
                            !current_wind = (max(abs(u(i,k,j)), abs(u(i+1,k,j))) &
                            !              + max(abs(v(i,k,j)), abs(v(i,k,j+1))) &
                            !              + max(abs(w(i,k,j)), abs(w(i,k+zoffset,j))) ) &
                            !              / (rho(i,k,j) * dz(i,k,j) * dx)
                        else
                            current_wind = max(abs(u(i,k,j)), abs(u(i+1,k,j))) / dx &
                                          +max(abs(v(i,k,j)), abs(v(i,k,j+1))) / dx &
                                          +max(abs(w(i,k,j)), abs(w(i,k+zoffset,j))) / dz(k)
                        endif
                        maxwind3d = max(maxwind3d, current_wind)
                    ENDDO
                ENDDO
            ENDDO

            if (cfl_strictness==2) then
                ! effectively divides by 3 to take the mean and multiplies by the sqrt(3) for the 3D advection limit
                maxwind3d = maxwind3d * three_d_cfl

                ! to ensure we are stable for 1D advection:
                if (use_density) then
                    !maxwind1d = max( maxval(abs(u(2:,:,:) / (rho*dz*dx) )), maxval(abs(v(:,:,2:) / (rho*dz*dx))) )
                    !maxwind1d = max( maxwind1d, maxval(abs(w/(rho*dz*dx))) )
                else
                    maxwind1d = max( maxval(abs(u)), maxval(abs(v)))
                    maxwind1d = max( maxwind1d, maxval(abs(w)))
                endif
                ! also insure stability for 1D advection
                maxwind3d = max(maxwind1d,maxwind3d)

            ! else if (cfl_strictness==3) then
            !   leave maxwind3d as the sum of the max winds
            ! This should be the default, does it need to be multiplied by sqrt(3)?
            elseif (cfl_strictness==4) then
                maxwind3d = maxwind3d * sqrt3
            endif

        endif

        !TESTING: Do we need to multiply maxwind3d by sqrt3 as the comment above suggests?
        ! maxwind3d = maxwind3d * sqrt3

        dt = CFL / maxwind3d

        ! If we have too small a time step throw an error
        ! something is probably wrong in the physics or input data
        if (dt<1e-1) then
            write(*,*) "dt   = ", dt
            write(*,*) "Umax = ", maxval(abs(u))
            write(*,*) "Vmax = ", maxval(abs(v))
            write(*,*) "Wmax = ", maxval(abs(w))
            stop "ERROR time step too small"
        endif

    end function compute_dt

    !>------------------------------------------------------------
    !!  Prints progress to the terminal if requested
    !!
    !! @param current_time  the current state of the model time
    !! @param end_time      the end of the current full time step (when step will return)
    !! @param time_step     length of full time step to be integrated by step
    !! @param dt            numerical timestep to print for information
    !!
    !!------------------------------------------------------------
    subroutine print_progress(current_time, end_time, time_step, dt, last_time)
        implicit none
        type(Time_type),    intent(in)    :: current_time,    end_time
        type(time_delta_t), intent(in)    :: time_step,       dt
        real,               intent(inout) :: last_time

        type(time_delta_t) :: progress_dt
        real :: time_percent

        ! first compute the current time until reaching the end
        progress_dt  = (end_time - current_time)

        ! convert that to a percentage of the total time required
        time_percent = 100 - progress_dt%seconds() / time_step%seconds()  * 100

        ! finally if it has been at least 5% of the time since the last time we printed output, print output
        if (time_percent > (last_time + 5.0)) then
            last_time = last_time + 5.0
            ! this used to just use the nice $ (or advance="NO") trick, but at least with some mpi implementations, it buffers this output until it crashes
            write(*,"(A,f5.1,A,A)") char(13), max(0.0, time_percent)," %  dt=",trim(dt%as_string())
        endif

    end subroutine print_progress

    !>------------------------------------------------------------
    !! Update the numerical timestep to use
    !!
    !! @param dt            numerical timestep to use
    !! @param options       set options for how to update the time step
    !! @param domain        the full domain structure (need winds to compute dt)
    !! @param end_time      the end of the current full time step (when step will return)
    !!
    !!------------------------------------------------------------
    subroutine update_dt(dt, options, domain, end_time)
        implicit none
        type(time_delta_t), intent(inout) :: dt
        type(options_t),    intent(in)    :: options
        type(domain_t),     intent(in)    :: domain
        type(Time_type),    intent(in)    :: end_time

        double precision :: seconds

        ! compute internal timestep dt to maintain stability
        ! courant condition for 3D advection. Note that w is normalized by dx/dz

        ! Note this needs to be performed when advect_density is enabled
        ! if (options%parameters%advect_density) then
            ! call dt%set(seconds=compute_dt(domain%dx, domain%ur, domain%vr, domain%wr, domain%rho, domain%dz_inter,&
            !                 options%parameters%cfl_reduction_factor, cfl_strictness=options%parameters%cfl_strictness,                   &
            !                 use_density=.True.))

        ! else
        ! compute the dt to meet the CFL criteria specified given dx, u, v, w, dz
        associate(dx         => domain%dx,                              &
                  u          => domain%u%data_3d,                       &
                  v          => domain%v%data_3d,                       &
                  w          => domain%w%data_3d,                       &
                  density    => domain%density%data_3d,                 &
                  dz         => options%parameters%dz_levels,           &
                  reduction  => options%parameters%cfl_reduction_factor,&
                  strictness => options%parameters%cfl_strictness       &
            )

            seconds = compute_dt(dx, u, v, w, density, dz, reduction, &
                                 cfl_strictness=strictness, use_density=.false.)

        end associate
        ! endif

        ! perform a reduction across all images to find the minimum time step required
#ifndef __INTEL_COMPILER
        call co_min(seconds)
#endif
#ifdef __INTEL_COMPILER
        seconds = domain%dx / 100
#endif

        ! set an upper bound on dt to keep microphysics and convection stable (?)
        ! store this back in the dt time_delta data structure
        call dt%set(seconds=min(seconds,120.0D0))

    end subroutine update_dt

    !>------------------------------------------------------------
    !!  Step forward one IO time step.
    !!
    !!  Calculated the internal model time step to satisfy the CFL criteria,
    !!  then updates all forcing update increments for that dt and loops through
    !!  time calling physics modules.
    !!  Also checks to see if it is time to write a model output file.
    !!
    !! @param domain    domain data structure containing model state
    !! @param options   model options structure
    !! @param bc        model boundary conditions data structure
    !! @param next_output   Next time to write an output file (in "model_time")
    !!
    !!------------------------------------------------------------
    subroutine step(domain, end_time, options)
        implicit none
        type(domain_t),     intent(inout)   :: domain
        type(Time_type),    intent(in)      :: end_time
        type(options_t),    intent(in)      :: options

        real :: last_print_time
        type(time_delta_t) :: dt, time_step_size
        integer :: ims, jms, kms
        integer :: test_x, test_y, test_z, test_image

        test_x = 87
        test_z = 3
        test_y = 198
        test_image = 33

        ims = domain%grid%ims
        jms = domain%grid%jms
        kms = domain%grid%kms

        last_print_time = 0.0
        time_step_size = end_time - domain%model_time

        ! now just loop over internal timesteps computing all physics in order (operator splitting...)
        do while (domain%model_time < end_time)

            call update_dt(dt, options, domain, end_time)

            ! Make sure we don't over step the forcing or output period
            if ((domain%model_time + dt) > end_time) then
                dt = end_time - domain%model_time
            endif

            ! ensure internal model consistency
            call diagnostic_update(domain, options)

            ! if an interactive run was requested than print status updates everytime at least 5% of the progress has been made
            if (options%parameters%interactive .and. (this_image()==1)) then
                call print_progress(domain%model_time, end_time, time_step_size, dt, last_print_time)
            endif

            ! this if is to avoid round off errors causing an additional physics call that won't really do anything
            if (dt%seconds() > 1e-3) then

                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" init", fix=.True.)

                ! first process the halo section of the domain (currently hard coded at 1 should come from domain?)
                call rad(domain, options, real(dt%seconds()))
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" rad(domain", fix=.True.)

                call lsm(domain, options, real(dt%seconds()))!, halo=1)
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" lsm")

                call pbl(domain, options, real(dt%seconds()))!, halo=1)
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" pbl")

                call convect(domain, options, real(dt%seconds()))!, halo=1)
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" convect")

                call mp(domain, options, real(dt%seconds()), halo=1)
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" mp_halo", fix=.True.)

                call domain%halo_send()
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" domain%halo_send", fix=.True.)

                ! call rad(domain, options, real(dt%seconds()), subset=1)
                ! call lsm(domain, options, real(dt%seconds()))!, subset=1)
                ! call pbl(domain, options, real(dt%seconds()))!, subset=1)
                ! call convect(domain, options, real(dt%seconds()), subset=1)

                call mp(domain, options, real(dt%seconds()), subset=1)
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" mp(domain", fix=.True.)

                call domain%halo_retrieve()
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" domain%halo_retrieve", fix=.True.)

                call advect(domain, options, real(dt%seconds()))
                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" advect(domain", fix=.True.)

                ! ! apply/update boundary conditions including internal wind and pressure changes.
                call domain%apply_forcing(dt)

                !If we are in the last 2 updates of a time step and a variable drops below 0, we have probably over-shot a value of 0. Force back to 0
                if ((end_time%seconds() - domain%model_time%seconds()) < (dt%seconds()*2)) then
                    call domain%enforce_limits()
                endif

                if (options%parameters%debug) call domain_check(domain, "img: "//trim(str(this_image()))//" domain%apply_forcing", fix=.True.)

            endif

            ! step model_time forward
            domain%model_time = domain%model_time + dt

        enddo

    end subroutine step
end module time_step


!-------------------------------------------------------------------------------
!> module ATMOSPHERE / Physics Cloud Microphysics
!!
!! @par Description
!!          Cloud Microphysics wrapper
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2013-12-06 (S.Nishizawa) [new]
!!
!<
!-------------------------------------------------------------------------------
module mod_atmos_phy_mp_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_tracer
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: ATMOS_PHY_MP_driver_setup
  public :: ATMOS_PHY_MP_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
!  real(RP), private, allocatable :: DENS_t(:,:,:)
!  real(RP), private, allocatable :: MOMZ_t(:,:,:)
!  real(RP), private, allocatable :: MOMX_t(:,:,:)
!  real(RP), private, allocatable :: MOMY_t(:,:,:)
!  real(RP), private, allocatable :: RHOT_t(:,:,:)
!  real(RP), private, allocatable :: QTRC_t(:,:,:,:)
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup Cloud Microphysics
  !-----------------------------------------------------------------------------
  subroutine ATMOS_PHY_MP_driver_setup( MP_TYPE )
    use scale_process, only: &
       PRC_MPIstop
    use scale_atmos_phy_mp, only: &
       ATMOS_PHY_MP_setup
    use mod_atmos_vars, only: &
       DENS, &
       RHOT, &
       QTRC
    implicit none

    character(len=H_SHORT), intent(in) :: MP_TYPE
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '+++ Module[Cloud Microphisics]/Categ[ATMOS]'

!    allocate( DENS_t(KA,IA,JA) )
!    allocate( MOMZ_t(KA,IA,JA) )
!    allocate( MOMX_t(KA,IA,JA) )
!    allocate( MOMY_t(KA,IA,JA) )
!    allocate( RHOT_t(KA,IA,JA) )
!    allocate( QTRC_t(KA,IA,JA,QA) )

    call ATMOS_PHY_MP_setup( MP_TYPE )

!    call ATMOS_PHY_MP_driver( .true., .false. )

    return
  end subroutine ATMOS_PHY_MP_driver_setup

  !-----------------------------------------------------------------------------
  !> Cloud Microphysics
  !-----------------------------------------------------------------------------
  subroutine ATMOS_PHY_MP_driver( update_flag, history_flag )
    use scale_atmos_phy_mp, only: &
       ATMOS_PHY_MP
    use mod_atmos_vars, only: &
       ATMOS_vars_fillhalo, &
       ATMOS_vars_total, &
       DENS, &
       MOMZ, &
       MOMX, &
       MOMY, &
       RHOT, &
       QTRC
    implicit none
    logical, intent(in) :: update_flag
    logical, intent(in) :: history_flag

    if ( update_flag ) then
       call ATMOS_PHY_MP( &
            DENS, &
            MOMZ, &
            MOMX, &
            MOMY, &
            RHOT, &
            QTRC )

       call ATMOS_vars_fillhalo

       call ATMOS_vars_total
    end if

    return
  end subroutine ATMOS_PHY_MP_driver

end module mod_atmos_phy_mp_driver


! ------------------------------------------------------------------------
! Copyright (C) 2017 Nobuya Sato, Hiori Kino, and Takashi Miyake
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
! ------------------------------------------------------------------------

program main
  use m_showtime
  use paramlist
  use frcfield
  use rfc5
  implicit none

  integer i
  integer:: loopa,loopc
  type(t_showtime)::  timer

  write(*,*)'soiap version 0.3.0'
  write(*,*)

  open(901,file='log.struc',form='formatted')
  open(902,file='log.tote',form='formatted')
  write(902,*)'# loopc,loopa,tote,fmax,tote/natom,omega,omega/natom'
  open(903,file='log.frc',form='formatted')
  open(904,file='log.strs',form='formatted')

  call input

  if (QMD%imd/=0.and.abs(QMD%imd)/=3.and.abs(QMD%imd)/=4) then
     write(*,*)'md_mode should be 0, 3 or 4'
     write(*,*)'md_mode=0: FIRE mode'
     write(*,*)'md_mode=3: simple relax'
     write(*,*)'md_mode=4: quenched MD (default)'
     stop 'QMD%imd error: other modes in structure_opt are under debug.'
  endif
  if (QMD%imdc/=0.and.QMD%imdc/=2.and.QMD%imdc/=3) then
     write(*,*)'md_mode_cell should be 0 2 or 3'
     write(*,*)'md_mode_cell=0: FIRE'
     write(*,*)'md_mode_cell=2: quenched MD (default)'
     write(*,*)'md_mode_cell=3: RFC5'
     stop 'QMD%imdc error: other modes in structure_opt are under development.'
  endif

  call tote_frc_strs
  QMD%uvo(:,:,1)=QMD%uv
  QMD%strso(:,:,1)=QMD%strs
  QMD%vuv=0.d0
  do loopc=1,QMD%nloopc ! relax unit cell
     QMD%loopc=loopc

     do loopa=1,QMD%nloopa ! relax internal coordinates
        QMD%loopa=loopa
        write(6,*)'QMD%loopc,QMD%loopa=',QMD%loopc,QMD%loopa,' out of ', &
             QMD%nloopc,QMD%nloopa

        call timer%start()
        call tote_frc_strs
        call timer%stop()
        call timer%show("tote_frc_strs:")

        do i=1,3
           QMD%strs(i,i)=QMD%strs(i,i)-QMD%extstrs(i)
        enddo

        call output_tote(902)

        if (QMD%fmax<QMD%fth) then
           write(*,'("QMD%frc converged. QMD%loopc, QMD%loopa, QMD%fmax",2i5,e12.4)') &
                QMD%loopc,QMD%loopa,QMD%fmax
           exit
        endif

        if (loopa/=QMD%nloopa) then
           call updt_coord
        endif
     enddo ! QMD%loopa

     call strs_max

     call output_struc(901)
     call output_frc(903)
     call output_strs(904)

     if (QMD%smax<QMD%sth) then
        write(*,'("QMD%strs converged. QMD%loopc, QMD%smax",i5,e12.4)')&
             QMD%loopc,QMD%smax
        if (QMD%fmax<QMD%fth) exit
     endif

     if (loopc/=QMD%nloopc) then
        call updt_cell
     endif
  enddo ! QMD%loopc

  close(901)
  close(902)
  close(903)
  close(904)

  write(*,*)'*** QMD%loopc =',QMD%loopc
  write(*,'(a,10F20.10)')'tote,fmax,tote/natom,omega,omega/natom=',&
       QMD%tote,QMD%fmax,&
       QMD%tote/QMD%natom,QMD%omega*((bohr)**3),QMD%omega*(bohr**3)/QMD%natom

  write(6,*)'!!!! normally end !!!!'

contains

  subroutine tote_frc_strs
    real*8 faemp

    if (QMD%ifrcf==1) then ! Stillinger-Weber for Si
       call Stillinger_Weber
    elseif (QMD%ifrcf==2) then ! Tsuneyuki potential for Si-O
       !stop 'Tsuneyuki potential is under debug'
       call Tsuneyuki
    elseif (QMD%ifrcf==3) then ! ZRL potential for Si-O
       call ZRL
    elseif (QMD%ifrcf==4) then ! ADP for Nd-Fe-B
       call ADP_KWU14
    elseif (QMD%ifrcf==5) then ! Jmatgen potential
      call Jmatgen
    elseif (QMD%ifrcf==6) then ! Lennard-Jones potential
      call LennardJones
    else
       stop 'etot_frc_strs error'
    endif

    QMD%fmax=0.d0
    do i=1,QMD%natom
       faemp=dsqrt(sum(QMD%frc(:,i)**2))
       if (QMD%iposfix(i)/=0.and.faemp>QMD%fmax) then
          QMD%fmax=faemp
       endif
    enddo

    !  write(*,'(a,10F20.10)')'tote,fmax,tote/natom,omega,omega/natom=',&
    !QMD%tote,QMD%fmax,&
    !QMD%tote/QMD%natom,QMD%omega*((bohr)**3),QMD%omega*(bohr**3)/QMD%natom

  end subroutine tote_frc_strs

  subroutine strs_max
    integer :: i,j

    QMD%smax=0.d0
    do i=1,3
       do j=1,3
          if (i==j) then
             QMD%smax=QMD%smax+QMD%strs(i,j)**2
          else
             QMD%smax=QMD%smax+QMD%strs(i,j)**2*2.d0
          endif
       enddo
    enddo

    QMD%smax=dsqrt(QMD%smax)

  end subroutine strs_max

  subroutine updt_cell
    integer :: ia

    if (QMD%imdc==3) then ! RFC5
       call updt_coordcell_RFC5((QMD%loopc-1)*QMD%nloopa+QMD%loopa,.true.,.true.)
    else
       if (QMD%loopc>1) then
          !    QMD%vuv=QMD%vuv+QMD%tstep*matmul(QMD%strs,QMD%uv)/QMD%mcell
          QMD%vuv=QMD%vuv+QMD%tstepc*matmul(QMD%strs,QMD%uv)/QMD%mcell
       else
          !    QMD%vuv=QMD%vuv+QMD%tste*matmul(QMD%strs,QMD%uv)/QMD%mcell*0.5d0
          QMD%vuv=QMD%vuv+QMD%tstepc*matmul(QMD%strs,QMD%uv)/QMD%mcell*0.5d0
       endif

       QMD%uvo(:,:,2)=QMD%uvo(:,:,1)
       QMD%uvo(:,:,1)=QMD%uv
       QMD%strso(:,:,2)=QMD%strso(:,:,1)
       QMD%strso(:,:,1)=QMD%strs

       if (QMD%imdc==0) then ! fire
          call lattice_fire(0.1d0)
       elseif (QMD%imdc==1) then ! steepest descent
          call latticerelax_sd
       elseif (QMD%imdc==2) then ! quenched MD
          call latticerelax
       else
          call lattice_simple_relax
       endif

       call cross_x(QMD%uv(:,1),QMD%uv(:,2),QMD%bv(:,3))
       call cross_x(QMD%uv(:,2),QMD%uv(:,3),QMD%bv(:,1))
       call cross_x(QMD%uv(:,3),QMD%uv(:,1),QMD%bv(:,2))
       QMD%omega=dot_product(QMD%bv(:,3),QMD%uv(:,3))
       QMD%omegai=1.d0/QMD%omega
       QMD%bv=QMD%bv*QMD%omegai

       do ia=1,QMD%natom
          QMD%ra(:,ia)=matmul(QMD%uv(:,:),QMD%rr(:,ia))
       enddo
    endif

    write(*,*)'QMD%omega =',QMD%omega

  end subroutine updt_cell

  subroutine updt_coord
    integer :: ia
    real(8) :: rfac

    do ia=1,QMD%natom
       if (QMD%loopa>1) then
          rfac=QMD%tstep/(QMD%mass(ia)*QMD%mfac(ia))
       else
          rfac=QMD%tstep/(QMD%mass(ia)*QMD%mfac(ia))*0.5d0
       endif
       QMD%vrr(:,ia)=QMD%vrr(:,ia)+rfac*matmul(QMD%frc(:,ia),QMD%bv(:,:))
    enddo

    if (QMD%imdc==3) then ! RFC5
       call updt_coordcell_RFC5((QMD%loopc-1)*QMD%nloopa+QMD%loopa,.true.,.false.)
    else
       call atomrelax
    endif

  end subroutine updt_coord

  subroutine output_struc(ifo)
    integer :: ifo,i,j

    write(ifo,*)'*** unit vectors [Bohr]: QMD%loopc =',QMD%loopc
    do i=1,3
       write(ifo,"(3f23.16)")(QMD%uv(i,j),j=1,3)
    enddo
    write(ifo,*)'*** internal lattice coordinates: QMD%loopc =',QMD%loopc
    do j=1,QMD%natom
       write(ifo,"(3f23.16)")(QMD%rr(i,j),i=1,3)
    enddo

    return
  end subroutine output_struc

  subroutine output_tote(ifo)
    integer :: ifo

    write(ifo,'(2i5,5F20.10)')QMD%loopc,QMD%loopa,QMD%tote,QMD%fmax,&
         QMD%tote/QMD%natom,QMD%omega*((bohr)**3),QMD%omega*(bohr**3)/QMD%natom

    !  write(ifo,'(a,2i5,5F20.10)')&
    !'loopa,loopc,tote,fmax,tote/natom,omega,omega/natom=',&
    !QMD%loopc,QMD%loopa,QMD%tote,QMD%fmax,&
    !QMD%tote/QMD%natom,QMD%omega*((bohr)**3),QMD%omega*(bohr**3)/QMD%natom

    return
  end subroutine output_tote

  subroutine output_frc(ifo)
    integer :: ifo,i,j

    write(ifo,*)'*** atomic forces: QMD%loopc =',QMD%loopc
    do j=1,QMD%natom
       write(ifo,"(3f23.16)")(QMD%frc(i,j),i=1,3)
    enddo

    return
  end subroutine output_frc

  subroutine output_strs(ifo)
    integer :: ifo,i,j

    write(ifo,*)'QMD%strs'
    write(ifo,'("QMD%loopc, QMD%smax",i5,2e16.6,e23.10)')QMD%loopc,&
         QMD%smax,QMD%sth,QMD%tote
    do i=1,3
       write(ifo,"(3f20.10)")(QMD%strs(i,j),j=1,3)
    enddo

    return
  end subroutine output_strs

end program main


!***********************************************************************
!  Integrated Water Flow Model (IWFM)
!  Copyright (C) 2005-2021
!  State of California, Department of Water Resources
!
!  This program is free software; you can redistribute it and/or
!  modify it under the terms of the GNU General Public License
!  as published by the Free Software Foundation; either version 2
!  of the License, or (at your option) any later version.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!  (http://www.gnu.org/copyleft/gpl.html)
!
!  You should have received a copy of the GNU General Public License
!  along with this program; if not, write to the Free Software
!  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
!
!  For tecnical support, e-mail: IWFMtechsupport@water.ca.gov
!***********************************************************************
MODULE Class_SystemData
  USE MessageLogger      , ONLY: SetLastMessage   , &
                                 iFatal
  USE IOInterface        , ONLY: GenericFileType  , &
                                 iGroup
  USE ZBudget_Parameters , ONLY: f_cAttributesDir
  USE ZBudget_Util       , ONLY: IsZBudgetFile
  IMPLICIT NONE

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** VARIABLE DEFINITIONS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- PUBLIC ENTITIES
  ! -------------------------------------------------------------
  PRIVATE
  PUBLIC :: SystemDataType

  ! -------------------------------------------------------------
  ! --- PHYSICAL SYSTEM DATA TYPE
  ! -------------------------------------------------------------
  TYPE SystemDataType
      INTEGER             :: NNodes                   = 0
      INTEGER             :: NElements                = 0
      INTEGER             :: NLayers                  = 0    !Number of layers considred for the hydrologic system (not necessarily equal to the aquifer layers)
      INTEGER             :: NFaces                   = 0    !Number of element faces
      REAL(8),ALLOCATABLE :: rNodeAreas(:)                   !Nodal area at each (node)
      INTEGER,ALLOCATABLE :: iElementIDs(:)                  !Element ID numbers
      REAL(8),ALLOCATABLE :: rElementAreas(:)                !Element area at each (element)
      INTEGER,ALLOCATABLE :: iElementNNodes(:)               !Number of nodes for each (element)
      INTEGER,ALLOCATABLE :: iElementNodes(:,:)              !Nodes for each element in counter-clockwise direction for (4,element) combination
      REAL(8),ALLOCATABLE :: rElementNodeAreas(:,:)          !Area associated with the vertex of each element given for (4,element) combination
      REAL(8),ALLOCATABLE :: rElementNodeAreaFractions(:,:)  !Ratio of area associated with the vertex of an element to the element area given for (4,element) combination
      INTEGER,ALLOCATABLE :: iFaceElems(:,:)                 !Element numbers on both sides of the face for (2,face) combination
      LOGICAL,ALLOCATABLE :: lBoundaryFace(:)                !Flag to check if a face is boundary face for each (face)
      LOGICAL,ALLOCATABLE :: lActiveNode(:,:)                !Flag that shows if a node is active or not for (node,layer) combination
      INTEGER,ALLOCATABLE :: iActiveLayerBelow(:,:)          !Active layer below each node for each (node,layer) combination; computed from lActiveNode
  CONTAINS
      PROCEDURE,PASS :: ReadFromFile
      PROCEDURE,PASS :: Kill
      PROCEDURE,PASS :: WriteToFile
  END TYPE SystemDataType

  ! -------------------------------------------------------------
  ! --- MISC. ENTITIES
  ! -------------------------------------------------------------
  INTEGER,PARAMETER                   :: ModNameLen = 18
  CHARACTER(LEN=ModNameLen),PARAMETER :: ModName    = 'Class_SystemData::'

CONTAINS

! ******************************************************************
! ******************************************************************
! ******************************************************************
! ***
! *** MISC. METHODS
! ***
! ******************************************************************
! ******************************************************************
! ******************************************************************

  ! -------------------------------------------------------------
  ! --- READ SYSTEM DATA FROM HDF FILE
  ! -------------------------------------------------------------
  SUBROUTINE ReadFromFile(SystemData,HDFFile,iStat)
    CLASS(SystemDataType),INTENT(OUT) :: SystemData
    TYPE(GenericFileType)             :: HDFFile
    INTEGER,INTENT(OUT)               :: iStat

    !Local variables
    CHARACTER(LEN=ModNameLen+12),PARAMETER :: ThisProcedure = ModName // 'ReadFromFile'
    INTEGER                                :: indxLayer,indxNode,indxLayerBelow,indx
    CHARACTER(:),ALLOCATABLE               :: cFileName

    !Check that this is indeed Z-Budget data file by checking if an object that Budget file doesn't have exist
    IF (.NOT. IsZBudgetFile(HDFFile)) THEN
        CALL HDFFile%GetName(cFileName)
        CALL SetLastMessage('File '//TRIM(cFileName)//' is not a Z-Budget file type!',iFatal,ThisProcedure)
        iStat = -1
        RETURN
    END IF

    CALL HDFFile%ReadData(f_cAttributesDir,'SystemData%NNodes',ScalarAttrData=SystemData%NNodes,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir,'SystemData%NElements',ScalarAttrData=SystemData%NElements,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir,'SystemData%NLayers',ScalarAttrData=SystemData%NLayers,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir,'SystemData%NFaces',ScalarAttrData=SystemData%NFaces,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    ALLOCATE (SystemData%rNodeAreas(SystemData%NNodes)                           , &
              SystemData%iElementIDs(SystemData%NElements)                       , &
              SystemData%rElementAreas(SystemData%NElements)                     , &
              SystemData%iElementNNodes(SystemData%NElements)                    , &
              SystemData%iElementNodes(4,SystemData%NElements)                   , &
              SystemData%iFaceElems(2,SystemData%NFaces)                         , &
              SystemData%lBoundaryFace(SystemData%NFaces)                        , &
              SystemData%lActiveNode(SystemData%NNodes,SystemData%NLayers), &
              SystemData%rElementNodeAreas(4,SystemData%NElements)               , &
              SystemData%rElementNodeAreaFractions(4,SystemData%NElements)       )
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%NodeAreas',SystemData%rNodeAreas,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementAreas',SystemData%rElementAreas,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementNNodes',SystemData%iElementNNodes,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementNodes',SystemData%iElementNodes,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    IF (SystemData%NFaces .GT. 0) THEN
        CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%FaceElements',SystemData%iFaceElems,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
        CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%BoundaryFace',SystemData%lBoundaryFace,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    END IF
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ActiveNode',SystemData%lActiveNode,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementNodeAreas',SystemData%rElementNodeAreas,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementNodeAreaFractions',SystemData%rElementNodeAreaFractions,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN

    !Backward compatibility: Check if SystemData%ElementIDs object exists. Read if it does; otherwise create the data in memory as being equal to the element index
    IF (HDFFile%DoesHDFObjectExist(f_cAttributesDir//'/SystemData%ElementIDs')) THEN
        CALL HDFFile%ReadData(f_cAttributesDir//'/SystemData%ElementIDs',SystemData%iElementIDs,iStat=iStat)  ;  IF (iStat .EQ. -1) RETURN
    ELSE
        SystemData%iElementIDs = [(indx,indx=1,SystemData%NElements)]
    END IF

    !Compile the array that holds active layer below each node
    ALLOCATE (SystemData%iActiveLayerBelow(SystemData%NNodes,SystemData%NLayers-1))
    SystemData%iActiveLayerBelow = 0
    DO indxLayer=1,SystemData%NLayers-1
        DO indxNode=1,SystemData%NNodes
            DO indxLayerBelow=indxLayer+1,SystemData%NLayers
                IF (SystemData%lActiveNode(indxNode,indxLayerBelow)) THEN
                    SystemData%iActiveLayerBelow(indxNode,indxLayer) = indxLayerBelow
                    EXIT
                END IF
            END DO
        END DO
    END DO

  END SUBROUTINE ReadFromFile

  ! -------------------------------------------------------------
  ! --- WRITE SYSTEM DATA TO HDF FILE
  ! -------------------------------------------------------------
  SUBROUTINE WriteToFile(SystemData,HDFFile)
    CLASS(SystemDataType),INTENT(IN) :: SystemData
    TYPE(GenericFileType)            :: HDFFile

    CALL HDFFile%WriteData(iGroup,f_cAttributesDir,'SystemData%NNodes',ScalarAttrData=SystemData%NNodes)
    CALL HDFFile%WriteData(iGroup,f_cAttributesDir,'SystemData%NElements',ScalarAttrData=SystemData%NElements)
    CALL HDFFile%WriteData(iGroup,f_cAttributesDir,'SystemData%NLayers',ScalarAttrData=SystemData%NLayers)
    CALL HDFFile%WriteData(iGroup,f_cAttributesDir,'SystemData%NFaces',ScalarAttrData=SystemData%NFaces)
    CALL HDFFile%WriteData(SystemData%rNodeAreas,cHDFPath=f_cAttributesDir//'/SystemData%NodeAreas')
    CALL HDFFile%WriteData(SystemData%iElementIDs,cHDFPath=f_cAttributesDir//'/SystemData%ElementIDs')
    CALL HDFFile%WriteData(SystemData%rElementAreas,cHDFPath=f_cAttributesDir//'/SystemData%ElementAreas')
    CALL HDFFile%WriteData(SystemData%iElementNNodes,cHDFPath=f_cAttributesDir//'/SystemData%ElementNNodes')
    CALL HDFFile%WriteData(SystemData%iElementNodes,cHDFPath=f_cAttributesDir//'/SystemData%ElementNodes')
    IF (SystemData%NFaces .GT. 0) THEN
        CALL HDFFile%WriteData(SystemData%iFaceElems,cHDFPath=f_cAttributesDir//'/SystemData%FaceElements')
        CALL HDFFile%WriteData(SystemData%lBoundaryFace,cHDFPath=f_cAttributesDir//'/SystemData%BoundaryFace')
    END IF
    CALL HDFFile%WriteData(SystemData%lActiveNode,cHDFPath=f_cAttributesDir//'/SystemData%ActiveNode')
    CALL HDFFile%WriteData(SystemData%rElementNodeAreas,cHDFPath=f_cAttributesDir//'/SystemData%ElementNodeAreas')
    CALL HDFFile%WriteData(SystemData%rElementNodeAreas,cHDFPath=f_cAttributesDir//'/SystemData%ElementNodeAreaFractions')
    !CALL HDFFile%WriteData(SystemData%iActiveLayerBelow,cAttributesDir//'/SystemData%iActiveLayerBelow')  !This is computed based on SystemData%lActiveNode array

  END SUBROUTINE WriteToFile

  ! -------------------------------------------------------------
  ! --- KILL SYSTEM DATA
  ! -------------------------------------------------------------
  SUBROUTINE Kill(SystemData)
    CLASS(SystemDataType) :: SystemData

    !Local variables
    INTEGER              :: ErrorCode
    TYPE(SystemDataType) :: Dummy

    DEALLOCATE(SystemData%rNodeAreas                 , &
               SystemData%iElementIDs                , &
               SystemData%rElementAreas              , &
               SystemData%iElementNNodes             , &
               SystemData%iElementNodes              , &
               SystemData%iFaceElems                 , &
               SystemData%lBoundaryFace              , &
               SystemData%lActiveNode                , &
               SystemData%iActiveLayerBelow          , &
               SystemData%rElementNodeAreas          , &
               SystemData%rElementNodeAreaFractions  , &
               STAT = ErrorCode                      )

    !Back to default values
    SELECT TYPE (SystemData)
        TYPE IS (SystemDataType)
            SystemData = Dummy
    END SELECT

  END SUBROUTINE Kill

END MODULE