      SUBROUTINE cumtnc(t,df,pnonc,cum,ccum)
C**********************************************************************
C
C     SUBROUTINE CUMTNC(T,DF,PNONC,CUM,CCUM)
C
C                 CUMulative Non-Central T-distribution
C
C
C                              Function
C
C
C     Computes the integral from -infinity to T of the non-central
C     t-density.
C
C
C                              Arguments
C
C
C     T --> Upper limit of integration of the non-central t-density.
C                                                  T is DOUBLE PRECISION
C
C     DF --> Degrees of freedom of the non-central t-distribution.
C                                                  DF is DOUBLE PRECISIO
C
C     PNONC --> Non-centrality parameter of the non-central t distibutio
C                                                  PNONC is DOUBLE PRECI
C
C     CUM <-- Cumulative t-distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C     CCUM <-- Compliment of Cumulative t-distribution.
C                                                  CCUM is DOUBLE PRECIS
C
C
C                              Method
C
C     Upper tail    of  the  cumulative  noncentral t   using
C     formulae from page 532  of Johnson, Kotz,  Balakrishnan, Coninuous
C     Univariate Distributions, Vol 2, 2nd Edition.  Wiley (1995)
C
C     This implementation starts the calculation at i = lambda,
C     which is near the largest Di.  It then sums forward and backward.
C***********************************************************************
C     .. Parameters ..

      DOUBLE PRECISION one,zero,half,two,onep5
      PARAMETER (one=1.0d0,zero=0.0d0,half=0.5d0,two=2.0d0,onep5=1.5d0)
      DOUBLE PRECISION conv
      PARAMETER (conv=1.0d-7)
      DOUBLE PRECISION tiny
      PARAMETER (tiny=1.0d-10)
C     ..
C     .. Scalar Arguments ..
      DOUBLE PRECISION ccum,cum,df,pnonc,t
C     ..
C     .. Local Scalars ..
      DOUBLE PRECISION alghdf,b,bb,bbcent,bcent,cent,d,dcent,dpnonc,
     +                 dum1,dum2,e,ecent,halfdf,lambda,lnomx,lnx,omx,
     +                 pnonc2,s,scent,ss,sscent,t2,term,tt,twoi,x,
     +                 xi,xlnd,xlne
      INTEGER ierr
      LOGICAL qrevs
C     ..
C     .. External Functions ..
      DOUBLE PRECISION gamln
      EXTERNAL gamln
C     ..
C     .. External Subroutines ..
      EXTERNAL bratio,cumnor,cumt
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC abs,exp,int,log,max,min
C     ..

C     Case pnonc essentially zero

      IF (abs(pnonc).LE.tiny) THEN
          CALL cumt(t,df,cum,ccum)
          RETURN

      END IF

      qrevs = t .LT. zero
      IF (qrevs) THEN
          tt = -t
          dpnonc = -pnonc

      ELSE
          tt = t
          dpnonc = pnonc
      END IF

      pnonc2 = dpnonc*dpnonc
      t2 = tt*tt

      IF (abs(tt).LE.tiny) THEN
          CALL cumnor(-pnonc,cum,ccum)
          RETURN

      END IF

      lambda = half*pnonc2
      x = df/ (df+t2)
      omx = one - x

      lnx = log(x)
      lnomx = log(omx)

      halfdf = half*df
      alghdf = gamln(halfdf)

C     ******************** Case i = lambda

      cent = int(lambda)

      IF (cent.LT.one) cent = one

C     Compute d=T(2i) in log space and offset by exp(-lambda)

      xlnd = cent*log(lambda) - gamln(cent+one) - lambda

      dcent = exp(xlnd)

C     Compute e=t(2i+1) in log space offset by exp(-lambda)

      xlne = (cent+half)*log(lambda) - gamln(cent+onep5) - lambda
      ecent = exp(xlne)

      IF (dpnonc.LT.zero) ecent = -ecent

C     Compute bcent=B(2*cent)

      CALL bratio(halfdf,cent+half,x,omx,bcent,dum1,ierr)

C     compute bbcent=B(2*cent+1)

      CALL bratio(halfdf,cent+one,x,omx,bbcent,dum2,ierr)

C     Case bcent and bbcent are essentially zero
C     Thus t is effectively infinite

      IF ((bcent+bbcent).LT.tiny) THEN
          IF (qrevs) THEN
              cum = zero
              ccum = one

          ELSE
              cum = one
              ccum = zero
          END IF

          RETURN

      END IF

C     Case bcent and bbcent are essentially one
C     Thus t is effectively zero

      IF ((dum1+dum2).LT.tiny) THEN
          CALL cumnor(-pnonc,cum,ccum)
          RETURN

      END IF

C     First term in ccum is D*B + E*BB

      ccum = dcent*bcent + ecent*bbcent

C     compute s(cent) = B(2*(cent+1)) - B(2*cent))

      scent = gamln(halfdf+cent+half) - gamln(cent+onep5) - alghdf +
     +        halfdf*lnx + (cent+half)*lnomx
      scent = exp(scent)

C     compute ss(cent) = B(2*cent+3) - B(2*cent+1)

      sscent = gamln(halfdf+cent+one) - gamln(cent+two) - alghdf +
     +         halfdf*lnx + (cent+one)*lnomx
      sscent = exp(sscent)

C     ******************** Sum Forward

      xi = cent + one
      twoi = two*xi

      d = dcent

      e = ecent

      b = bcent

      bb = bbcent

      s = scent

      ss = sscent

   10 b = b + s
      bb = bb + ss

      d = (lambda/xi)*d
      e = (lambda/ (xi+half))*e

      term = d*b + e*bb

      ccum = ccum + term

      s = s*omx* (df+twoi-one)/ (twoi+one)

      ss = ss*omx* (df+twoi)/ (twoi+two)

      xi = xi + one
      twoi = two*xi

      IF (abs(term).GT.conv*ccum) GO TO 10

C     ******************** Sum Backward

      xi = cent
      twoi = two*xi

      d = dcent

      e = ecent

      b = bcent

      bb = bbcent

      s = scent* (one+twoi)/ ((df+twoi-one)*omx)

      ss = sscent* (two+twoi)/ ((df+twoi)*omx)

   20 b = b - s
      bb = bb - ss

      d = d* (xi/lambda)

      e = e* ((xi+half)/lambda)

      term = d*b + e*bb

      ccum = ccum + term

      xi = xi - one

      IF (xi.LT.half) GO TO 30

      twoi = two*xi

      s = s* (one+twoi)/ ((df+twoi-one)*omx)

      ss = ss* (two+twoi)/ ((df+twoi)*omx)

      IF (abs(term).GT.conv*ccum) GO TO 20

   30 CONTINUE

      IF (qrevs) THEN
          cum = half*ccum
          ccum = one - cum

      ELSE
          ccum = half*ccum
          cum = one - ccum
      END IF

C     Due to roundoff error the answer may not lie between zero and one
C     Force it to do so

      cum = max(min(cum,one),zero)
      ccum = max(min(ccum,one),zero)

      RETURN

      END


subroutine writetofile(fname)
!writes the results of the simulation to a binary file
!also calculates the pressure and ram pressure forces on the object
    use vars
    use parallel
    implicit none

    character (len=*) :: fname
    real, allocatable :: u2(:,:), pressure(:,:)
    real :: bernoulli
    integer :: i, j

    real, allocatable, dimension(:,:) :: toppres, sidepres, du, dv
    real, allocatable, dimension(:,:) ::  sideboundary, toptheta, sidetheta

    real :: frontarea, toparea

    real :: plift, pdrag, ram, ramlift, lift, drag
    real :: u0
    real :: c_lift, c_drag

    !update velocities
    call getv()

    !populate global array
    call collate_data()

    if (irank .eq. 0) then

        allocate(u2(nx_global,ny_global))
        allocate(pressure(nx_global,ny_global))
        allocate(sideboundary(nx_global,ny_global))

        allocate(toppres(nx_global,ny_global), sidepres(nx_global,ny_global))
        allocate(du(nx_global,ny_global), dv(nx_global,ny_global))
        allocate(toptheta(nx_global,ny_global),sidetheta(nx_global,ny_global))

        ! |v|^2
        u2 = u_global*u_global + v_global*v_global

        ! incoming velocity
        u0=u2(1,ny_global/2)

        !From Bernoulli's equation 1/2rhov^2 + p = const
        bernoulli = p0*p_air + 0.5*rho*u0 *(rho_air) * (airspeed*vconv)**2 !bernoulli constant for the gas

        pressure = bernoulli - 0.5*rho*u2 *(rho_air) * (airspeed*vconv)**2 !pressure as a function of position

        pressure=pressure/p_air!*(1-mask_global)

        !calculate pressure on top/bottom boundary (pressure 1 gridcell up/down from boundary)
        toppres(:,:)=0
        toptheta(:,:)=0
        do j=1,ny_global
            do i=1,nx_global
                if (boundary_global(i,j) .ne. 0) then
                    if (boundary_global(i,j) .eq. 1) then !top
                        toppres(i,j) = pressure(i,j+2)
                        !toptheta(i,j) = atan(v_global(1,j+2),u_global(i,j+2))
                    else !bottom
                        toppres(i,j) = pressure(i,j-2)
                        !toptheta(i,j) = atan(v_global(1,j-2),u_global(i,j-2))
                    endif
                endif
            enddo
        enddo

        sideboundary(:,:) = 0

        !find the side boundary
        do j=1,ny_global
            do i=1,nx_global
                if(mask_global(i,j) .eq. 1) then
                    sideboundary(i,j)=sideboundary(i,j)-1 !left - normal vector is negative
                    exit
                endif
            enddo

            if (i .ne. nx) then
                do i=nx_global,1,-1
                    if (mask_global(i,j) .eq. 1) then
                        sideboundary(i,j) = sideboundary(i,j)+1 !right, normal vector is positive
                        exit
                    endif
                enddo
            endif
        enddo

        !get pressure and u,v on side boundary

        sidepres=0
        dv=0
        du=0
    !    sidetheta(:,:)=0.
        do j=1,ny_global
            do i=1,nx_global
                if (sideboundary(i,j) .ne. 0) then
                    if (sideboundary(i,j) .lt. 0) then !front
                        sidepres(i,j) = pressure(i-2,j)
                        dv(i,j) = v_global(i-2,j)
                        du(i,j)= abs(u_global(i-2,j)-sqrt(u0))
                        !sidetheta(i,j) = atan(v_global(i-2,j),u_global(i-2,j))
                    else !back
                        sidepres(i,j) = pressure(i+2,j)
                        !sidetheta(i,j) = atan(v_global(i+2,j),u_global(i+2,j))
                    endif
                endif
            enddo
        enddo

        !toptheta(:,:)=0.
        !sidetheta(:,:) = 3.141592/2.

        plift = -sum( toppres*boundary_global)*dxx * p_air ! f = oint -p(yhat.da)
        pdrag = -sum( sidepres*sideboundary)*dyy*p_air !! f = oint -p(xhat.da)

        !ram pressure:
        ! f = dp/dt = m*dv/dt.
        !in n seconds, u0*rho kg of air pass through each m^2 per unit time
        ! if the gas changes velocity by dv then
        ! f = u0*rho*dv

        ram =-sum(sideboundary*sqrt(u0)*du) *(rho*rho_air) * (vconv*airspeed)**2 * dyy
        ramlift =-sum(sideboundary*sqrt(u0)*(dv)) *(rho*rho_air) * (vconv*airspeed)**2 * dyy

        lift=plift+ramlift
        drag=pdrag+ram

        frontarea=sum(abs(sideboundary))/2*dyy
        !print*,"frontarea=",frontarea

        toparea=sum(abs(boundary_global))/2*dxx
        !print*,'toparea=',toparea

        !calculate lift and drag coefficients
        ! C_l = lift/(1/2 rho u^2) / A

        c_lift = lift / (0.5*rho*u0*rho_air * (vconv*airspeed)**2 )/toparea

        !c_d = drag /(1/2*rho*u^2)/A

        c_drag= drag / (0.5*rho*u0*rho_air * (vconv*airspeed)**2 )/frontarea

        print*,"-------------------------------------------------------------------------------"
        print *, "pressure lift=", plift
        print *, "ram lift     =", ramlift
        print *,''
        print *, "pressure drag=", pdrag
        print *, "ram drag     =", ram
        print*, ''
        print*," ------------------------------------"
        print *, "|Total lift   =", lift, "N/m |"
        print* , "|Total drag   =", drag, "N/m |"
        print *, ' ----------------------------------'
        print *, "Lift Coefficient=",c_lift
        print *, "Drag Coefficient=",c_drag
        print *, "Lift to drag    =",lift/drag
        print *, ''

        u2=sqrt(u2)*airspeed

        open (unit=10,file=fname,access='stream',status='REPLACE')
        write(10) nx_global,ny_global
        write(10) x_global, y_global
        write(10) psi_global/(1-mask_global)
        write(10) mask_global
        write(10) u_global, v_global
        write(10) u2/(1-mask_global), pressure/(1-mask_global)
        write(10) vort_global/(1-mask_global)
        write(10) plift, ramlift, pdrag, ram, lift, drag
        write(10) c_lift, c_drag, c_lift*toparea, c_drag*frontarea
        close(10)

        print *, "Written '",fname,"' to file."
        print*,"-------------------------------------------------------------------------------"

    endif

end subroutine


*
*     ------------------------------------------------------------------
*	B N D I N V
*     ------------------------------------------------------------------
*
        SUBROUTINE BNDINV(A,EL,N,DETERM,EPSIL,ITEST,NSIZE)
C
C       DOUBLE PRECISION MATRIX INVERSION SUBROUTINE
C       FROM "DLYTAP".
C
C*      DOUBLE PRECISION E,F
C*      DOUBLE PRECISION A,EL,D,DSQRT,C,S,DETERP
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION A(NSIZE,1),EL(NSIZE,1)
        IF(N.LT.2)GO TO 140
        ISL2=0
        K000FX=2
        IF(ISL2.EQ.0)INDSNL=2
        IF(ISL2.EQ.1)INDSNL=1
C       CALL SLITET(2,INDSNL)
C       CALL OVERFL(K000FX)
C       CALL DVCHK(K000FX)
C
C       SET EL = IDENTITY MATRIX
        DO 30 I=1,N
        DO 10 J=1,N
 10     EL(I,J)=0.0D0
 30     EL(I,I)=1.0D0
C
C       TRIANGULARIZE A, FORM EL
C
        N1=N-1
        M=2
        DO 50 J=1,N1
        DO 45 I=M,N
        IF(A(I,J).EQ.0.0D0)GO TO 45
        D=DSQRT(A(J,J)*A(J,J)+A(I,J)*A(I,J))
        C=A(J,J)/D
        S=A(I,J)/D
 38     DO 39 K=J,N
        D=C*A(J,K)+S*A(I,K)
        A(I,K)=C*A(I,K)-S*A(J,K)
        A(J,K)=D
 39     CONTINUE
        DO 40 K=1,N
        D=C*EL(J,K)+S*EL(I,K)
        EL(I,K)=C*EL(I,K)-S*EL(J,K)
        EL(J,K)=D
 40     CONTINUE
 45     CONTINUE
 50     M=M+1
C       CALL OVERFL(K000FX)
C       GO TO (140,51),K000FX
C
C       CALCULATE THE DETERMINANT
 51     DETERP=A(1,1)
        DO 52 I=2,N
 52     DETERP=DETERP*A(I,I)
        DETERM=DETERP
C       CALL OVERFL(K000FX)
C       GO TO (140,520,520),K000FX
C
C       IS MATRIX SINGULAR
 520    F=A(1,1)
        E=A(1,1)
        DO 58 I=2,N
        IF(DABS(F).LT.DABS(A(I,I)))F=A(I,I)
        IF(DABS(E).GT.DABS(A(I,I)))E=A(I,I)
 58     CONTINUE
        EPSILP=EPSIL
        IF(EPSILP.LE.0)EPSILP=1.0E-8
        RAT=E/F
        IF(ABS(RAT).LT.EPSILP)GO TO 130
C
C       INVERT TRIANGULAR MATRIX
        J=N
        DO 100 J1=1,N
C       CALL SLITE(2)
        I=J
        ISL2=1
        DO 90 I1=1,J
C       CALL SLITET(2,K000FX)
        IF(ISL2.EQ.0)K000FX=2
        IF(ISL2.EQ.1)K000FX=1
        IF(ISL2.EQ.1)ISL2=0
        GO TO (70,75),K000FX
 70     A(I,J)=1.0D0/A(I,I)
        GO TO 90
 75     KS=I+1
        D=0.0D0
        DO 80 K=KS,J
 80     D=D+A(I,K)*A(K,J)
        A(I,J)=-D/A(I,I)
 90     I=I-1
 100    J=J-1
C       CALL OVERFL(K000FX)
C       GO TO (140,103,103),K000FX

C103    CALL DVCHK(K000FX)
C       GO TO (140,105),K000FX
C
C       PREMULTIPLY EL BY INVERTED TRIANGULAR MATRIX
 105    M=1
        DO 120 I=1,N
        DO 118 J=1,N
        D=0.0D0
        DO 107 K=M,N
 107    D=D+A(I,K)*EL(K,J)
        EL(I,J)=D
 118    CONTINUE
 120    M=M+1
C       CALL OVERFL(K000FX)
C       GO TO (140,123,123),K000FX
C
C       RECOPY EL TO A
 123    DO 124 I=1,N
        DO 124 J=1,N
 124    A(I,J)=EL(I,J)
        ITEST=0
C126    IF(INDSNL.EQ.1)CALL SLITE(2)
 126    IF(INDSNL.EQ.1)ISL2=1
        RETURN
C
 130    ITEST=1
        GO TO 126
 140    ITEST=-1
        GO TO 126
        END


!----------------------------------------------------------------------*
!  SUBROUTINE SUBLAI3                                                  *
!  Version 2: January 2001                                             *
!          Version august, 503                                        *
!                                                                      *
!  Purpose: This subroutine calculates the rate of growth of LAI of    *
!    of the crop in the seedbed and after transplanting in the field.  *
!    Reductions by N-stress and water-stress are taken into account.   *
!                                                                      *
! FORMAL PARAMETERS:  (I=input,O=output,C=control,IN=init,T=time)      *
! name   type meaning (unit)                                     class *
! ----   ---- ---------------                                    ----- *
! CROPSTA I4  Crop stage (-)                                        I  *
! RWLVG   R4  Green leaves growth rate (kg d-1 ha-1)                I  *
! DLDR    R4  Death rate green leaves (kg d-1 ha-1)                 I  *
! TSLV    R4  Temperature sum for leaf development (oC)             I  *
! HULV    R4  Daily temperature for leaf development (oC)           I  *
! SHCKL   R4  Delay parameter in development ((oCd)(oCd)-1)         I  *
! LESTRS  R4  Reduction factor for leaf elongation (-)              I  *
! SLA     R4  Specific leaf area (ha kg-1)                          I  *
! NH      R4  Number of hills (hills m-2)                           I  *
! NPLH    I4  Number of plants per hill (pl/hill)                   I  *
! NPLSB   R4  Number of plants in seedbed (pl/m2)                   I  *
! DVS     R4  Development stage of the crop (-)                     I  *
! LAI     R4  Leaf area index (ha ha-1)                             I  *
! RGRLMX  R4  Maximum relative growth rate leaves ((oCd)-1)         I  *
! RGRLMN  R4  Minimum relative growth rate leaves ((oCd)-1)         I  *
! ESTAB   C*  Establishment method (-)                              I  *
! GLAI    R4  Growth rate leaf area index (ha d-1 ha-1)             O  *
! RGRL    R4  Actual relative growth rate leaves ((oCd)-1)          O  *
!----------------------------------------------------------------------*
       SUBROUTINE SUBLAI3(CROPSTA,RGRLMX,RGRLMN,TSLV,HULV, &
                          SHCKL,LESTRS,RNSTRS,SLA,NH,NPLH,NPLSB,DVS,LAI, &
                          ESTAB,RWLVG,DLDR,WLVG,GLAI,RGRL)

      IMPLICIT NONE
!-----Formal parameters
      INTEGER       CROPSTA
      CHARACTER (*) ESTAB
      REAL          RGRL  , TSLV, HULV, SHCKL, NPLSB
      REAL          LESTRS, SLA  , NH  , NPLH, DVS , LAI  , GLAI
      REAL          RNSTRS, RGRLMX, RGRLMN, WLVG, RWLVG, DLDR
!-----Local parameters
      REAL          TSLVTR, TSHCKL, GLAI1,GLAI2, X, TESTSET
      REAL          WLVGEXP, LAIEXP, WLVGEXS, LAIEXS, TEST, DVSE
      LOGICAL       TESTL

      REAL NOTNUL

      SAVE         ! TAOLI

      IF (CROPSTA .LE. 1) THEN
        X       = 1.
        TESTL   = .FALSE.
        TESTSET = 0.01
      END IF

!===================================================================*
!------Transplanted rice                                            *
!===================================================================*
!      Calculate RGRL as function of N stress limitation
       RGRL = RGRLMX - (1.-RNSTRS)*(RGRLMX-RGRLMN)

       IF (ESTAB .EQ. 'TRANSPLANT') THEN
!------- 1. Seed-bed; no drought stress effects in seed-bed!
         IF (CROPSTA .LT. 3) THEN
            IF (LAI.LT.1.) THEN
               GLAI = LESTRS * LAI*RGRL*HULV
               WLVGEXS = WLVG
               LAIEXS  = LAI
            ELSE
               IF (.NOT. TESTL) THEN
               TEST = ABS((LAI/NOTNUL(WLVG))-SLA)/SLA
                  IF (TEST .LT. TESTSET) TESTL = .TRUE.
               END IF
               IF (TESTL) THEN
                  GLAI = ((WLVG+RWLVG)*SLA)-LAI
               ELSE
                  GLAI1 = ((WLVG+RWLVG-WLVGEXS)*SLA+LAIEXS)-LAI
                  GLAI2 = ((WLVG+RWLVG)*SLA)-LAI
                  IF (GLAI2 .GT. 0.) THEN
                      GLAI  = (GLAI1+X*GLAI2)/(X+1.)
                  ELSE
                      GLAI = GLAI1
                  END IF
                  X     = X+1.
               END IF
            END IF
!------- 2. Transplanting effects: dilution and shock-setting
         ELSE IF (CROPSTA .EQ. 3) THEN
            TSLVTR = TSLV
            TSHCKL = SHCKL*TSLVTR
            GLAI   = (LAI*NH*NPLH/NPLSB) - LAI
            TESTL  = .FALSE.
            X      = 1.
!--------3. After transplanting: main crop growth
         ELSE IF (CROPSTA .EQ. 4) THEN
!--------3.1. During transplanting shock-period
            IF (TSLV.LT.(TSLVTR+TSHCKL)) THEN
               GLAI = 0.
               DVSE = DVS
!--------3.2. After transplanting shock; drought stress effects
            ELSE
               IF ((LAI.LT.1.0).AND.(DVS.LT.1.0)) THEN
                  GLAI = LESTRS * LAI*RGRL*HULV
                  WLVGEXP = WLVG
                  LAIEXP  = LAI
               ELSE
!                 There is a transition from RGRL to SLA determined growth
!                 when difference between simulated and imposed SLA is less than 1%
                  if(RWLVG.lt.0.0) then
                               TESTL =.true.
                          elseif((RWLVG.ge.0.0).and.(testl)) then
                              TESTL =.false.
                          endif                  !Added by TaoLi, 10 Aug, 2010
                  IF (.NOT. TESTL) THEN
                     TEST = ABS((LAI/NOTNUL(WLVG))-SLA)/SLA
                     IF (TEST .LT. TESTSET) TESTL = .TRUE.
                  END IF
                  IF (TESTL) THEN
                     GLAI = ((WLVG+RWLVG-DLDR)*SLA)-LAI
                  ELSE
                     GLAI1 = ((WLVG+RWLVG-DLDR-WLVGEXP)*SLA+LAIEXP)-LAI
                     GLAI2 = ((WLVG+RWLVG-DLDR)*SLA)-LAI
                     IF (GLAI2 .LT. 0. .AND. GLAI1 .GT. 0.) THEN
                        GLAI = GLAI1/(X+1)
                     ELSE
                        GLAI  = (GLAI1+X*GLAI2)/(X+1.)
                     END IF
                     X     = X+1.
                  END IF
               END IF
            END IF
         END IF

!===================================================================*
!------Direct-seeded rice                                           *
!===================================================================*
       ELSE IF (ESTAB .EQ. 'DIRECT-SEED') THEN
         IF ((LAI.LT.1.0).AND.(DVS.LT.1.0)) THEN
            GLAI    = LAI*RGRL*HULV * LESTRS
            WLVGEXP = WLVG
            LAIEXP  = LAI
         ELSE
!           There is a transition from RGRL to SLA determined growth
!           when difference between simulated and imposed SLA is less than 10%
                  if(RWLVG.lt.0.0) then
                        TESTL =.true.
                  elseif((RWLVG.ge.0.0).and.(testl)) then
                        TESTL =.false.
                  endif                  !Added by TaoLi, 10 Aug, 2010
            IF (.NOT. TESTL) THEN
               TEST = ABS((LAI/NOTNUL(WLVG))-SLA)/SLA
               IF (TEST .LT. TESTSET) TESTL = .TRUE.
            END IF
            IF (TESTL) THEN
               GLAI = ((WLVG+RWLVG-DLDR)*SLA)-LAI
            ELSE
               GLAI1 = ((WLVG+RWLVG-DLDR-WLVGEXP)*SLA+LAIEXP)-LAI
               GLAI2 = ((WLVG+RWLVG-DLDR)*SLA)-LAI
               IF (GLAI2 .LT. 0. .AND. GLAI1 .GT. 0.) THEN
                  GLAI = GLAI1/(X+1)
               ELSE
                  GLAI  = (GLAI1+X*GLAI2)/(X+1.)
               END IF
               X     = X+1.
            END IF
         END IF
       END IF

      RETURN
      END


module constants

    implicit none
    real(kind=8) :: pi = datan(1d0)*4d0!3.14159265358979323846264338327950288419716939937510
    real(kind=8) :: GeV = 1d0
    real(kind=8) :: kev = 10d0**(-6)
    real(kind=8) :: femtometer = 5.0677d0 ! /GeV
    real(kind=8) :: centimeter = 5.0677d0*10d0**13d0
    real(kind=8) :: kilometerpersecond = 3.33564d0 * 10d0**(-6d0)
    real(kind=8) :: kilogramday = 7.3634d0*10d0**55d0
    real(kind=8) :: mn = 0.938272d0
    real(kind=8) :: mv = 246.2d0

    real(kind=8) :: vearth  = 232.0d0!km/s
    REAL(kind=8) :: vescape = 12 * 232.d0! km/s
    REAL(kind=8) :: vscale  = 220.0d0! km/s

    real(kind=8) :: ntscale = 1d0

end module constants


      SUBROUTINE INVARS
C--
C--   SUBROUTINE INVARS (ISTART)
C--
C--   Purpose : initialize all spectral variables starting from
C--             either a reference atmosphere or a restart file
C--   Input :   ISTART = 0 : reference atmosphere (at rest)
C--                    = 1 : restart file
C--   Initialized common blocks : DATE1, DYNSP1, DYNSP2 (PHIS only),
C--                               SFCANOM, SFCFLUX
C--
      include "atparam.h"
      include "atparam1.h"

      include "com_date.h"
      include "com_tsteps.h"

      include "com_surfcon.h"

      include "com_dyncon0.h"
      include "com_dyncon1.h"

      include "com_dynvar.h"

      COMPLEX ZERO, CCON, SURFS(MX,NX)
      REAL  SURFG(IX,IL)

      GAM1 = GAMMA/(1000.*GRAV)
      ZERO = (0.,0.)
      CCON = (1.,0.)*SQRT(2.)

C--   1. Compute spectral surface geopotential

      CALL SPEC (PHI0,PHIS)
      IF (IX.EQ.IY*4) CALL TRUNCT (PHIS)

      CALL GRID (PHIS,PHIS0,1)

      IF (ISTART.EQ.0) THEN

C--   2. Start from reference atmosphere (at rest)

        print*, ' starting from rest'

        IYEAR  = IYEAR0
        IMONTH = IMONT0

C       2.1 Set vorticity, divergence and tracers to zero

        DO K=1,KX
         DO N=1,NX
          DO M=1,MX
            VOR(M,N,K,1)=ZERO
            DIV(M,N,K,1)=ZERO
          ENDDO
         ENDDO
        ENDDO

        DO ITR=1,NTR
         DO K=1,KX
          DO N=1,NX
           DO M=1,MX
             TR(M,N,K,1,ITR)=ZERO
           ENDDO
          ENDDO
         ENDDO
        ENDDO

C       2.2 Set reference temperature :
C           tropos:  T = 288 degK at z = 0, constant lapse rate
C           stratos: T = 216 degK, lapse rate = 0

        TREF  = 288.
        TTOP  = 216.
        GAM2  = GAM1/TREF
        RGAM  = RGAS*GAM1
        RGAMR = 1./RGAM

C       Surface and stratospheric air temperature

        DO N=1,NX
         DO M=1,MX
           T(M,N,1,1)=ZERO
	   T(M,N,2,1)=ZERO
           SURFS(M,N)=-GAM1*PHIS(M,N)
         ENDDO
        ENDDO

        T(1,1,1,1)=CCON*TTOP
        T(1,1,2,1)=CCON*TTOP
        SURFS(1,1)=CCON*TREF-GAM1*PHIS(1,1)

C       Temperature at tropospheric levels
        DO K=3,KX
          FACTK=FSG(K)**RGAM
          DO N=1,NX
           DO M=1,MX
             T(M,N,K,1)=SURFS(M,N)*FACTK
           ENDDO
          ENDDO
        ENDDO

C       2.3 Set log(ps) consistent with temperature profile
C           p_ref = 1013 hPa at z = 0

        RLOG0=LOG(1.013)
        DO J=1,IL
         DO I=1,IX
           SURFG(I,J)=RLOG0+RGAMR*LOG(1.-GAM2*PHIS0(I,J))
         ENDDO
        ENDDO

        CALL SPEC (SURFG,PS)
        IF (IX.EQ.IY*4) CALL TRUNCT (PS)

C       2.4 Set tropospheric spec. humidity in g/kg
C           Qref = RHref * Qsat(288K, 1013hPa)

        ESREF=17.
        QREF=REFRH1*0.622*ESREF
        QEXP=HSCALE/HSHUM

C       Spec. humidity at the surface

        DO J=1,IL
         DO I=1,IX
           SURFG(I,J)=QREF*EXP(QEXP*SURFG(I,J))
         ENDDO
         print *, ' Q0 jlat = ', j, surfg(1,j)
        ENDDO

        CALL SPEC (SURFG,SURFS)
        IF (IX.EQ.IY*4) CALL TRUNCT (SURFS)

C       Spec. humidity at tropospheric levels

        DO K=3,KX
          FACTK=FSG(K)**QEXP
          print *, 'vertical scale factor at level ', k, factk
          DO N=1,NX
           DO M=1,MX
             TR(M,N,K,1,1)=SURFS(M,N)*FACTK
           ENDDO
          ENDDO
        ENDDO

C       Print diagnostics from initial conditions

        CALL DIAGNS (1,0)

      ELSE

C--   3. Start from restart file

        print*,' reading a restart file'

        CALL RESTART (0)

C       Print diagnostics from initial conditions

        CALL DIAGNS (2,0)

      ENDIF

C--
      RETURN
      END


      SUBROUTINE MB02ID( JOB, K, L, M, N, RB, RC, TC, LDTC, TR, LDTR, B,
     $                   LDB, C, LDC, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve the overdetermined or underdetermined real linear systems
C     involving an M*K-by-N*L block Toeplitz matrix T that is specified
C     by its first block column and row. It is assumed that T has full
C     rank.
C     The following options are provided:
C
C     1. If JOB = 'O' or JOB = 'A' :  find the least squares solution of
C        an overdetermined system, i.e., solve the least squares problem
C
C                  minimize || B - T*X ||.                           (1)
C
C     2. If JOB = 'U' or JOB = 'A' :  find the minimum norm solution of
C        the undetermined system
C                   T
C                  T * X = C.                                        (2)
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the problem to be solved as follows
C             = 'O':  solve the overdetermined system (1);
C             = 'U':  solve the underdetermined system (2);
C             = 'A':  solve (1) and (2).
C
C     Input/Output Parameters
C
C     K       (input) INTEGER
C             The number of rows in the blocks of T.  K >= 0.
C
C     L       (input) INTEGER
C             The number of columns in the blocks of T.  L >= 0.
C
C     M       (input) INTEGER
C             The number of blocks in the first block column of T.
C             M >= 0.
C
C     N       (input) INTEGER
C             The number of blocks in the first block row of T.
C             0 <= N <= M*K / L.
C
C     RB      (input) INTEGER
C             If JOB = 'O' or 'A', the number of columns in B.  RB >= 0.
C
C     RC      (input) INTEGER
C             If JOB = 'U' or 'A', the number of columns in C.  RC >= 0.
C
C     TC      (input)  DOUBLE PRECISION array, dimension (LDTC,L)
C             On entry, the leading M*K-by-L part of this array must
C             contain the first block column of T.
C
C     LDTC    INTEGER
C             The leading dimension of the array TC.  LDTC >= MAX(1,M*K)
C
C     TR      (input)  DOUBLE PRECISION array, dimension (LDTR,(N-1)*L)
C             On entry, the leading K-by-(N-1)*L part of this array must
C             contain the 2nd to the N-th blocks of the first block row
C             of T.
C
C     LDTR    INTEGER
C             The leading dimension of the array TR.  LDTR >= MAX(1,K).
C
C     B       (input/output)  DOUBLE PRECISION array, dimension (LDB,RB)
C             On entry, if JOB = 'O' or JOB = 'A', the leading M*K-by-RB
C             part of this array must contain the right hand side
C             matrix B of the overdetermined system (1).
C             On exit, if JOB = 'O' or JOB = 'A', the leading N*L-by-RB
C             part of this array contains the solution of the
C             overdetermined system (1).
C             This array is not referenced if JOB = 'U'.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= MAX(1,M*K),  if JOB = 'O'  or  JOB = 'A';
C             LDB >= 1,           if JOB = 'U'.
C
C     C       (input)  DOUBLE PRECISION array, dimension (LDC,RC)
C             On entry, if JOB = 'U' or JOB = 'A', the leading N*L-by-RC
C             part of this array must contain the right hand side
C             matrix C of the underdetermined system (2).
C             On exit, if JOB = 'U' or JOB = 'A', the leading M*K-by-RC
C             part of this array contains the solution of the
C             underdetermined system (2).
C             This array is not referenced if JOB = 'O'.
C
C     LDC     INTEGER
C             The leading dimension of the array C.
C             LDB >= 1,           if JOB = 'O';
C             LDB >= MAX(1,M*K),  if JOB = 'U'  or  JOB = 'A'.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -17,  DWORK(1)  returns the minimum
C             value of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             Let x = MAX( 2*N*L*(L+K) + (6+N)*L,(N*L+M*K+1)*L + M*K )
C             and y = N*M*K*L + N*L, then
C             if MIN( M,N ) = 1 and JOB = 'O',
C                         LDWORK >= MAX( y + MAX( M*K,RB ),1 );
C             if MIN( M,N ) = 1 and JOB = 'U',
C                         LDWORK >= MAX( y + MAX( M*K,RC ),1 );
C             if MIN( M,N ) = 1 and JOB = 'A',
C                         LDWORK >= MAX( y +MAX( M*K,MAX( RB,RC ),1 );
C             if MIN( M,N ) > 1 and JOB = 'O',
C                         LDWORK >= MAX( x,N*L*RB + 1 );
C             if MIN( M,N ) > 1 and JOB = 'U',
C                         LDWORK >= MAX( x,N*L*RC + 1 );
C             if MIN( M,N ) > 1 and JOB = 'A',
C                         LDWORK >= MAX( x,N*L*MAX( RB,RC ) + 1 ).
C             For optimum performance LDWORK should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction algorithm failed. The Toeplitz matrix
C                   associated with T is (numerically) not of full rank.
C
C     METHOD
C
C     Householder transformations and modified hyperbolic rotations
C     are used in the Schur algorithm [1], [2].
C
C     REFERENCES
C
C     [1] Kailath, T. and Sayed, A.
C         Fast Reliable Algorithms for Matrices with Structure.
C         SIAM Publications, Philadelphia, 1999.
C
C     [2] Kressner, D. and Van Dooren, P.
C         Factorizations and linear system solvers for matrices with
C         Toeplitz structure.
C         SLICOT Working Note 2000-2, 2000.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires O( L*L*K*(N+M)*log(N+M) + N*N*L*L*(L+K) )
C     and additionally
C
C     if JOB = 'O' or JOB = 'A',
C                  O( (K*L+RB*L+K*RB)*(N+M)*log(N+M) + N*N*L*L*RB );
C     if JOB = 'U' or JOB = 'A',
C                  O( (K*L+RC*L+K*RC)*(N+M)*log(N+M) + N*N*L*L*RC );
C
C     floating point operations.
C
C     CONTRIBUTOR
C
C     D. Kressner, Technical Univ. Berlin, Germany, May 2001.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, June 2001.
C     D. Kressner, Technical Univ. Berlin, Germany, July 2002.
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2004,
C     May 2011.
C
C     KEYWORDS
C
C     Elementary matrix operations, Householder transformation, matrix
C     operations, Toeplitz matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         JOB
      INTEGER           INFO, K, L, LDB, LDC, LDTC, LDTR, LDWORK, M, N,
     $                  RB, RC
C     .. Array Arguments ..
      DOUBLE PRECISION  B(LDB,*), C(LDC,*), DWORK(LDWORK), TC(LDTC,*),
     $                  TR(LDTR,*)
C     .. Local Scalars ..
      INTEGER           I, IERR, LEN, NB, NBMIN, PDI, PDW, PNI, PNR,
     $                  PPI, PPR, PT, RNK, WRKMIN, WRKOPT, X, Y
      LOGICAL           COMPO, COMPU, COMPUS, LQUERY
C     .. Local Arrays ..
      INTEGER           IPVT(1)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      EXTERNAL          ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DGELQF, DGELS, DGEMM, DGEQRF, DLACPY, DLASET,
     $                  DORGQR, DTRMM, DTRSM, DTRTRI, MA02AD, MB02CU,
     $                  MB02CV, MB02KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      INFO  = 0
      COMPO = LSAME( JOB, 'O' ) .OR. LSAME( JOB, 'A' )
      COMPU = LSAME( JOB, 'U' ) .OR. LSAME( JOB, 'A' )
      X = MAX( 2*N*L*( L + K ) + ( 6 + N )*L,
     $         ( N*L + M*K + 1 )*L + M*K )
      Y = N*M*K*L + N*L
      IF ( MIN( M, N ).EQ.1 ) THEN
         WRKMIN = MAX( M*K, 1 )
         IF ( COMPO )  WRKMIN = MAX( WRKMIN, RB )
         IF ( COMPU )  WRKMIN = MAX( WRKMIN, RC )
         WRKMIN = MAX( Y + WRKMIN, 1 )
      ELSE
         WRKMIN = X
         IF ( COMPO )  WRKMIN = MAX( WRKMIN, N*L*RB + 1 )
         IF ( COMPU )  WRKMIN = MAX( WRKMIN, N*L*RC + 1 )
      END IF
      WRKOPT = 1
      LQUERY = LDWORK.EQ.-1
C
C     Check the scalar input parameters.
C
      IF ( .NOT.( COMPO .OR. COMPU ) ) THEN
         INFO = -1
      ELSE IF ( K.LT.0 ) THEN
         INFO = -2
      ELSE IF ( L.LT.0 ) THEN
         INFO = -3
      ELSE IF ( M.LT.0 ) THEN
         INFO = -4
      ELSE IF ( N.LT.0 .OR. ( N*L ).GT.( M*K ) ) THEN
         INFO = -5
      ELSE IF ( COMPO .AND. RB.LT.0 ) THEN
         INFO = -6
      ELSE IF ( COMPU .AND. RC.LT.0  ) THEN
         INFO = -7
      ELSE IF ( LDTC.LT.MAX( 1, M*K ) ) THEN
         INFO = -9
      ELSE IF ( LDTR.LT.MAX( 1, K ) ) THEN
         INFO = -11
      ELSE IF ( LDB.LT.1 .OR. ( COMPO .AND. LDB.LT.M*K ) ) THEN
         INFO = -13
      ELSE IF ( LDC.LT.1 .OR. ( COMPU .AND. LDC.LT.M*K ) ) THEN
         INFO = -15
      ELSE
         COMPUS = COMPU
         IF( COMPO .AND. MIN( N*L, RB ).EQ.0 )
     $       COMPO = .FALSE.
         IF( COMPU .AND. MIN( N*L, RC ).EQ.0 )
     $       COMPU = .FALSE.
         IF ( LQUERY ) THEN
            IF ( MIN( M, N ).EQ.1 ) THEN
               PDW = K*L*M*N
               IF ( COMPO ) THEN
                  CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K,
     $                        B, LDB, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               END IF
               IF ( COMPU ) THEN
                  CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C,
     $                        LDC, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               END IF
            ELSE
               IF ( COMPO ) THEN
                  CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB,
     $                         ONE, ZERO, TC, LDTC, TR, LDTR, B, LDB,
     $                         DWORK, N*L, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + N*L*RB )
               END IF
               PDW = ( N*L + M*K )*L
               CALL DGEQRF( M*K, L, DWORK, M*K, DWORK, DWORK, -1, IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L )
               CALL DORGQR( M*K, L, L, DWORK, M*K, DWORK, DWORK, -1,
     $                      IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW + L )
               CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE,
     $                      ZERO, TC, LDTC, TR, LDTR, DWORK, M*K, DWORK,
     $                      N*L, DWORK, -1, IERR )
               WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + PDW )
               PDW = 2*N*L*( L + K )
               CALL DGELQF( N*L, L, DWORK, MAX( 1, N*L ), DWORK, DWORK,
     $                      -1, IERR )
               WRKOPT = MAX( WRKOPT, PDW + 6*L + INT( DWORK(1) ) )
               IF ( COMPU ) THEN
                  CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC,
     $                         ONE, ZERO, TC, LDTC, TR, LDTR, C, LDC,
     $                         DWORK, M*K, DWORK, -1, IERR )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(1) ) + M*K*RC )
               END IF
            END IF
         ELSE IF ( LDWORK.LT.WRKMIN ) THEN
            DWORK(1) = DBLE( WRKMIN )
            INFO = -17
         END IF
      END IF
C
C     Return if there were illegal values.
C
      IF ( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02ID', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( COMPUS .AND. MIN( N*L, RC ).EQ.0 )
     $   CALL DLASET( 'Full', M*K, RC, ZERO, ZERO, C, LDC )
      IF ( .NOT.( COMPO .OR. COMPU ) ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Check cases M = 1 or N = 1.
C
      IF ( MIN( M, N ).EQ.1 ) THEN
         PDW = K*L*M*N
         IF ( COMPO ) THEN
            CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K )
            CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1),
     $                   M*K )
            CALL DGELS( 'NonTranspose', M*K, N*L, RB, DWORK, M*K, B,
     $                  LDB, DWORK(PDW+1), LDWORK-PDW, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW )
         END IF
         IF ( COMPU ) THEN
            CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK, M*K )
            CALL DLACPY( 'All', K, (N-1)*L, TR, LDTR, DWORK(K*L+1),
     $                   M*K )
            CALL DGELS( 'Transpose', M*K, N*L, RC, DWORK, M*K, C, LDC,
     $                  DWORK(PDW+1), LDWORK-PDW, IERR )
            WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+1) ) + PDW )
         END IF
         DWORK(1) = DBLE( WRKOPT )
         RETURN
      END IF
C
C     Step 1:  Compute the generator.
C
      IF ( COMPO ) THEN
         CALL MB02KD( 'Column', 'Transpose', K, L, M, N, RB, ONE, ZERO,
     $                TC, LDTC, TR, LDTR, B, LDB, DWORK, N*L,
     $                DWORK(N*L*RB+1), LDWORK-N*L*RB, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(N*L*RB+1) ) + N*L*RB )
         CALL DLACPY( 'All', N*L, RB, DWORK, N*L, B, LDB )
      END IF
C
      PDW = N*L*L + 1
      CALL DLACPY( 'All', M*K, L, TC, LDTC, DWORK(PDW), M*K )
      CALL DGEQRF( M*K, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L),
     $             DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) +
     $                      PDW + (M*K+1)*L - 1 )
C
      DO 10  I = PDW, PDW + M*K*L - 1, M*K + 1
         IF ( DWORK(I).EQ.ZERO ) THEN
            INFO = 1
            RETURN
         END IF
   10 CONTINUE
C
      CALL MA02AD( 'Upper', L, L, DWORK(PDW), M*K, DWORK, N*L )
      CALL DORGQR( M*K, L, L, DWORK(PDW), M*K, DWORK(PDW+M*K*L),
     $             DWORK(PDW+(M*K+1)*L), LDWORK-PDW-(M*K+1)*L-1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+(M*K+1)*L) ) +
     $                      PDW + (M*K+1)*L - 1 )
      CALL MB02KD( 'Row', 'Transpose', K, L, M, N-1, L, ONE, ZERO,
     $              TC, LDTC, TR, LDTR, DWORK(PDW), M*K, DWORK(L+1),
     $              N*L, DWORK(PDW+M*K*L), LDWORK-PDW-M*K*L+1, IERR )
      WRKOPT = MAX( WRKOPT, INT( DWORK(PDW+M*K*L) ) + PDW + M*K*L - 1 )
      PPR = N*L*L + 1
      PNR = N*L*( L + K ) + 1
      CALL MA02AD( 'All', K, (N-1)*L, TR, LDTR, DWORK(PPR+L), N*L )
      CALL DLACPY( 'All', (N-1)*L, L, DWORK(L+1), N*L, DWORK(PNR+L),
     $             N*L )
      PT  = ( M - 1 )*K + 1
      PDW = PNR + N*L*L + L
C
      DO 30  I = 1, MIN( M, N-1 )
         CALL MA02AD( 'All', K, L, TC(PT,1), LDTC, DWORK(PDW), N*L )
         PT  = PT  - K
         PDW = PDW + L
   30 CONTINUE
C
      PT = 1
C
      DO 40  I = M + 1, N - 1
         CALL MA02AD( 'All', K, L, TR(1,PT), LDTR, DWORK(PDW), N*L )
         PT  = PT  + L
         PDW = PDW + L
   40 CONTINUE
C
      IF ( COMPO ) THEN
C
C        Apply the first reduction step to T'*B.
C
         CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit',
     $               L, RB, ONE, DWORK, N*L, B, LDB )
         CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RB, L, ONE,
     $               DWORK(L+1), N*L, B, LDB, -ONE, B(L+1,1), LDB )
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L,
     $               RB, ONE, DWORK, N*L, B, LDB )
      END IF
C
      IF ( COMPU ) THEN
C
C        Apply the first reduction step to C.
C
         CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit',
     $               L, RC, ONE, DWORK, N*L, C, LDC )
         CALL DGEMM( 'NoTranspose', 'NoTranspose', (N-1)*L, RC, L, ONE,
     $               DWORK(L+1), N*L, C, LDC, -ONE, C(L+1,1), LDC )
         CALL DTRSM( 'Left', 'Lower', 'Transpose', 'NonUnit', L,
     $               RC, ONE, DWORK, N*L, C, LDC )
      END IF
C
      PDI = ( N - 1 )*L + 1
      CALL DLACPY( 'Lower', L, L, DWORK, N*L, DWORK(PDI), N*L )
      CALL DTRTRI( 'Lower', 'NonUnit', L, DWORK(PDI), N*L, IERR )
      CALL MA02AD( 'Lower', L-1, L, DWORK(PDI+1), N*L,
     $             DWORK((2*N-1)*L+1), N*L )
      CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PDI+1), N*L )
      CALL DLACPY( 'Upper', L, L, DWORK(PDI), N*L, DWORK(PNR), N*L )
      CALL DLASET( 'Lower', L-1, L, ZERO, ZERO, DWORK(PNR+1), N*L )
      CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PPR), N*L )
      CALL DLASET( 'All', L, K, ZERO, ZERO, DWORK(PNR+N*L*L), N*L )
C
      PPI = PPR
      PPR = PPR + L
      PNI = PNR
      PNR = PNR + L
      PDW = 2*N*L*( L + K ) + 1
      LEN = ( N - 1 )*L
C
C     Determine block size for the involved block Householder
C     transformations.
C
      NB    = MIN( ( LDWORK - PDW - 6*L + 1 ) / ( N*L ), L )
      NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', N*L, L, -1, -1 ) )
      IF ( NB.LT.NBMIN )  NB = 0
C
      DO 50  I = L + 1, N*L, L
         CALL MB02CU( 'Column', L, L+K, L+K, NB, DWORK, N*L, DWORK(PPR),
     $                N*L, DWORK(PNR), N*L, RNK, IPVT, DWORK(PDW), ZERO,
     $                DWORK(PDW+6*L), LDWORK-PDW-6*L+1, IERR )
         IF ( IERR.NE.0 )  THEN
C
C           Error return:  The rank condition is (numerically) not
C                          satisfied.
C
            INFO = 1
            RETURN
         END IF
         CALL MB02CV( 'Column', 'NoStructure', L, LEN-L, L+K, L+K, NB,
     $                -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L,
     $                DWORK(L+1), N*L, DWORK(PPR+L), N*L, DWORK(PNR+L),
     $                N*L, DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1,
     $                IERR )
         PDI = PDI - L
         IF ( COMPO ) THEN
C
C           Block Gaussian elimination to B.
C
            CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit',
     $                  L, RB, -ONE, DWORK, N*L, B(I,1), LDB )
            IF ( LEN.GT.L ) THEN
               CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RB, L,
     $                     ONE, DWORK(L+1), N*L, B(I,1), LDB, ONE,
     $                     B(I+L,1), LDB )
            END IF
         END IF
         IF ( COMPU ) THEN
C
C           Block Gaussian elimination to C.
C
            CALL DTRSM( 'Left', 'Lower', 'NonTranspose', 'NonUnit',
     $                  L, RC, -ONE, DWORK, N*L, C(I,1), LDC )
            IF ( LEN.GT.L ) THEN
               CALL DGEMM( 'NonTranspose', 'NonTranspose', LEN-L, RC, L,
     $                     ONE, DWORK(L+1), N*L, C(I,1), LDC, ONE,
     $                     C(I+L,1), LDC )
            END IF
         END IF
         CALL DLASET( 'All', L, L, ZERO, ZERO, DWORK(PDI), N*L )
         CALL MB02CV( 'Column', 'Triangular', L, I+L-1, L+K, L+K, NB,
     $                -1, DWORK, N*L, DWORK(PPR), N*L, DWORK(PNR), N*L,
     $                DWORK(PDI), N*L, DWORK(PPI), N*L, DWORK(PNI), N*L,
     $                DWORK(PDW), DWORK(PDW+6*L), LDWORK-PDW-6*L+1,
     $                IERR )
         IF ( COMPO ) THEN
C
C           Apply block Gaussian elimination to B.
C
            CALL DGEMM( 'NoTranspose', 'NoTranspose', I-1, RB, L, ONE,
     $                  DWORK(PDI), N*L, B(I,1), LDB, ONE, B, LDB )
            CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L,
     $                  RB, ONE, DWORK((N-1)*L+1), N*L, B(I,1), LDB )
         END IF
         IF ( COMPU ) THEN
C
C           Apply block Gaussian elimination to C.
C
            CALL DGEMM( 'NonTranspose', 'NonTranspose', I-1, RC, L, ONE,
     $                  DWORK(PDI), N*L, C(I,1), LDC, ONE, C, LDC )
            CALL DTRMM( 'Left', 'Upper', 'NonTranspose', 'NonUnit', L,
     $                  RC, ONE, DWORK((N-1)*L+1), N*L, C(I,1), LDC )
         END IF
         LEN = LEN - L
         PNR = PNR + L
         PPR = PPR + L
   50 CONTINUE
C
      IF ( COMPU ) THEN
         CALL MB02KD( 'Column', 'NonTranspose', K, L, M, N, RC, ONE,
     $                ZERO, TC, LDTC, TR, LDTR, C, LDC, DWORK, M*K,
     $                DWORK(M*K*RC+1), LDWORK-M*K*RC, IERR )
         WRKOPT = MAX( WRKOPT, INT( DWORK(M*K*RC+1) ) + M*K*RC )
         CALL DLACPY( 'All', M*K, RC, DWORK, M*K, C, LDC )
      END IF
      DWORK(1) = DBLE( WRKOPT )
      RETURN
C
C *** Last line of MB02ID ***
      END


program FD_hMetal
use FD_hMetal_mod
use PhreeqcRM
implicit none

! ==============================================================================
!                           SIMULATION PARAMETERS
! ==============================================================================
integer, parameter          :: nthreads = 0
    ! number of OpenMP threads for reaction module. <= 0 implies the number of
    ! threads equals the number of processors of the computer
double precision, parameter :: maxtime = 1.577d8 ! 5 years = 1.577d8 seconds
double precision, parameter :: Omega = 0.4d0 ! length of domain [m]
double precision, parameter :: dx = 1d-2 ! spatial discretization parameter
integer, parameter          :: ncell = nint(Omega/dx)
    ! number of chemistry cells
    ! subtract 1 because won't be calculating chemistry for boundary cell
integer, parameter          :: ntrans = ncell + 1
    ! number of cells for transport
double precision, parameter :: dt = 25920.0_dp ! time step [s] (25920 seconds = 0.3 days)
integer, parameter          :: nsteps = nint(maxtime/dt) ! number of time steps
double precision, parameter :: save_dt = dt * 1e3_dp
integer, parameter          :: save_steps = nint(maxtime/(save_dt)) + 1
    ! time step for saving concentrations for plotting and number of writes to be done

! ==============================================================================
!                           PHYSICAL PARAMETERS
! ==============================================================================
double precision, parameter        :: porosity = 0.47d0 ! porosity
double precision, parameter        :: init_D = 4.27e-10 ! effective diffusion coefficient
double precision                   :: D(ntrans - 1) = init_D
    ! vectors for diffusion coefficient

! ==============================================================================
!                       GENERAL/PHREEQCRM VARIABLES
! ==============================================================================

double precision, dimension(ncell) :: den_0, prs_0, tmp_0, sat_0, por_0, vol_0
double precision                   :: cur_time
integer                            :: i, j, m, id, status, ngrd
integer                            :: ncomp, nchem, so_col
integer                            :: ic1(ncell, 7)
integer, dimension(ncell)          :: mask
double precision, allocatable      :: bc_conc(:, :), comp_conc(:, :),&
                                      sout(:, :), concs(:, :),&
                                      fig3_plot_concs(: , :), fig4_plot_concs(: , :),&
                                      plot_times(:)
integer                            :: bc1(1) ! this is for one boundary condition

! ==============================================================================
!                             READ/WRITE VARIABLES
! ==============================================================================

integer, parameter      :: fig3_numel = 7
integer                 :: fig3_elements(fig3_numel)
integer, parameter      :: fig3Plot_unit = 12
character(*), parameter :: fig3Plot_name = 'fig3_concs.txt'

integer, parameter      :: fig4_numel = 3
integer                 :: fig4_elements(fig4_numel)
integer, parameter      :: fig4Plot_unit = 14
character(*), parameter :: fig4Plot_name = 'fig4_concs.txt'

! ==============================================================================
!                             DEBUGGING VARIABLES
! ==============================================================================

! integer                           :: so_row

! ! use these to get the selected output headings
! character(50)                     :: tempname
! type(selectout_list), allocatable :: head_list(:)

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

cur_time = 0.0d0

! print some summary info, to begin with
print *, '======================================='
print *, 'CFL = ', (init_D / porosity * dt) / dx**2
print *, '1.0d0 / dx = ', 1.0d0 / dx
print *, 'dt = ', dt
print *, 'ncell (chemistry) = ', ncell
print *, '======================================='

! ==============================================================================
!                   DEFINE PHYSICAL CONDITIONS (for PHREEQCRM)
! ==============================================================================
den_0 = 1.0d0 ! Density
prs_0 = 0.986923d0 ! Pressure 98.6923 atm = 100 bar
tmp_0 = 25.0d0 ! Temperature
sat_0 = 1.0d0 ! Saturation
por_0 = porosity ! Porosity
vol_0 = 1.0d0

! print chemistry mask to print detailed output (headings) for only first element
mask = 0
mask(1) = 1

id = RM_Create(ncell, nthreads)
! local database location
! location of file when running from main directory
status = RM_LoadDatabase(id, './phreeqc_files/PHREEQC-database.txt')
if (status < 0) then
    print *, 'Database Load Error'
    call exit(status)
endif

! initialize all the settings for the reaction module
status = RM_OpenFiles(id)
status = RM_SetRepresentativeVolume(id, vol_0)
status = RM_SetSaturation(id, sat_0)
status = RM_SetPorosity(id, por_0)
status = RM_SetTime(id, cur_time)
! *** DON'T set the time step here, so it doesn't take a step for the IC ****
! status = RM_SetTimeStep(id, dt)
status = RM_SetDensity(id, den_0)
status = RM_SetTemperature(id, tmp_0)
status = RM_SetPressure(id, prs_0)
status = RM_SetSelectedOutputOn(id, 1) ! turn on selected output
status = RM_SetUnitsSolution(id, 2) ! 2 = mol/L
status = RM_SetUnitsPPassemblage(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsKinetics(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsExchange(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsSurface(id, 0) ! 0 = mol/L of representative volume
status = RM_SetUnitsSSassemblage(id, 1) ! 1 = mol/L of representative volume
status = RM_SetPrintChemistryMask(id, mask)
! status = RM_SetPrintChemistryOn(id, 0, 0, 0) ! this toggles detailed output about reaction calculations
status = RM_SetPrintChemistryOn(id, 1, 1, 1) ! this toggles detailed output about reaction calculations
status = RM_SetScreenOn(id, 0) ! turn off messages about rebalancing
status = RM_SetComponentH2O(id, 1)
    ! 0 implies that H2O is not given as a separate component--just H and O
    ! 1 is default with H2O as separate component
! location of file when running from main directory
status = RM_RunFile(id, 1, 1, 1, './phreeqc_files/PHREEQC-Case1-Input.txt')

! the following isn't strictly necessary if you already know what your problem
! looks like, but it's quick and only done once.

ncomp = RM_FindComponents(id)
write (*, *) 'ncomp = ', ncomp
! get number of grid cells in model (this can change, so it needs to be checked)
ngrd = RM_GetGridCellCount(id)
if (ngrd /= ncell) then
    print *, '****** Cell count differs from particle number ******'
    call exit(status)
endif

nchem = RM_GetChemistryCellCount(id)
if (nchem /= ncell) then
    print *, '****** Chem count differs from particle number ******'
    call exit(status)
endif

! ==============================================================================
!                       INITIAL/BOUNDARY CONDITIONS
! ==============================================================================
! ===  (1) SOLUTIONS, (2) EQUILIBRIUM_PHASES, (3) EXCHANGE,
! ===  (4) SURFACE, (5) GAS_PHASE, (6) SOLID_SOLUTIONS, and (7) KINETICS

ic1 = -1
ic1(:, 1) = 1
ic1(:, 2) = 1
ic1(:, 4) = 1
ic1(:, 7) = 1

allocate(bc_conc(1, ncomp))
    ! must be 2D array for module--requires singleton dimension in this case
bc1 = 0 ! corresponds to solution zero in input file

status = RM_InitialPhreeqc2Module(id, ic1)
! ==============================================================================

! the following commented blocks will give you the names of the components and
! headings for selected output.
! They are left here purely for reference, and will not run unless you
! instantiate the corresponding variables.

! ! this makes a list of the names of components
! allocate(comp_list(ncomp))
! ! print *, 'ncomp = ', ncomp
! do i = 1, ncomp
!     status = RM_GetComponent(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: comp_list(i)%comp)
!     comp_list(i)%comp = trim(tempname)
!     print *, comp_list(i)%comp
! enddo

status = RM_RunCells(id)

! so_col = RM_GetSelectedOutputcolumncount(id)
! so_row = RM_GetSelectedOutputrowcount(id)
! allocate(sout(so_row, so_col))
! status = RM_GetSelectedOutput(id, sout)

! ! this makes a list of the names of selected output elements
! allocate(head_list(so_col))
! do i = 1, so_col
!     status = RM_GetSelectedOutputheading(id, i, tempname)
!     allocate(character(len_trim(tempname)) :: head_list(i)%head)
!     head_list(i)%head = trim(tempname)
!     print *, head_list(i)%head
! enddo

! get ion concentrations from the reaction module
allocate(comp_conc(ncell, ncomp))
status = RM_GetConcentrations(id, comp_conc)
status = RM_InitialPhreeqc2Concentrations(id, bc_conc, 1, bc1)

! ==============================================================================
!               SELECTED OUTPUT (based on the PHREEQC input file)
! ==============================================================================

! the names of the fields in sOut can be found in the file: sOut_fields.txt

! assign the indices of sOut that will be used for re-creating Fig. 3 of Arora, et al.
! These are: pH, Alkalinity, N(5), Sulfate, Feii, Pb
fig3_elements = (/ 7, 50, 10, 14, 12, 40, 28 /)

! assign the indices of sOut that will be used for re-creating Fig. 4 of Arora, et al.
! These are: Ferrihydrite, FeS, and Siderite
fig4_elements = (/ 21, 22, 23  /)

! ==============================================================================
!        CONCS (what is being transported and given to the reaction module)
! ==============================================================================
! dimension of concs is ntrans (# chemistry cells + 1 for boundary) x ncomp

! For this specific problem:

! If (RM_SetComponentH2O(id, 0)):
! (1) H, (2) O, (3) Charge, (4) Acetate, (5) C, (6) Ca, (7) Cl, (8) Fe, (9) Feii,
! (10) K, (11) Mg, (12) N, (13) Na, (14) Naq, (15) Oxy, (16) Pb, (17) S,
! (18) Sulfate, (19) Zn

! If (RM_SetComponentH2O(id, 1)):
! (1) H2O, (2) H, (3) O, (4) Charge, (5) Acetate, (6) C, (7) Ca, (8) Cl, (9) Fe,
! (10) Feii, (11) K, (12) Mg, (13) N, (14) Na, (15) Naq, (16) Oxy, (17) Pb,
! (18) S, (19) Sulfate, (20) Zn

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

so_col = RM_GetSelectedOutputcolumncount(id)

allocate(sout(ncell, so_col))

status = RM_GetSelectedOutput(id, sout)

allocate(concs(ntrans, ncomp), fig3_plot_concs(ncell, fig3_numel + 1),&
               fig4_plot_concs(ncell, fig4_numel), plot_times(save_steps))

! use phreeqc-generated boundary condition
concs(1, :) = bc_conc(1, :)
concs(2 : ntrans, :) = comp_conc

fig3_plot_concs(:, 1 : fig3_numel) = sOut(:, fig3_elements)
fig3_plot_concs(:, fig3_numel + 1) = concs(2 : ntrans, 6)

fig4_plot_concs(:, :) = sOut(:, fig4_elements)

plot_times = (/((i - 1) * save_dt, i = 1, save_steps)/)

! this is the file that stores what comes from fig3_plot_concs
! the header gives the shape of the full array and the number of time steps
open (unit = fig3Plot_unit, file = fig3Plot_name, action = 'write')
write (fig3Plot_unit, *) shape(fig3_plot_concs), save_steps
write (fig3Plot_unit, *) fig3_plot_concs
close (unit = fig3Plot_unit, status = 'keep')

open (unit = fig4Plot_unit, file = fig4Plot_name, action = 'write')
write (fig4Plot_unit, *) shape(fig4_plot_concs), save_steps
write (fig4Plot_unit, *) fig4_plot_concs
close (unit = fig4Plot_unit, status = 'keep')

! *** set the time step here, so it doesn't take a step for the IC ****
status = RM_SetTimeStep(id, dt)

! counter for plot_times
j = 2

! time stepping loop
do m = 1, nsteps

    print *, 'step = ', m, ' of ', nsteps

    call diffuse(concs(:, :), D, dx, dt, porosity, ntrans)

    cur_time = cur_time + dt
    status = RM_SetTime(id, cur_time)
    comp_conc = concs(2 : ntrans, :)
    status = RM_SetConcentrations(id, comp_conc)
    status = RM_RunCells(id)
    status = RM_GetConcentrations(id, comp_conc)
    concs(2 : ntrans, :) = comp_conc

    if (cur_time >= plot_times(j)) then
        status = RM_GetSelectedOutput(id, sout)

        fig3_plot_concs(:, 1 : fig3_numel) = sOut(:, fig3_elements)
        fig3_plot_concs(:, fig3_numel + 1) = concs(2 : ntrans, 6)
        fig4_plot_concs(:, :) = sOut(:, fig4_elements)

        open (unit = fig3Plot_unit, file = fig3Plot_name, action = 'write',&
              status = 'old', access = 'append')
        write (fig3Plot_unit, *) fig3_plot_concs
        close (unit = fig3Plot_unit, status = 'keep')
        open (unit = fig4Plot_unit, file = fig4Plot_name, action = 'write',&
              status = 'old', access = 'append')
        write (fig4Plot_unit, *) fig4_plot_concs
        close (unit = fig4Plot_unit, status = 'keep')

        j = j + 1
    endif

enddo

status = RM_Destroy(id)
deallocate(concs, fig3_plot_concs, plot_times, sout, comp_conc, bc_conc)

end program FD_hMetal


SUBROUTINE gammas(incx,mu,sig,omega)

!-------------------------------------------------------------
!
! Compute gamma elements from known analytic form of gamma
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
INTEGER, INTENT(IN) :: incx
INTEGER :: bigl, l, ll, lmm, lpm, indx, fact
REAL*8, INTENT(IN) :: mu, sig, omega
REAL*8 :: alf, plm2, plm1, pl, plm1m, plm, plmp1, she, sho, clm
REAL*8, DIMENSION(0:sord-1) :: al, oal
REAL*8, DIMENSION(4,4) :: amat
REAL*8, DIMENSION(4,(nmom+3)) :: bmat, gmat

bigl = sord - 1

! Initialize matrix values
amat = 0.0
bmat = 0.0
gmat = 0.0

! Set the elements of bmat
! Elements from the balance equation
plm1 = 0.0
pl = 1.0
DO l = 0, bigl
   al = 0.0      ! Initialize
   IF (l /= 0) CALL legpoly(l,incx,mu,plm2,plm1,pl)
   al(0) = pl
   indx = l**2 + 1
   bmat(1,indx) = SQRT(2.0*l + 1.0)*pl       ! l0 moment
   DO ll = 1, l                              ! lm moments
      plm1m = oal(ll-1)
      plm   = al(ll-1)
      CALL aslegf(l,ll,incx,mu,plm1m,plm,plmp1)
      al(ll) = plmp1
      lmm = l - ll
      lpm = l + ll
      clm = (2.0*l + 1.0)*REAL(fact(lmm))/REAL(fact(lpm))
      she = 2.0*SQRT(clm)*al(ll)*COS(ll*omega)
      sho = 2.0*SQRT(clm)*al(ll)*SIN(ll*omega)
      ! Now have the odd and even values, can set in bmat
      indx = l**2 + 2*ll
      bmat(1,indx) = she
      bmat(1,indx+1) = sho
   END DO
   ! Reset values
   plm2 = plm1
   plm1 = pl
   oal = al
END DO

! Elements corresponding to the incoming
bmat(1,nmom+1) = ez
bmat(1,nmom+2) = ey
bmat(1,nmom+3) = ex

! Elements corresponding to the DD relations
bmat(2,nmom+1) = 1.0
bmat(3,nmom+2) = 1.0
bmat(4,nmom+3) = 1.0

! Set the elements of the inverted amat directly since it's only 4x4
alf = 1.0/(sig+2.0*ez+2.0*ey+2.0*ex)
amat(1,1) = alf
amat(2,1) = alf*2.0
amat(3,1) = amat(2,1)
amat(4,1) = amat(2,1)

amat(1,2) = alf*ez
amat(2,2) = alf*(-sig-2.0*ey-2.0*ex)
amat(3,2) = 2.0*amat(1,2)
amat(4,2) = amat(3,2)

amat(1,3) = alf*ey
amat(2,3) = 2.0*amat(1,3)
amat(3,3) = alf*(-sig-2.0*ez-2.0*ex)
amat(4,3) = amat(2,3)

amat(1,4) = alf*ex
amat(2,4) = 2.0*amat(1,4)
amat(3,4) = amat(2,4)
amat(4,4) = alf*(-sig-2.0*ez-2.0*ey)

! Form gmat as the product of inverted amat and bmat
gmat = MATMUL(amat,bmat)

! Store the gmat elements
! Set the gaa from gmat, first equation, first nmom equations
gaa = gmat(1,1:nmom)
! Set gaxy, gaxz, & gayz from gmat, first equation, last 3 elements
gaxy = gmat(1,nmom+1)
gaxz = gmat(1,nmom+2)
gayz = gmat(1,nmom+3)
! Set gxya, gxza, & gyza from gmat, last 3 equations, first nmom equations of each
gxya = gmat(2,1:nmom)
gxza = gmat(3,1:nmom)
gyza = gmat(4,1:nmom)
! Set the gxy**, gxz**, gyz** from gmat, bottom right 3x3 corner
gxyxy = gmat(2,nmom+1)
gxzxy = gmat(3,nmom+1)
gyzxy = gmat(4,nmom+1)
gxyxz = gmat(2,nmom+2)
gxzxz = gmat(3,nmom+2)
gyzxz = gmat(4,nmom+2)
gxyyz = gmat(2,nmom+3)
gxzyz = gmat(3,nmom+3)
gyzyz = gmat(4,nmom+3)

RETURN
END SUBROUTINE gammas


SUBROUTINE force_par
USE PARACLUSTER
USE CLUSTER    !module where cluster variables and parameters are defined
USE POTENTIAL
USE ENFORCE
USE DISTANCE
!
IMPLICIT NONE
INTRINSIC sqrt
INTEGER :: nat3d,i,k
REAL :: delta,ermi,mik,dmik,fik,dfik,wik,dwik,vik
REAL :: xik,yik,zik
REAL :: dik0,dik,rik,rik2,rik23
REAL :: pmorse,eneri,wtot
REAL,ALLOCATABLE  :: fDx(:),fDy(:),fDz(:)
!
!
!      common/bimW/C6,C8,C10,C12
!      common/bimF/dmu,delta
!      common/bimM/dM0,DIST0,tau
!
       ! parameters dmu, delta which compare in Fermi-type potential
       !F(x)= {1+ exp(x-mu)/delta}**(-1)
!        parameter(dmu0=10.05d0)
!        parameter(delta0=1.04d0)=epsilon

        ! dM0, tau, DIST0  which compare in Morse potential
        ! M(x)=dM0*(exp(tau*(1-x/DIST0)){exptau*(1-x/DIST0)-2})
!        parameter(dM00=0.3d0)
!        parameter(tau0=9.75d0)
!        parameter(DIST00=10.3d0)

        ! parameters of van der Waal part
        !W(x)= - (C6/x**6 + C8/x**8 + C10/x**10 + C12/x**12)
!        parameter(C60=75600.d0)
!        parameter(C80=9122400.d0)
!        parameter(C100=2.09d8)
!        parameter(C120=7.78d10)

! pay attention to the units: in fact,
! we have all the routine which calculates the velocities and the positions
! on eV (for energy!) and on units of arete (for position!)
! Doye considers energy in eV BUT position in A
! the parameters are in eV and angstrom

      ! for C60 cluster => PR potential
      ener=0.d0
      eneri=0.d0
      delta=epsilon
      dik0=dist(1)  !! distanza in arete ai NN
      nat3d=natom

ALLOCATE(fDx(nat3d),fDy(nat3d),fDz(nat3d))
! conservo i vecchi valori della forza in dfx,dfy,dfz
      DO i=1,nat3d
       dfx(i)=fx(i)
       dfy(i)=fy(i)
       dfz(i)=fz(i)
      ENDDO
      DO i=1,nat3d
        fx(i)=0.d0
        fy(i)=0.d0
        fz(i)=0.d0
        fDx(i)=0.d0
        fDy(i)=0.d0
        fDz(i)=0.d0
      ENDDO

!! part of PR: E=(1-F(x))*M(x)+F(x)*W(x)
        !W(x)= - (C6/x**6 + C8/x**8 + C10/x**10 + C12/x**12)
        !F(x)= {1+ exp(x-mu)/delta}**(-1)
        ! M(x)=dM0*(exp(tau*(1-x/DIST0)){exptau*(1-x/DIST0)-2})

!       print*,tau, DIST0, dmu, dM0, delta, C6, C8, C10, C12
  DO i=1,nat3d
    DO k=1+i,nat3d

          xik=x(k)+u(k)-x(i)-u(i)
          yik=y(k)+v(k)-y(i)-v(i)
          zik=z(k)+w(k)-z(i)-w(i)

          dik=sqrt(xik*xik+yik*yik+zik*zik)   !in unita' di arete
          rik=aretebim*dik                        !in A
          rik2=rik*rik
          rik23=rik2**3.d0

 !!calcolo ora le forze come Doye in eV e A
 !!poi devo passare le forze in unita' eV e arete
 !! f(i) per noi= f(i)( in eV/A)*10.05*rac2  !!

         ermi=EXP((rik-dmu)/delta)
         fik=1.d0/(1.d0+ermi)
         dfik=-ermi/(delta*(1.d0+ermi)*(1.d0+ermi))

         pmorse=EXP(tau*(1.d0-rik/DIST0))
!         write(*,*) dM0, 'who am i '
         mik=dM0*pmorse*(pmorse-2.d0)
!         write(*,*) mik,'mik for i',i,'and k',k
         dmik=(2.d0*tau*dM0*pmorse*(1.d0-pmorse))/DIST0
         wik=-(C6+(C8+(C10+C12/rik2)/rik2)/rik2)/rik23
         dwik=(6*C6+(8*C8+(10*C10+12*C12/rik2)/rik2)/rik2)/(rik*rik23)

    ! this is the potential

         vik=fik*mik+(1.d0-fik)*wik
         ener=ener+vik
         eneri=eneri+fik*mik  !! in eV

!         print*,i, k, rik, vik
! this is the force  in eV/A

         wtot=mik*dfik+fik*dmik+(1.d0-fik)*dwik-dfik*wik
         wtot=-wtot

              fDx(i)=fDx(i)-aretebim*xik*wtot/rik
              fDy(i)=fDy(i)-aretebim*yik*wtot/rik
              fDz(i)=fDz(i)-aretebim*zik*wtot/rik

              fDx(k)=fDx(k)+aretebim*xik*wtot/rik
              fDy(k)=fDy(k)+aretebim*yik*wtot/rik
              fDz(k)=fDz(k)+aretebim*zik*wtot/rik

        !fx(k)=fDx(k)*arete
        !fy(k)=fDy(k)*arete
        !fz(k)=fDz(k)*arete

ENDDO !su k

        fx(i)=fDx(i)*aretebim
        fy(i)=fDy(i)*aretebim
        fz(i)=fDz(i)*aretebim
        ener=eneri
!!        forza=dsqrt(fx(i)**2+fy(i)**2+fz(i)**2)
ENDDO
DEALLOCATE(fDx,fDy,fDz)

END SUBROUTINE force_par