! (C) Copyright 1996-2016 ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation nor
! does it submit to any jurisdiction.
!

      PROGRAM cospe
      INTEGER, PARAMETER :: NENS = 51
      INTEGER            :: I,iretI,iretR,Nlines,KKHOUR,KYEAR1,KMON1,KDAY1,KHOUR1
      INTEGER, DIMENSION(:), ALLOCATABLE :: KPF,KDAT,KHOUR,KFFF,KMSL,IWRK
      INTEGER, DIMENSION(:,:), ALLOCATABLE :: ICSTORM
      REAL   , DIMENSION(:), ALLOCATABLE :: XLAT,XLON,X5PBOX,X5PBOX2
      REAL   , DIMENSION(:,:), ALLOCATABLE :: Z5PBOX,Z5PBOX2,ZMXFFF
      REAL               :: RADIUS,MAP(720,361),TMAP(720,361),xminlat,xminlon,xmaxlat,xmaxlon
      REAL               :: XLATPF(80,NENS+1),XLONPF(80,NENS+1),XMSLP(80,NENS+1),XFFF(80,NENS+1),ZRES(5)
      CHARACTER          :: CPORRA*4

      RADIUS=120. ! in km
      XLATPF=-999.
      XLONPF=-999.
      XMSLP =-999.
      XFFF  =-999.
      KYEAR=2011
      KMON =3
      KDAY =31
      KKHOUR=0
      KSTEP=144
      KDAYINCR=KSTEP/24

! Compute the forecast lead datetime

      CALL DAYINCR (KYEAR, KMON, KDAY, KDAYINCR, INYEAR, INMON, INDAY, IRET)
      IF (IRET.NE.0) THEN
         STOP 'PROBLEMS WITH DAYINCR ROUTINE (ECLIB) '
      END IF
      KBASETIME =KYEAR*10000+KMON*100+KDAY
      KFCDATE   =INYEAR*10000+INMON*100+INDAY      ! HARDCODDED
      PRINT*, INYEAR, INMON, INDAY,KFCDATE
!      STOP

      OPEN(10,file="msl_25U_25U_2011033100")
      I=1
      DO
        READ(10,*,END = 20)

        I = I +1

      END DO
 20   CONTINUE
      NLINES = I-1

      !	allocate memory

      ALLOCATE(KPF  (Nlines))
      ALLOCATE(KDAT (Nlines))
      ALLOCATE(KHOUR(Nlines))
      ALLOCATE(KFFF (Nlines))
      ALLOCATE(KMSL (Nlines))
      ALLOCATE(XLAT (Nlines))
      ALLOCATE(XLON (Nlines))
      print*,i,iretI,iretR
!      CLOSE(10)
!      open(10,file="/home/mo/moo/FVitart/source/NewProducts/mc0/msl_25U_25U_2011033100")
      REWIND (10)
      DO I=1,Nlines
       READ(10,*,END = 40) XLAT(I),XLON(I),KPF(I),KDAT(I),KHOUR(I),KFFF(I),KMSL(I)

      END DO
 40   CONTINUE
      ! Go through the ensemble members and HiRes (==52)
	  ! and compute the strike probability field from individual tracks; RADIUS is set to 120km
      DO I=1, NENS
         MAP=0.
         !K1=1
         DO K=1, NLINES

            KYEAR1=KDAT(K)/10000
            KMON1 =(KDAT(K)-KYEAR1*10000)/100
            KDAY1 =(KDAT(K)-KYEAR1*10000)-KMON1*100

            CALL HOURDIFF(KYEAR1,KMON1,KDAY1,KHOUR(K)/100,KYEAR,KMON,KDAY,KKHOUR,IHOURS,IRET)

            IF ( KPF(K) == I .and. (IHOURS.GE.0.AND.IHOURS.LE.KSTEP)) THEN!KDAT(K) <= KFCDATE) THEN     ! CHANGE !!!!!!!!!!!!!!!!!!!!

               K1=IHOURS/6 + 1                     ! HARDCODDED (EPS must be defined every 6 hours)

               ii=int(XLON(K))/0.5+1
               jj=(90-int(XLAT(K)))/0.5+1
               do ii0=-10,10
                 do jj0=-10,10
                   xlon0=((ii+ii0)-1)*0.5
                   xlat0=90-((jj+jj0)-1)*0.5

                   call GreatCircleDistance(XLON(K),XLAT(K),xlon0,xlat0,xdist)

                   if (xdist.le.RADIUS) then
                      map(ii+ii0,jj+jj0)=map(ii+ii0,jj+jj0)+1
                   endif
                 enddo
               enddo
               XLATPF(K1,I)=XLAT(K)
               XLONPF(K1,I)=XLON(K)
               XMSLP (K1,I)=FLOAT(KMSL(K))
               XFFF  (K1,I)=FLOAT(KFFF(K))
               !K1 = K1 + 1
            END IF
         END DO
         DO I1=1,720
            DO J=1,361
               IF (MAP(I1,J).GE.1) THEN
                  TMAP(I1,J)=TMAP(I1,J)+100/51.
               ENDIF
            ENDDO
         ENDDO
      END DO

! Include the HiRes track (==52)
      !K1=1
      DO K=1, NLINES

        KYEAR1=KDAT(K)/10000
        KMON1 =(KDAT(K)-KYEAR1*10000)/100
        KDAY1 =(KDAT(K)-KYEAR1*10000)-KMON1*100
        CALL HOURDIFF(KYEAR1,KMON1,KDAY1,KHOUR(K)/100,KYEAR,KMON,KDAY,KKHOUR,IHOURS,IRET)

        IF ( KPF(K) == (NENS+1) .and. (IHOURS.GE.0.AND.IHOURS.LE.KSTEP)) THEN !KDAT(K) <= KFCDATE) THEN    ! CHANGE !!!!!!!!!!!!!!!!!
          K1=IHOURS/6 + 1                     ! HARDCODDED (EPS must be defined every 6 hours)
          XLATPF(K1,NENS+1)=XLAT(K)
          XLONPF(K1,NENS+1)=XLON(K)
          XMSLP (K1,NENS+1)=FLOAT(KMSL(K))
          XFFF  (K1,NENS+1)=FLOAT(KFFF(K))
          !K1 = K1 + 1
          print*,XMSLP(k1,52)
        END IF
      END DO
      !stop
! define the map corners based on the tracks
      xmaxlat=maxval(XLATPF,XLATPF.NE. -999)
      xminlat=minval(XLATPF,XLATPF.NE. -999)
      xmaxlon=maxval(XLONPF,XLONPF.NE. -999)
      xminlon=minval(XLONPF,XLONPF.NE. -999)
      call plot_area(xminlat,xminlon,xmaxlat,xmaxlon)

      !print*,"minlat,minlon,maxlat,maxlon  ",xminlat,xminlon,xmaxlat,xmaxlon

!
! compute the quantiles for each step
!
      KSTEP6=(KSTEP/6)+1

      ALLOCATE (Z5PBOX (KSTEP6,8))
      ALLOCATE (Z5PBOX2(KSTEP6,8))
      ALLOCATE (ICSTORM(KSTEP6,5))
      ICSTORM=0
      DO K=1, KSTEP6

        NPF= count(XMSLP(K,1:NENS) /= -999.)
        ALLOCATE(X5PBOX (NPF))
        ALLOCATE(X5PBOX2(NPF))
        ALLOCATE(IWRK   (NPF))

        X5PBOX =PACK(XMSLP(K,1:NENS),XMSLP(K,1:NENS) /= -999.)
        X5PBOX2=PACK(XFFF (K,1:NENS),XFFF (K,1:NENS) /= -999.)
        IF (NPF >= 5 ) THEN

! MSLP
          IFAIL=0
! call NAG lib to compute the min/Q25/Q50/Q75/max for each time step

          CALL G01ALF(NPF,X5PBOX,IWRK,ZRES,IFAIL)

          IF (IFAIL /= 0) THEN
             Z5PBOX(K,1:6)=-999.
             print*,'fail to find the percentiles at ', k*6,' hours'
          ELSE
             Z5PBOX(K,1:5)=ZRES
             Z5PBOX(K,  6)=XMSLP(K,NENS)         ! Ctrl
             Z5PBOX(K,  7)=XMSLP(K,NENS+1)       ! HRes
             Z5PBOX(K,  8)=FLOAT(NPF)
          END IF

          !DEALLOCATE(IWRK  )

! WIND SPEED
! call NAG lib to compute the min/Q25/Q50/Q75/max for each time step
          IFAIL=0
          IWRK=0
          ZRES=0.
          CALL G01ALF(NPF,X5PBOX2,IWRK,ZRES,IFAIL)

          IF (IFAIL /= 0) THEN
             Z5PBOX2(K,1:6)=-999.
             print*,'fail to find the percentiles at ', k*6,' hours'
          ELSE
             Z5PBOX2(K,1:5)=ZRES
             Z5PBOX2(K,  6)=XFFF (K,NENS)
             Z5PBOX2(K,  7)=XFFF (K,NENS+1)
             Z5PBOX2(K,  8)=FLOAT(NPF)
          END IF

        ELSE
          Z5PBOX(K,1:8)=-999.     ! This is not completely true
          Z5PBOX2(K,1:8)=-999.
        END IF

        DEALLOCATE(X5PBOX)
        DEALLOCATE(X5PBOX2)
        DEALLOCATE(IWRK  )

! compute the number of members for each storm class at each time step

        DO I=1,NENS

          IF (XFFF(K,I) /= -999.) THEN

            IF (XFFF(K,I).LT.17) THEN ! tropical depression
               ICSTORM(K,1)=ICSTORM(K,1)+1
            END IF
            IF (XFFF(K,I).GE.17.AND.XFFF(K,I).LE.32) THEN   ! tropical storm
               ICSTORM(K,2)=ICSTORM(K,2)+1
            ENDIF
            IF (XFFF(K,I).GE.33.AND.XFFF(K,I).LE.42) THEN   ! hurricane cat1
               ICSTORM(K,3)=ICSTORM(K,3)+1
            END IF
            IF (XFFF(K,I).GE.43.AND.XFFF(K,I).LE.48) THEN   ! hurricane cat2
               ICSTORM(K,4)=ICSTORM(K,4)+1
            END IF
            IF (XFFF(K,I).GE.49.) THEN                      ! hurricane cat3
               ICSTORM(K,5)=ICSTORM(K,5)+1
            END IF
          END IF
        END DO
        print*,ICSTORM(K,1:5)
      END DO
      ALLOCATE(ZMXFFF(KDAYINCR,NENS+1))
      K1=1
      DO K=5,KSTEP6,4
         ZMXFFF(K1,1:NENS+1)=XFFF (K,1:NENS+1)
         K1=K1+1
      END DO
      !DO IS=1,NENS
      !   write(*,'(I2,A2,5(F5.0))') IS," ",(ZMXFFF(Kk,is),Kk=1,KDAYINCR)
      !end do

      !do kk=1,KSTEP6
      !write(*,'(5(F6.0),F4.0)') (Z5PBOX2(Kk,i),i=1,8)
      !end do

! draw maps with the strike probability and individual tracks

      print*,kbasetime,kfcdate,kkhour,kstep,xminlat,xminlon,xmaxlat,xmaxlon
      call makeplot (tmap,kbasetime,kfcdate,kkhour,kstep,xminlat,xminlon,xmaxlat,xmaxlon,xlatpf,xlonpf,Z5PBOX,Z5PBOX2,ZMXFFF,ICSTORM,KSTEP6,KDAYINCR)

      END

      SUBROUTINE GreatCircleDistance(xlon0,xlat0,xlon1,xlat1,d_km)

!
!  Computes the distance in meters between two points
!

!
!
! Input:
!       xlon0,xlat0: longitude and latitude of the first point
!       xlon1,xlat1: longitude and latitude of the second point
!
! Output:
!       d_km: distance between the 2 pointsin kilometres
!

      REAL nm2km,rad2nm,deg2rad,d_nm,d_km,d_rad

      pi=3.1416
      rad2nm=180*60/pi
      nm2km=1.852
      nm2km=1.852
      deg2rad=pi/180.

      rlon0=xlon0
      rlat0=xlat0
      rlon1=xlon1
      rlat1=xlat1

      xdiff=rlon1-rlon0+180
      if (xdiff.ge.360) xdiff=xdiff-360
      if (xdiff.le.-360) xdiff=xdiff+360
      rlon1=(rlon0+xdiff-180)*deg2rad

      xdiff=rlat1-rlat0+180
      if (xdiff.ge.360) xdiff=xdiff-360
      if (xdiff.le.-360) xdiff=xdiff+360
      rlat1=(rlat0+xdiff-180)*deg2rad

      rlon0=xlon0*deg2rad
      rlat0=xlat0*deg2rad

!
! The modulo function is invoked to keep +- 180
!

!
! We compute the distance between the 2 points
!

      d_rad=acos(sin(rlat0)*sin(rlat1)+cos(rlat0)*cos(rlat1)*cos(rlon0-rlon1))
      d_nm=d_rad*rad2nm
      d_km=d_nm*nm2km

      END
      subroutine plot_area(minlat,minlon,maxlat,maxlon)
      IMPLICIT NONE
      INTEGER      :: nlons,nlats
      REAL         :: maxlon,maxlat,minlon,minlat,latrange,lonrange,scaling
      REAL         :: lonextra,latextra
      LOGICAl      :: flag
!      maxlon=maxval(xlons)+8
!      minlon=minval(xlons)-8
!      maxlat=maxval(xlats)+8
!      minlat=minval(xlats)-8
      maxlon=maxlon+8
      minlon=minlon-8
      maxlat=maxlat+8
      minlat=minlat-8
!      print*,"maxlon,maxlat,minlon,minlat ",maxlon,maxlat,minlon,minlat
      latrange=maxlat-minlat
      lonrange=maxlon-minlon
      if (latrange/lonrange >= 2./3.) then
        scaling=(3./2.)/(abs(lonrange/latrange))			! ideal proportions are landscape 3:2
        lonextra=(scaling*lonrange)-lonrange
        maxlon=maxlon+(lonextra/2.)
        minlon=minlon-(lonextra/2.)
!        print*,"if 1"
      else
        scaling=(3./2.)/(abs(lonrange/latrange))			! ideal proportions are landscape 3:2
        latextra=(latrange/scaling)-latrange
        maxlat=maxlat+(latextra/2.)
        minlat=minlat-(latextra/2.)
!        print*,"if 2"
      end if

      end


      SUBROUTINE CONLOD (XD,YD,ZD,NDP,WK,IWK,SCRARR)
C
C +-----------------------------------------------------------------+
C |                                                                 |
C |                Copyright (C) 1986 by UCAR                       |
C |        University Corporation for Atmospheric Research          |
C |                    All Rights Reserved                          |
C |                                                                 |
C |                 NCARGRAPHICS  Version 1.00                      |
C |                                                                 |
C +-----------------------------------------------------------------+
C
C
C
C******************************************************************
C*                                                                *
C*   THIS FILE IS A PACKAGE OF SUPPORT ROUTINES FOR THE ULIB      *
C*   FILES CONRAN AND CONRAS.  SEE THOSE FILES FOR AN             *
C*   EXPLAINATION OF THE ENTRY POINTS.                            *
C*                                                                *
C******************************************************************
C
C
C
      COMMON /CONRA1/ CL(30)     ,NCL        ,OLDZ       ,PV(210)    ,
     1                FINC       ,HI         ,FLO
      COMMON /CONRA2/ REPEAT     ,EXTRAP     ,PER        ,MESS       ,
     1                ISCALE     ,LOOK       ,PLDVLS     ,GRD        ,
     2                CINC       ,CHILO      ,CON        ,LABON      ,
     3                PMIMX      ,SCALE      ,FRADV      ,EXTRI      ,
     4                BPSIZ      ,LISTOP
      COMMON /CONRA3/ IREC
      COMMON /CONRA4/ NCP        ,NCPSZ
      COMMON /CONRA5/ NIT        ,ITIPV
      COMMON /CONRA6/ XST        ,YST        ,XED        ,YED        ,
     1                STPSZ      ,IGRAD      ,IG         ,XRG        ,
     2                YRG        ,BORD       ,PXST       ,PYST       ,
     3                PXED       ,PYED       ,ITICK
      COMMON /CONRA7/ TITLE      ,ICNT   ,ITLSIZ
      COMMON /CONRA8/ IHIGH      ,INMAJ      ,INLAB      ,INDAT      ,
     1              LEN      ,IFMT       ,LEND       ,
     2                IFMTD      ,ISIZEP     ,INMIN
      COMMON /CONRA9/ ICOORD(500),  NP       ,MXXY       ,TR         ,
     1                BR         ,TL         ,BL         ,CONV       ,
     2                XN         ,YN         ,ITLL       ,IBLL       ,
     3                ITRL       ,IBRL       ,XC         ,YC         ,
     4                ITLOC(210) ,JX         ,JY         ,ILOC       ,
     5                ISHFCT     ,XO         ,YO         ,IOC        ,NC
      COMMON /CONR10/ NT         ,NL         ,NTNL       ,JWIPT      ,
     1                JWIWL      ,JWIWP      ,JWIPL      ,IPR        ,
     2                ITPV
      COMMON /CONR11/ NREP       ,NCRT       ,ISIZEL     ,
     1                MINGAP     ,ISIZEM         ,
     2                TENS
      COMMON /CONR12/ IXMAX      ,IYMAX      ,XMAX       ,YMAX
      LOGICAL         REPEAT     ,EXTRAP     ,PER        ,MESS       ,
     1                LOOK       ,PLDVLS     ,GRD        ,LABON      ,
     2                PMIMX      ,FRADV      ,EXTRI      ,CINC       ,
     3                TITLE      ,LISTOP     ,CHILO      ,CON
      COMMON /CONR13/XVS(50),YVS(50),ICOUNT,SPVAL,SHIELD,
     1               SLDPLT
      LOGICAL SHIELD,SLDPLT
      COMMON /CONR14/LINEAR
      LOGICAL LINEAR
      COMMON /CONR15/ ISTRNG
        CHARACTER*64 ISTRNG
        COMMON /CONR16/ FORM
        CHARACTER*10 FORM
        COMMON /CONR17/ NDASH, IDASH, EDASH
        CHARACTER*10 NDASH, IDASH, EDASH
C
C
      DIMENSION       SCRARR(1)
C
        SAVE
C
C  IFR - FLAG TO REGISTER FIRST PASS IN Y DIRECTION
C
C  LOAD THE SCRATCH SPACE AND CONVEX HULL POINTERS
C  ITLOC IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO THE SCARTCH
C  SPACE.
C  PV IS THE LIST OF CONVEX HULL POINTERS RELATIVE TO USER COORDINATES
C
C  INITALIZE THE SPECIAL VALUE FEATURE
C
      X = (XED-XST)/2. + XST
      Y = (YED-YST)/2. + YST
      IF(LINEAR) GO TO 1
      SPVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT)
        GO TO 2
 1    SPVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT)
 2    CONTINUE
C
C  INITIALIZE THE SEARCH
C
      IYMAX = 0
      IFR = 1
      JX = 1
      X = XST
   10 JY = 1
      Y = YST
C
C  SET HULL POINTERS FOR THIS COLUMN TO NULL
C
      ITLOC(JX*2-1) = 0
      ITLOC(JX*2) = 0
C
C  FLAG START OF COLUMN
C
      LOOP = 1
C
C  GET INTERPOLATED VALUE
C
  20  IF (LINEAR) GO TO 3
      RVAL = CONCOM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT)
      GO TO 4
  3   RVAL = CONLCM(X,Y,XD,YD,ZD,NDP,WK,IWK,IT)
  4   CONTINUE
      SCRARR(JY+(JX-1)*IYMAX) = RVAL
      IF (RVAL.GT.SPVAL) SPVAL = RVAL
C
C  IF OUTSIDE CONVEX HULL BRANCH
C
      IF (IT.GT.NTNL) GO TO    30
C
C  IF OUTSIDE TRIANGLES AND USING LINEAR INTERPLOATION THEN BRANCH
C
      IF(LINEAR.AND.IT.GT.NT) GO TO 30
C
C  IF FIRST OF COLUMN IN HULL CONTINUE THROUGH
C
      IF (LOOP.NE.1) GO TO    40
C
C  SET HULL POINTERS
C
      PV(JX*2-1) = Y
      ITLOC(JX*2-1) = JY
C
C  SET FLAG TO LOOK FOR END OF HULL IN COLUMN
C
      LOOP = 2
C
C  GO FOR NEXT ENTRY
C
      GO TO    40
C
C  TEST FOR END OF CONVEX HULL ON THIS ROW
C
   30 IF (LOOP.NE.2) GO TO    40
C
C  END OF HULL SET POINTERS FOR END OF HULL AND FLAG IT VIA LOOP
C
      LOOP = 0
      ITLOC(JX*2) = JY-1
      PV(JX*2) = Y-STPSZ
C
C  GET NEXT ELEMENT IN ROW IF NOT OUTSIDE ENCLOSING RECTANGULAR
C  BOARDER
C
   40 Y = Y+STPSZ
      JY = JY+1
      IF (Y.LE.YED) GO TO    20
C
C  TEST FOR FIRST COLUMN
C
      IF (IFR.NE.1) GO TO    50
C
C  FIRST COLUMN OVER SET MAX Y VALUES
C
      IYMAX = JY-1
      YMAX = Y-STPSZ
      IFR = 0
C
C  IF HULL WENT TO EDGE OF RECTANGULAR BOARDER SET HULL POINTERS HERE
C
   50 IF (LOOP.NE.2) GO TO    60
      PV(JX*2) = Y-STPSZ
      ITLOC(JX*2) = JY-1
C
C  END OF COLUMN GET NEXT ONE
C
   60 X = X+STPSZ
      JX = JX+1
C
C  IF NOT END OF WORK CONTINUE WITH NEXT COLUMN
C
      IF (X.LE.XED) GO TO    10
C
C  END OF WORK SET MAX X VALUES
C
      IXMAX = JX-1
      XMAX = X-STPSZ
      RETURN
      END


   subroutine amrex_probinit (init,name,namlen,problo,probhi) bind(c)

     use probdata_module
     use amrex_constants_module
     use amrex_error_module
     use fundamental_constants_module
     use eos_module

     use amrex_fort_module, only : rt => amrex_real
     implicit none

     integer :: init, namlen
     integer :: name(namlen)
     real(rt)         :: problo(3), probhi(3)

     integer :: untin
     integer :: i

     namelist /fortin/ density, diameter, ambient_dens, problem

     integer, parameter :: maxlen=127
     character :: probin*(maxlen)
     character :: model*(maxlen)
     integer :: ipp, ierr, ipp1

     ! Build "probin" filename -- the name of file containing fortin namelist.
     if (namlen .gt. maxlen) then
        call amrex_error("ERROR: probin file name too long")
     end if

     do i = 1, namlen
        probin(i:i) = char(name(i))
     end do

     density  = 1.0e0_rt
     diameter = 1.0e0_rt

     ambient_dens = 1.0e-8_rt

     problem = 1

     ! Read namelists -- override the defaults

     untin = 9
     open(untin,file=probin(1:namlen),form='formatted',status='old')
     read(untin,fortin)
     close(unit=untin)

   end subroutine amrex_probinit

   ! ::: -----------------------------------------------------------
   ! ::: This routine is called at problem setup time and is used
   ! ::: to initialize data on each grid.
   ! :::
   ! ::: NOTE:  all arrays have one cell of ghost zones surrounding
   ! :::        the grid interior.  Values in these cells need not
   ! :::        be set here.
   ! :::
   ! ::: INPUTS/OUTPUTS:
   ! :::
   ! ::: level     => amr level of grid
   ! ::: time      => time at which to init data
   ! ::: lo,hi     => index limits of grid interior (cell centered)
   ! ::: nstate    => number of state components.  You should know
   ! :::		   this already!
   ! ::: state     <=  Scalar array
   ! ::: delta     => cell size
   ! ::: xlo,xhi   => physical locations of lower left and upper
   ! :::              right hand corner of grid.  (does not include
   ! :::		   ghost region).
   ! ::: -----------------------------------------------------------
   subroutine ca_initdata(level,time,lo,hi,nscal, &
                          state,state_l1,state_l2,state_l3,state_h1,state_h2,state_h3, &
                          delta,xlo,xhi)

     use amrex_constants_module
     use amrex_error_module
     use amrex_fort_module, only : rt => amrex_real

     use probdata_module
     use meth_params_module, only : NVAR, URHO, UMX, UMY, UMZ, UTEMP, &
          UEDEN, UEINT, UFS, UFA
     use network, only : nspec
     use prob_params_module, only: problo, probhi, center

     implicit none

     integer :: level, nscal
     integer :: lo(3), hi(3)
     integer :: state_l1,state_l2,state_l3,state_h1,state_h2,state_h3
     real(rt)         :: xlo(3), xhi(3), time, delta(3)
     real(rt)         :: state(state_l1:state_h1,state_l2:state_h2,state_l3:state_h3,NVAR)

     real(rt)         :: xx, yy, zz

     integer :: i, j, k

     !$OMP PARALLEL DO PRIVATE(i, j, k, xx, yy, zz)
     do k = lo(3), hi(3)
        zz = xlo(3) + delta(3) * (dble(k-lo(3))+HALF) - center(3)

        do j = lo(2), hi(2)
           yy = xlo(2) + delta(2) * (dble(j-lo(2))+HALF) - center(2)

           do i = lo(1), hi(1)
              xx = xlo(1) + delta(1) * (dble(i-lo(1))+HALF) - center(1)

              ! Establish the cube or sphere

              if (problem .eq. 1 .or. problem .eq. 2) then

                 if ((xx**2 + yy**2 + zz**2)**0.5 < diameter / 2) then
                    state(i,j,k,URHO) = density
                 else
                    state(i,j,k,URHO) = ambient_dens
                 endif

              else if (problem .eq. 3) then

                 if (abs(xx) < diameter/2 .and. abs(yy) < diameter/2 .and. abs(zz) < diameter/2) then
                    state(i,j,k,URHO) = density
                 else
                    state(i,j,k,URHO) = ambient_dens
                 endif

              else

                 call amrex_error("Problem not defined.")

              endif

              ! Establish the thermodynamic quantities. They don't have to be
              ! valid because this test will never do a hydro step.

              state(i,j,k,UTEMP) = 1.0e0_rt
              state(i,j,k,UEINT) = 1.0e0_rt
              state(i,j,k,UEDEN) = 1.0e0_rt

              state(i,j,k,UFS:UFS-1+nspec) = state(i,j,k,URHO) / nspec

           enddo
        enddo
     enddo
     !$OMP END PARALLEL DO

   end subroutine ca_initdata


      SUBROUTINE GKAM1B(USETD,SCR1,SCR2,PHIDH,PHIDH1,MODES,CORE,
     1  LHSET,NOUE,SCR3)
C
      INTEGER       USET,USETD,PHIDH,PHIDH1,SCR1,SCR2
      INTEGER MCB(7),SYSBUF,CORE
      INTEGER SCR3
      DIMENSION CORE(1)
C
      COMMON  /SYSTEM/ SYSBUF
      COMMON  /PATX/LC,N1,N2,N3,USET
      COMMON  /BITPOS/UM,UO,UR,USG,USB,UL,UA,UF,US,UN,UG,UE,UP,UNE,UFE,
     1UD
      COMMON  /ZBLPKX/A(4),II
      COMMON  /PARMEG/ IA(7),IA11(7),IA12(7),IA21(7),IA22(7),LCORE,IRULE
C
C ----------------------------------------------------------------------
C
      LHSET =LHSET  + NOUE
C
C     BUILD  MERGE  VECTOR
C
      USET = USETD
      LC  = KORSZ(CORE(MODES))
      LCORE = LC
      CALL  CALCV(SCR1,UD,UA,UE,CORE(MODES))
C
C     BUILD  EXE  IDENTY   MATRIX
C
      NZ = LC-SYSBUF
      CALL GOPEN(SCR2,CORE(NZ+1),1)
      CALL MAKMCB(MCB,SCR2,NOUE,6,1)
      A(1) = 1.0
      DO 10 I=1,NOUE
      CALL BLDPK(1,1,SCR2,0,0)
      II = I
      CALL ZBLPKI
      CALL BLDPKN(SCR2,0,MCB)
   10 CONTINUE
      CALL  CLOSE(SCR2, 1)
      CALL WRTTRL ( MCB )
C
C     SET  UP  FOR  MERGE
C
      IRULE =0
      IA22(1)= SCR2
      CALL RDTRL(IA22)
      IA(1) = PHIDH
      IA(2)= LHSET
      IA(3) =  N1+N2+N3
      IA(4) =  2
      IA(5) = 1
      IA21 (1) = 0
      IA12 (1) = 0
      IA11 (1) = PHIDH1
      CALL MAKMCB(CORE(MODES),SCR3,LHSET,2,1)
      CALL RDTRL (IA11)
C
C     BUILD  VECTOR IN CORE
C
      CALL GOPEN(SCR3,CORE(NZ+1),1)
      CALL BLDPK(1,1,SCR3,0,0)
      II = MODES -1
      DO 20 I=1,NOUE
      II = II+1
      CALL ZBLPKI
   20 CONTINUE
      CALL BLDPKN( SCR3, 0, CORE(MODES) )
      CALL CLOSE(SCR3,1)
      CALL WRTTRL(CORE(MODES))
      CALL MERGE(SCR3,SCR1,CORE(MODES))
      CALL WRTTRL( IA )
      RETURN
      END


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! The code reads two W2K-charge densities      !!
!! and writes the average of the two densities  !!
!! The argumens is                              !!
!!        case                                  !!
!! The input files are                          !!
!!        case.clmval, case.clmvaldn            !!
!! The output files is                          !!
!!        case.clmval_aver                      !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

MODULE struct
  LOGICAL                  :: rel
  REAL*8                   :: AA,BB,CC,VOL,pia(3),alpha(3)
  REAL*8,ALLOCATABLE       :: R0(:),DX(:),RMT(:),zz(:),rotloc(:,:,:),v(:)
  REAL*8,ALLOCATABLE       :: tau(:,:)
  REAL*8,POINTER           :: pos(:,:)
  CHARACTER*4              :: lattic,irel,cform
  CHARACTER*80             :: title
  CHARACTER*10,ALLOCATABLE :: aname(:)
  INTEGER                  :: nat,iord
  INTEGER,ALLOCATABLE      :: mult(:),jrj(:),iatnr(:),isplit(:)
  INTEGER,ALLOCATABLE      :: iz(:,:,:),inum(:)
  REAL*8,ALLOCATABLE       :: rotij(:,:,:),tauij(:,:)

CONTAINS

  SUBROUTINE dealc_struct
    DEALLOCATE(aname, mult, jrj, r0, dx, rmt)
    deallocate(zz, rotloc, iatnr, isplit, v)
    DEALLOCATE (pos)
    DEALLOCATE(iz, tau, inum)
  END SUBROUTINE dealc_struct

  SUBROUTINE init_struct(struct_file)
    !USE reallocate
    IMPLICIT NONE
    CHARACTER*100, intent(in) :: struct_file
    INTEGER                   :: ios
    REAL*8                    :: test,ninety
    INTEGER                   :: index,i,j,j1,j2,m,jatom

    test=1.D-5
    ninety=90.0D0

    open (20, file=struct_file, status='old')
    read (20,1000) title
    read (20,1010)  lattic,nat,cform,irel
    REL=.TRUE.
    IF(IREL.EQ.'NREL') REL=.FALSE.
    ALLOCATE(aname(nat),mult(nat),jrj(nat),r0(nat),dx(nat),rmt(nat))
    allocate(zz(nat),rotloc(3,3,nat),iatnr(nat),isplit(nat),v(nat))
    v=0.0d0
    ALLOCATE (pos(3,48*nat))
    read (20,1020) aa,bb,cc,alpha(1),alpha(2),alpha(3)
    IF(ABS(ALPHA(1)).LT.test) ALPHA(1)=ninety
    IF(ABS(ALPHA(2)).LT.test) ALPHA(2)=ninety
    IF(ABS(ALPHA(3)).LT.test) ALPHA(3)=ninety
    INDEX=0

    DO jatom=1,NAT
       INDEX=INDEX+1
       READ(20,1030,iostat=ios) iatnr(jatom),( pos(j,index),j=1,3 ), mult(jatom),isplit(jatom)
       IF(ios /= 0) THEN
          WRITE(*,*) iatnr(jatom),( pos(j,index),j=1,3 ), mult(jatom),isplit(jatom)
          WRITE(*,*) 'ERROR IN STRUCT FILE READ'
          STOP
       ENDIF
       IF (mult(jatom) .EQ. 0) THEN
          WRITE (*,6000) jatom, index, mult(jatom)
          STOP
       ENDIF
       DO m=1,mult(jatom)-1
          index=index+1
          READ(20,1031) iatnr(jatom),( pos(j,index),j=1,3)   ! pos -- position inside the unit cell read from case.struct
       ENDDO
       READ(20,1050) aname(jatom),jrj(jatom),r0(jatom),rmt(jatom),zz(jatom) ! zz-nuclear charge, jrj--number of radial data points
       dx(jatom)=LOG(rmt(jatom)/r0(jatom)) / (jrj(jatom)-1)
       rmt(jatom)=r0(jatom)*EXP( dx(jatom)*(jrj(jatom)-1) )
       READ(20,1051) ((rotloc(i,j,jatom),i=1,3),j=1,3)
    ENDDO
    !CALL doreallocate(pos, 3, index)
    READ(20,1151) iord
    ALLOCATE(iz(3,3,iord),tau(3,iord),inum(iord))
    DO j=1,iord  ! iz(:,:,iord) - all symmetry transformations
                 ! tau(:,iord)  - translations
       READ(20,1101) ( (iz(j1,j2,j),j1=1,3),tau(j2,j),j2=1,3 ),inum(j)
    ENDDO

1000 FORMAT(A80)
1010 FORMAT(A4,23X,I3,1x,a4,/,13X,A4,18X,A4)
1020 FORMAT(6F10.7,10X,F10.7)
1030 FORMAT(4X,I4,4X,F10.7,3X,F10.7,3X,F10.7,/,15X,I2,17X,I2)
1031 FORMAT(4X,I4,4X,F10.7,3X,F10.7,3X,F10.7)
1050 FORMAT(A10,5X,I5,5X,F10.9,5X,F10.5,5X,F10.5)
1051 FORMAT(20X,3F11.8)
1101 FORMAT(3(3I2,F11.8/),I8)
1151 FORMAT(I4)
6000 FORMAT(///,3X,'ERROR IN LAPW0 : MULT(JATOM)=0 ...', &
          /, 20X,'JATOM=',I3,3X,'INDEX=',I3,3X,'MULT=',I3)
  END SUBROUTINE init_struct

END MODULE struct

subroutine ReadCLMVAL(fclmval1, fclmval2, fclmvala)
  use struct, ONLY: nat, jrj
  IMPLICIT NONE
  CHARACTER*100, intent(in) :: fclmval1, fclmval2, fclmvala
  ! locals
  INTEGER :: fhv1, fhv2, fhv3
  INTEGER :: ISCF, jatom, jatom1, jatom2, iat, IMAX, LMMAX, ILM, Li, Mi, I, J, JX, NWAVE
  CHARACTER*100 :: str1, str2
  COMPLEX*16 :: RHOK1,RHOK2
  INTEGER :: KZZ(3)
  INTEGER, ALLOCATABLE :: JRI(:)
  REAL*8, ALLOCATABLE :: RHOLM1(:), RHOLM2(:)

  fhv1 = 10
  fhv2 = 11
  fhv3 = 12

  IMAX = jrj(1)
  do iat=2,nat
     if (jrj(iat).gt.IMAX) IMAX = jrj(iat)
  enddo

  ALLOCATE( RHOLM1(IMAX), RHOLM2(IMAX) )

  OPEN(fhv1,file=fclmval1, status='old')
  OPEN(fhv2,file=fclmval2, status='old')
  OPEN(fhv3,file=fclmvala, status='unknown')

  READ(fhv1,'(A43,5X,I3,A)') str1, ISCF, str2
  READ(fhv2,'(A43,5X,I3,A)') str1, ISCF, str2
  READ(fhv1,*)
  READ(fhv2,*)
  READ(fhv1,*)
  READ(fhv2,*)

  WRITE(fhv3,'(A43,5X,I3,A)') '    VALENCE CHARGE DENSITY   IN  MT SPHERES', ISCF, ' ITERATION'
  WRITE(fhv3,'(1x,A)') '   NORM OF CLM(R) =          '
  WRITE(fhv3,*)

  DO jatom=1,nat
     IMAX=jrj(JATOM)

     READ(fhv1,'(3X,A13,I3,5X)') str1, jatom1
     READ(fhv2,'(3X,A13,I3,5X)') str1, jatom2
     if (jatom1.ne.jatom .or. jatom2.ne.jatom) print *, 'ERROR: atom number not correct! Something wrong reading clmval'
     READ(fhv1,'(3X,A12,I3//)') str1, LMMAX
     READ(fhv2,'(3X,A12,I3//)') str1, LMMAX

     WRITE(fhv3,'(3X,A13,I3,5X)')'ATOMNUMBER   ', jatom
     WRITE(fhv3,'(3X,A12,I3//)') 'NUMBER OF LM', LMMAX

     DO ILM=1,LMMAX
        READ(fhv1,'(3X,A12,I3,3X,A2,I2/)') str1, Li, str2, Mi
        READ(fhv2,'(3X,A12,I3,3X,A2,I2/)') str1, Li, str2, Mi
        READ(fhv1,'(3X,4E19.12)') ( RHOLM1(I), I=1,IMAX )
        READ(fhv2,'(3X,4E19.12)') ( RHOLM2(I), I=1,IMAX )
        READ(fhv1,'(/)')
        READ(fhv2,'(/)')

        WRITE(fhv3,'(3X,A12,I3,3X,A2,I2/)') 'CLM(R) FOR L', Li, 'M=', Mi
        WRITE(fhv3,'(3X,4E19.12)') ( 0.5*(RHOLM1(I)+RHOLM2(I)), I=1,IMAX )
        WRITE(fhv3,'(/)')
     end DO
     READ(fhv1,'(///)')
     READ(fhv2,'(///)')
     WRITE(fhv3,'(///)')
  ENDDO

  READ(fhv1,*)
  READ(fhv2,*)
  READ(fhv1,*)
  READ(fhv2,*)
  READ(fhv1,'(9X,I10,1X,A12)')  NWAVE, str1
  READ(fhv2,'(9X,I10,1X,A12)')  NWAVE, str1

  WRITE(fhv3,'(1x,A)') '   VALENCE CHARGE DENSITY IN INTERSTITIAL '
  WRITE(fhv3,*)
  WRITE(fhv3,'(9X,I10,1X,A12)')  NWAVE, 'NUMBER OF PW'

  DO J=1,NWAVE
     READ(fhv1,'(3X,3I5,2E19.12)')  (KZZ(JX),JX=1,3),RHOK1
     READ(fhv2,'(3X,3I5,2E19.12)')  (KZZ(JX),JX=1,3),RHOK2
     WRITE(fhv3, '(3X,3I5,2E19.12)')   (KZZ(JX),JX=1,3),0.5*(RHOK1+RHOK2)
  ENDDO

  close(fhv1)
  close(fhv2)
  close(fhv3)

  DEALLOCATE( RHOLM1, RHOLM2 )

end subroutine ReadCLMVAL

program CombineUpDn
  use struct
  IMPLICIT NONE
  !DEFINE BUFFER HOLDS THE COMMAND LINE ARGUMENT
  CHARACTER*100 :: case
  !
  CHARACTER*100 :: struct_file, fclmval1, fclmval2, fclmvala
  INTEGER :: iargc
  !GET THE PARAMETERS FROM THE COMMAND LINE ARGUMENT

  if (iargc().LT.1) then
     print *, 'ERROR: Give case as the argument!'
     CALL EXIT(1)
  endif

  CALL GETARG(1,case)

  struct_file = TRIM(case)//'.struct'
  fclmval1 = TRIM(case)//'.clmval'
  fclmval2 = TRIM(case)//'.clmvaldn'
  fclmvala = TRIM(case)//'.clmval_aver'

  !print *, struct_file
  !print *, fclmval1
  !print *, fclmval2
  !print *, fclmvala

  CALL init_struct(struct_file)
  CALL ReadCLMVAL(fclmval1, fclmval2, fclmvala)
  CALL dealc_struct()
end program CombineUpDn


c
c $Id$
c

      SUBROUTINE verlt_test(tstep,ivv,lupdate)

      implicit none

      include 'p_input.inc'
      include 'p_array.inc'
      include 'cm_atom.inc'
      include 'cm_cuto.inc'

      integer i,exceed

      real*8 tstep,tstepsq,ivv
      real*8 dispmax,dispxsq,dispysq,dispzsq,disprsq

      logical lnew,lupdate

      dimension ivv(mxatms,3)

      data lnew/.true./

      save lnew

      tstepsq=tstep**2

      if(lnew)then

       lupdate=.true.
       lnew=.false.

       do i=1,natms

        ivv(i,1)=0.0
        ivv(i,2)=0.0
        ivv(i,3)=0.0

       enddo

      else

       lupdate=.false.

       dispmax=((vcut-rcut)/2.0)**2

       do i=1,natms

        ivv(i,1)=ivv(i,1)+vvv(i,1)
        ivv(i,2)=ivv(i,2)+vvv(i,2)
        ivv(i,3)=ivv(i,3)+vvv(i,3)

       enddo

       exceed=0

       do i=1,natms

        dispxsq=ivv(i,1)**2
        dispysq=ivv(i,2)**2
        dispzsq=ivv(i,3)**2
        disprsq=tstepsq*(dispxsq+dispysq+dispzsq)
        if(disprsq.gt.dispmax)exceed=exceed+1
        if(exceed.ge.2)lupdate=.true.

       enddo

       if(lupdate)then

        do i=1,natms

         ivv(i,1)=0
         ivv(i,2)=0
         ivv(i,3)=0

        enddo

       endif

      endif

      return

      END


      SUBROUTINE INPUT

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

C
C  PURPOSE:
C      INPUT READS INPUT VALUES AND RUN PARAMETERS AND CONTROLS THE
C      INITIALIZATION SEQUENCE IN THIS PROGRAM.
C  MODIFIED FROM ORIGINAL BY
C      STEVE POHORSKY    INFORMATICS     TASK 605    JUL 82
C  FOR
C      JIM POLLACK
C  ENVIRONMENT
C      Cray-2            UNICOS 3.0      FORTRAN
C  REVISION HISTORY
C
C  INPUT PARAMETERS
C      SUBROUTINE INPUT READS JOB INPUT INCLUDING RUN PARAMETERS.
C      INCLUDED AMONG THESE ARE THE STARTING DAY AND HOUR OF SIMULATED
C      TIME AT WHICH THIS RUN OF THE PROGRAM IS TO START. IF THESE ARE
C      BOTH ZERO, THEN SUBROUTINE INIT1 IS CALLED TO
C      PERFORM A COLD START OF THIS MODEL FROM A SOMEWHAT ARTIFICIAL
C      (ISOTHERMAL WITH NO WINDS) SET OF DATA. OTHERWISE THE STARTING
C      DAY AND HOUR REFER TO A TIME STEP FROM A PREVIOUS RUN OF THIS
C      MODEL FROM WHICH THIS RUN IS TO CONTINUE. FOR THIS CASE THE
C      HISTORY TAPE OUTPUT FROM THE PREVIOUS RUN IS READ, AND THE MODEL
C      IS INITIALIZED TO THE CONDITIONS IT HAD IN THE SPECIFIED
C      TIME STEP.
C  OUTPUT PARAMETERS
C      INPUT INITIALIZES THE MAJOR ARRAYS (P,U,V,T,GT,TOPOG,ALSP,...)
C      THAT SPECIFY THE STATE OF THE ATMOSPHERE AND THE SURFACE FOR THE
C      STARTING TIME STEP. (SEE SUBROUTINE INIT1.) ALSO, A NUMBER OF
C      CONSTANTS ARE CALCULATED FOR USE BY THE ROUTINES THAT PERFORM
C      THE TIME INTEGRATION. THE HISTORY TAPE FILE IS ALSO SET UP AND/OR
C      POSITIONED FOR SUBSEQUENT OUTPUT FROM THIS RUN.
C  CALLED BY
C      MAIN
C  SUBROUTINES CALLED:
C      EMISS, MAGFAC, INSDET (WHICH CALLS SDET); INIT1 CALLED
C      ONLY WHEN DOING A COLD START.
C

      use grid_h
      use defines_h
      use constants_h, only: PI, GRAV, RGAS, KAPA
      use fccsave_h
      use standard_h
      use dtcommon_h
      use cldcommon_h
      use comp3cmn_h, only: tauts, taute, volno, imover2, imover4, ndt,
     *                      wantit

      implicit none

C#######################################################################

      INTEGER :: TID

      real*8  :: BOUNDUM(L_JSIZE+1,L_ISIZE)

      CHARACTER(len=64) :: DUMMY

      integer, parameter :: coldstart = 1
      integer, parameter :: warmstart = 0
      integer, parameter :: renameyes = 1

!  Namelist input

      integer :: RSETSW
      real*8  :: runnumx
      namelist / inputnl / RUNNUMX, DLAT, JM, IM, NLAY, PSF, PTROP,
     *                     DTM, TAUTOT, RPTAU, CONRNU, TAUE, TAUH,
     *                     TAUID, TAUIH, NC3, RSETSW, RENAME,
     *                     CLOUDON, ACTIVE_DUST, ACTIVE_WATER,
     *                     MICROPHYSICS, CO2SCAV, TIMESPLIT, ALBFEED,
     *                     LATENT_HEAT,VDUST, ICEALB, ICETHRESH_DEPTH,
     *                     DTSPLIT,H2OCLOUDFORM,VARY_CONR

      integer :: i, j, k, n, ios, inu, jkl, ktpr,l,m
      real*8  :: taur, xls, taux, tauxm

!     NPCFLAG input variable

      logical :: npcflagin(L_J+1,L_I)

      !! Zero argument function that returns the number of bytes
      !! in a "recl=" unit
      integer, external :: recl_unit

      !! record length of the direct-access file
      integer, parameter :: record_length_in_bytes = 17768

C#================================================================

C     HISTORY FILE

      KTP  = 11

C     DATA CARD IMAGE FILE

      INU = 5

C     OUTPUT  STREAM

      MTP = 6

C     Read in the run values.

      READ(INU,inputnl)

      NCYCLE  = NC3
      NICETOP = 2*L_LAYERS + 3
      PSL     = PSF
      KEY2    = .TRUE.
      KEY13   = .FALSE.
      KEY15   = .TRUE.
      IGMAX   = 999
      MPRINT  = 48

C     Write out a copy of the run values to the output file.

      WRITE(MTP,7005)
      WRITE(MTP,7006) RUNNUMX
      WRITE(MTP,7007) TAUID, TAUIH, TAUD, TAUE, TAUO, TAUH, TAUC
      WRITE(MTP,7008) DTM, NCYCLE, NC3, JM, IM, DLAT
      WRITE(MTP,7009) (DSIG(JKL),JKL=1,NLAY)
      WRITE(MTP,7010) ED, RAD, GRAV, DAY, RGAS, KAPA, PSL, PSF
      WRITE(MTP,7011) PTROP, DLIC, TAUO2, TAURUN, KEY2, KEY13, KEY15
      WRITE(MTP,7012) TSTART, MPRINT, NLAY, NICETOP, IDUSTSW, IGMAX
      WRITE(MTP,7014) TAUTOT, TREFR, CONRNU, TAUR
      WRITE(MTP,7015) RPTAU, VDUST, MICROPHYSICS, RENAME
      WRITE(MTP,7016)

 7005 FORMAT(' ',//,25X,'************* RUN VALUES *************',/)
 7006 FORMAT(' ','Run number: ',f7.2,/)
 7007 FORMAT(' ','TAUID =',F5.1,3X,'TAUIH =',F8.1,3X,'TAUD =',
     *       F6.1,2X,'TAUE =',F7.1,3X,'TAUO =',F5.1,/,' TAUH =',
     *       F5.1,3X,'TAUC =',F5.1)
 7008 FORMAT(' ','DTM =',F5.1,3X,'NCYCLE =',I3,3X,'NC3 =',I3,3X,
     *       'JM =',I3,3X,'IM =',I3,3X,'DLAT =',F6.2)
 7009 FORMAT(' ','DSIG =',5(2X,F9.6))
 7010 FORMAT(' ','ED =',F5.1,3X,'RAD =',F6.0,3X,'GRAV =',F6.2,3X,
     *       'DAY =',F6.2,3X,'RGAS =',F7.2,/,' KAPA =',F8.5,3x,
     *       'PSL =',F6.2,3X,'PSF =',F6.2)
 7011 FORMAT(' ','PTROP =',F8.5,3X,'DLIC =',F6.2,3X,'TAUO2 =',F5.1,
     *       3X,'TAURUN =',F6.1,/,' KEY2 =',L3,3X,'KEY13 =',L3,3X,
     *       'KEY15 =',L3)
 7012 FORMAT(' ','TSTART =',F6.2,3X,'MPRINT =',I3,3X,'NLAY =',I3,3x,
     *       'NICETOP =',I3,/,' IDUSTSW =',I2,3X,'IGMAX =',I4)
 7014 FORMAT(' ','TAUTOT =',F8.5,3X,'TREFR =',F6.3,3X,'CONRNU =',
     *       F7.4,3X,'TAUR = ',1PE8.2)
 7015 FORMAT(' ','RPTAU = ',f6.2,3x,'VDUST = ',L1,3x,'MICROPHYS = ',
     *           L1,3x,'RENAME = ',i1)
 7016 FORMAT(' ',/,25X,'**************************************',///)

      IF(MOD(NICETOP,2).EQ.1.AND.NICETOP.LE.2*NLAY+3) GOTO 30

      WRITE (MTP,9010) NICETOP
      GOODINP = .FALSE.
      GOTO 8000

   30 CONTINUE

      TAUI    = TAUID*24.0+TAUIH
      DT      = DTM*60.0
      FIM     = IM
      DLAT    = DLAT*PI/180.0
      DLON    = 2.0*PI/FIM

!     QH2O is the mixing ratio.  The GCM computes it as mass mixing
!     ratio.  The radiation code wants number mixing ratio.  The TOTAL
!     mass in each layer is just the mass of CO2, not CO2+H2O.  If we
!     change the total mass, then the expresion for MWRATIO would
!     change to read MWRATIO = (MWCO2+MWH2O)/MWH2O

      MWRATIO = MWCO2/MWH2O

C     INITIALIZE CONSTANT ELEMENTS OF VECTOR OF CUMULATIVE
C     OPTICAL DEPTHS FOR INDIVIDUAL GRID POINTS

      TAUCUM(1) = 0.0
      TAUCUM(3) = 0.0

      do J=1,L_J-1
        do I=1,L_I
          DMADT(J,I) = 0.0
        end do
      end do

C     READ IN THERMAL INERTIA, ALTITUDE, AND ALBEDO FROM DATA FILES

      OPEN(UNIT=9,
     *  FILE='data/osu_ti_5x6_2011',
     *  STATUS='OLD',FORM='UNFORMATTED')
      READ(9) BOUNDUM
      CLOSE(9)

      DO J = 1,L_JSIZE-1
        DO I = 1,L_ISIZE
          DO K=1,NL
            ZIN(J,I,K) = BOUNDUM(J+1,I)
          END DO
        END DO
      END DO

C SOIL model 3-D arrays, RHOSOIL & CPSOIL
C We'll eventually read these values in from a data file

      DO J=1,L_JSIZE-1
        DO I=1,L_ISIZE
          DO K=1,NL
            RHOSOIL(J,I,K) = 1481.39
            CPSOIL(J,I,K)  = 840.0
          END DO
        END DO
      END DO

      OPEN(UNIT=9,
     *  FILE='data/topog37x60.mola_intel',
     *  STATUS='OLD',FORM='UNFORMATTED')
      READ(9) BOUNDUM
      CLOSE(9)

      DO J = 1,L_JSIZE
        DO I = 1,L_ISIZE
          TOPOG(J,I) = BOUNDUM(J+1,I)
        END DO
      END DO

C Initialise dynamical core geopotential WHICH IS NEGATIVE OF TOPOG FILES

      DO I = 1,L_ISIZE
        DO J = 1,L_JSIZE
          PHS(I,J) = -TOPOG(J,I)
        END DO
      END DO

      OPEN(UNIT=9,
     *  FILE='data/osu_albedo_5x6_2011',
     *  STATUS='OLD',FORM='UNFORMATTED')
      READ(9) BOUNDUM
      CLOSE(9)

      DO J = 1,L_JSIZE-1
        DO I = 1,L_ISIZE
          ALSP(J,I) = BOUNDUM(J+1,I)
        END DO
      END DO

!  NPCFLAG - template that defines where the north polar ice cap is.

      open(20,file='data/npcflag_osu_550_intel',
     *        status='old',form='unformatted')
      read(20) npcflagin
      close(20)

      do j=1,L_J-1
        do i=1,L_I
          npcflag(j,i) = npcflagin(j+1,i)
        end do
      end do

C  Read in the opacity maps if VDUST = .TRUE., otherwise read in
C  the opacity ascii file (original GCM method).  VDUST modification
C  made 7/19/01.  UNIT 85 is to remain open throughout the run.

!  opacitymap_0.3 has 3 Ls values:  359.7, 359.8, 359.9  & all
!  opacity values are 0.30000000000000

      IF(VDUST) THEN
      open(85,file=
     * 'data/TES_my24_dustscenario_zvary_37x60_6ls_intel',
!     * 'data/TES_my24_dustscenario_zmean_37x60_6ls_intel',
!     * 'data/TES_yr26_dust_opacity_37x60_intel',
     *          form='unformatted',access='direct',
     *          recl=(record_length_in_bytes / recl_unit()),
     *          status='old',iostat=ios)

        if(ios.ne.0) then
          write(6,'("Could not open data file: opacity.map")')
          stop
        end if

        do n=1,1000
          read(85,rec=n,iostat=ios) xls
!         print*,xls
          if(ios.ne.0) exit
          nvdust     = n
          vdustls(n) = xls
        end do

        if(nvdust.lt.1) then
          write(6,'("Problem with opacity.map data.")')
          stop
        endif

C  Get initial TAUTOTJI map (Ls < 0 returns first opacity record).

        xls = 0.0
        call getvdust(xls,nvdust,vdustls,TAUTOTJI)

      ELSE

C  Read in dust optical depths for each day of the run.

c       open(UNIT=4,FILE='/home/jschaef/gcm/gcmdata/opacity.ascii',
c    *       status='OLD')
c       read(4,36) dummy
c  36   format(a64)

        do n=0,360
c         read(4,*) xls, dustod(n)
          dustod(n) = TAUTOT
        end do
        close(4)

C  GCM1.7   6/28/01
C  This is where spatially varying dust (at the RPTAU reference
C  pressure) is set.  In this picture, dustod is a global scale
C  factor acting on TAUTOTJI.  TAUTOTJI(J,I) is the dust optical
C  depth at the RPTAU reference pressure (6.1 mbar is the current
C  standard reference pressure).  TAUPAT(J,I) is the spatially varying
C  scale factor, TAUTOT is the global factor (aka the viking dust
C  history and so on) and can change with time.  TAUPAT(J,I) can
C  vary in time, but for now is constant.  When we start to model
C  the TES results using the TES opacities, that will enter through
C  TAUPAT.

C  Remember, the c-grid J=1 is NOT the south pole, adjust possible
C  patterns accordingly.

        do J=1,L_J-1
          do I = 1,L_I
            TAUPAT(J,I) = 1.0D0
          end do
        end do

        do J=1,L_J-1
          do I = 1,L_I
            TAUTOTJI(J,I) = TAUTOT*TAUPAT(J,I)
          end do
        end do

      END IF

      CALL EMISS
      RAD = RAD*1000.0
      CALL MAGFAC

C     Initialize new pbl code

      CALL INITPBL

C     Initialize the dust tracer code

      CALL INITDT

      CALL INITCLD

      icethresh_kgm2=icethresh_depth*dpden_ice*1.e-6

!     IF(TAUI.NE.0.0)  GOTO 200
      if(rsetsw.eq.warmstart) goto 200

C     START UP FROM DATA FILES AND CONSTANTS...   COLD START
C     ISOTHERMAL ATMOSPHERE WITH NO WINDS.

      RUNNUM = RUNNUMX
      TAU    = 0.0
      CALL INIT1

      CALL INSDET(rsetsw)
      TOFDAY = 0.0

C     Because the initial TAUTOT value is anywhere in the dustod array,
C     not necessarily the first value, we need to get the Ls now, and
C     the appropiate TAUTOT value.
C  VDUST update 7/19/01:  if VDUST = .TRUE. use opacity maps, otherwise
C  use the old GCM "TAUTOT" method.

      call nextls(igrow,igmax,sdedy,sunstp,anome,eccn,vinc,xls)

      if(VDUST) then
        call getvdust(xls,nvdust,vdustls,TAUTOTJI)
      else
        call interpdust(xls,dustod,TAUTOT)

C  GCM1.7   6/28/01

        do J=1,L_J-1
          do I = 1,L_I
            TAUTOTJI(J,I) = TAUTOT*TAUPAT(J,I)
          end do
        end do
      endif

C     SET UP HISTORY TAPE

      VOLNO = 1
      TAUTS = 0.0
      TAUTE = TAUE+0.001
      KTP   = 11

C     Write out the initial tape header - written on each tape
C     Used for standard 50-day history stuff

      CALL MHISTH(TOPOG,ALSP,ZIN,sdepth,dsig,dxyp,
     *            runnum,decmax,eccn,orbinc,vinc)

      IBLKCT = 0
      IF(KEY13)GO TO 8000
      CALL HISTORY

      GOTO 8000

C     HISTORY TAPE RESTART

  200 CONTINUE

      KTPR = 51
      KTP  = 11

!     Modified warmstart logic

      READ(KTPR) runnum, taux, tauts, taute

      if(abs(taux-tauih).gt.0.01) then
        write(6,'(//)')
        write(6,'("Problem with warm start:  check requested time.")')
        stop
      end if

!     We've got the correct file - proceed with the warm start

      CALL M4READ(KTP)

      READ(KTPR) PNLS, PNLAT, CNLS, CNLAT, PSLS, PSLAT, CSLS, CSLAT,
     *           FUDG, PREV, ANMTSP, AORB, ASYM, DECMAX, ECCN,
     *           EGOGND, EG15GND, ETAS, ETPER, NSMTH, ORBINC, PMIN,
     *           ROT, RUNNUM, TINP, TSTART, VINC, TREFR, ALFRAY
      READ(ktpr) IMAXCN, IMAXCS, IMAXPN, IMAXPS, ISIZE, JSIZE, LAYERS,
     *           K1, LRAY, NPDST

      READ(KTPR)

      read(ktpr) TAUx, dclk, sind, cosd, tofday, sunstp, rotper, sdedy,
     *           sdeyr, vout, day, psf, psl, ptrop, etaout, ntape, ed,
     *           vpout, igrow, igmax, lat, dxu, dyu, dxyp, f,
     *           sinl, cosl, axu, axv, ayu, ayv, jbpn, jbcn, jbps, jbcs,
     *           conrnu, nstep, dlic, iblkct, co2latst

      TAUXM = TAUX
      read(ktpr) FA, SDGR, DELTAT, DELTAU,
     *           DELTAV, HTHST, HSOLST, HRAD, HCOND, DMADT,
     *           PCONSAV, STRESSX, STRESSY, SD, GEOT, TS, P,
     *           U, V, T, TSTRAT, GT, CO2ICE, TINF, SSUN, FLUXSURF,
     *           RIROUT, DISGRN, TAUSURF
      READ(KTPR) FRY, HSOLCO2, HSOLDST, HTH15, HTHOUT, HCONADJ, HTURBO,
     *           HRINUM, FCONADJ, FTURBO, FRINUM, FRAYFR, HRAYFR,
     *           DISRAY, CO2LAT
      READ(KTPR) DNDIFFV, DNIRFLUX, RHOUCH

!  FCC Save

      READ(KTPR) TAUREFCLD, QEXTREFCLD, QXVCLD, QSVCLD, GVCLD,
     *           QXICLD, QSICLD, GICLD, QEXTREFDST, QXVDST,
     *           QSVDST, GVDST, QXIDST, QSIDST, GIDST, ATMCOND,
     *           LATHEAT, CUMTAUV, SCAVEFF, LON2PM, NIT,
     *           NSTEPC3, firstcall

C WARM START: READ TSOIL FROM FORT.91: THE RECORD CONTAINING TSOIL
C AND SMOOTHED WINDSHEAR FROM TIME T-1

      READ(91) DU_PBL
      READ(91) STEMP
C Read C grid dynamics- a bit of a waste but it's only done every
C 160 timesteps
      READ(91) PIB,UOB,VOB,POB,QOB,QOC,JY1,JY2
      READ(91) QTRACE
      READ(91) QCOND
      READ(91) QTDELTA
      READ(91) NPCFLAG

      do j=1,l_j
       do i=1,l_i
        do l=1,l_layers
         k=2*l+2
         tsave(j,i,k)=t(j,i,l)
         do m=1,ntrace
          qsave(j,i,k,m)=qtrace(j,i,l,m)
         enddo
        enddo
       enddo
      enddo

!  end warm start updates

      if(rename.eq.renameyes) then
        TAU   = 0.0
        NTAPE = 0
      else
        TAU    = TAUX
      end if

      RUNNUM = RUNNUMX
      CALL INSDET(rsetsw)

C     Get the current dust-loading for this Ls.
C     VDUST update added 7/19/01

      if(VDUST) then
        call getvdust(vpout,nvdust,vdustls,TAUTOTJI)
      else
        call interpdust(vpout,dustod,TAUTOT)

C  GCM1.7   6/28/01

        do J=1,L_J-1
          do I = 1,L_I
            TAUTOTJI(J,I) = TAUTOT*TAUPAT(J,I)
          end do
        end do
      endif

      call dustprofile  !  Added 08-07-06

      TAUE   = TAUI+TAUE
      TAUI   = TAU
      TOFDAY = MOD(TAU,ROTPER)  ! generic MOD
      WRITE(MTP,9839) TAU
      GOTO 8000

C     TAPE ID DOESNT MATCH EXPERIMENT ID

 1000 CONTINUE

      WRITE(MTP,9835) TID,ID
      GOODINP = .FALSE.

 8000 CONTINUE

c     Check that the albedo and thermal inertia of the north polar cap
c     is not too low.

!     DO J=1,L_J
!       DO I=1,L_I
!         IF (NPCFLAG(J,I)) THEN
!            ALSP(J,I)  = max(ALSP(J,I),0.325)
!            ZIN(J,I,1) = max(ZIN(J,I,1),500.)
!            DO N=1,NL
!              ZIN(J,I,N) = ZIN(J,I,1)
!            END DO
!         ENDIF
!       ENDDO
!     ENDDO

C     Put input value of runnum into the CH array.

      RUNNUM = RUNNUMX

      RETURN

 9002 FORMAT (1X,'IGMAX=',I5,5X,'TSTART=',F10.2,5X,'TAURUN=',F7.2,
     *        5X,' MPRINT=',I4)
 9010 FORMAT( ///,1X, '#########  ERROR: ', I3,
     *                ' IS AN INVALID VALUE FOR NICETOP.  #########')
 9050 FORMAT (10A4)
 9190 FORMAT('1*****  DEFAULT INPUT VALUES  **********')
 9193 FORMAT('1********  RUNNING VALUES  *************')
 9835 FORMAT(2X, 'TAPE ID (',A4,') DOESNT MATCH EXPERIMENT ID (',A4,')')
 9837 FORMAT(2X, 'END OF TAPES FOR EXPERIMENT (', A4, ') ENCOUNTERED',/,
     *       2X, ' STARTING AT END OF VOLUME ',I2)
 9839 FORMAT(2X, 'EXPERIMENT RESTARTING FROM TAPE AT TAU=',
     *            F15.5)
 9841 FORMAT(2X, 'TAU=',F15.5,'   NOT FOUND ON TAPE (',A4,')  VOLUME ',
     *       I2, / ,
     *       2X, 'CHANGING FROM TAPE ',I2,' TO TAPE ', I2)
 9843 FORMAT(1X, '==>  HISTORY RECORD READ AT TAU=', F15.5)

      END

      integer function recl_unit()
      implicit none

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! Figure out the units that the "recl=" specifier wants when opening
!! a file for direct access.  Some compilers specify recl in bytes,
!! some specify it in "words", which is usually 4 bytes, but not always.
!!
!! The return value of this function is the number of bytes that
!! "recl=1" would use.  It can thus be used to create a system
!! independent "open" specification: have the code internally specify
!! the record length in bytes, and then open the file with, e.g.:
!!      open(unit_number, filename, access='direct',
!!     *     recl= record_length_in_bytes / recl_unit() )
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      !! Find out how many "units" a real*8 value would take.
      !! We use real*8 because we know by definition that it is 8 bytes
      !! long, and no compiler I'm aware of counts recl in units that
      !! are bigger than that.
      real*8  :: fake
      integer :: num_units

      inquire(iolength=num_units) fake

      if (num_units .eq. 1) then
          recl_unit = 8
      else if (num_units .eq. 2) then
          recl_unit = 4
      else if (num_units .eq. 4) then
          recl_unit = 2
      else if (num_units .eq. 8) then
          recl_unit = 1
      else
          stop 'Impossible "recl=" specification'
      endif

      return
      end


	module SAM_ModuleDefs
    !-------------------------------------------------------------------------------!
    !     Contains defintion of derived data types and constants which are          !
    !     to be used in the intermediate SAMUCA model (Following CANEGRO - MJ)      !
    !-------------------------------------------------------------------------------!

    !--- DSSAT's Global Variables
    use ModuleDefs
    save

    !--- The name of the (current) cultivar
      CHARACTER*20 CULTIVAR, SCSTGNAM(20), GROWTHPHASES(5)

!     Phenological stages (to cope with DSSAT GSTD):
!     Sugarcane 'agronomical' growth stages:
!       1: emergence
!       2: tillering
!       3: tillering following stalk emergence
!       4: Stalk elongation and tiller senescence
!     Note that sugarcane has 11 physiological stages (see Moore & Botha, 2013)

      type CaneSamuca

          !--- Samuca's states variables
          integer   seqnow
          integer   year
          integer   doy
          integer   das
          integer   dap
          integer   n_lf_AG_dewlap
          integer   nratoon
          integer   n_ph
          real      diac
          real      dw_total
          real      dw_aerial
          real      dw_BG
          real      dw_it_ag
          real      dw_lf
          real      dw_rt
          real      dw_it_dead
          real      dw_it_dead_AG
          real      dw_it_dead_BG
          real      dw_lf_dead
          real      fw_it_ag
          real      suc_it_ag
          real      pol
          real      lai
          real      lai_ass
          real      nstk
          real      stk_h
          real      swface
          real      swfacp
          real      rd
          real      rld(nl)
          real      frac_li_pho
          real      frac_li_till
          real      trwup
          real      eop
          real      watdmd
          real      tot_gresp_crop
          real      tot_mresp_crop
          real      gstd
          real      dtg
          real      drue_calc
          real      rue_calc
          real      cstat
          real      amax_out
          real      eff_out
          real      tmn
          real      tempfac_pho
          real      tempfac_per
          real      co2
          real      pho_fac_co2
          real      diacem
          real      agefactor_amax
          real      agefactor_per
          real      sug_it_BG
          real      amaxfbfac
          real      per

          logical   flemerged
          character 	(len = 6)	pltype      ! Planting type (Ratoon or PlCane)
          character 	(len = 6)	cropstatus  ! Dead or Alive
	      character 	(len = 6)	cropdstage  ! Development Stage - Only Sprout or Emergd

          !--- Arrays
          real      phprof(200,60)              ! Phytomer profiles
          real      tillerageprof(100,2)        ! Tillers age profiles
          real      Acanopy(3+1,5+1)            ! Instantaneous CO2 Assimilation Rate at three hours and five canopy depth in kg(CO2) ha-1(leaf) h-1
          real      Qleaf(3+1,5+1)              ! Instantaneous par absorbed by leaves at three hours and five canopy depth in W m-2
          real      incpar(3,4)                 ! Incoming direct, difuse and total par radiation above canopy in three hours W m-2
          real      photo_layer_act(3)          ! Actual Total Daily Photosynthesis per canopy Layer
          logical   fl_it_AG(200)               ! Above Ground Internode Flag
          logical   fl_lf_AG(200)               ! Above Ground Leaf Flag
          logical   fl_lf_alive(200)            ! This leaf is alive (T/F)?

        end type CaneSamuca

      end module SAM_ModuleDefs


program vhone

!--------------------------------------------------------------------------
!
!    MM        MM    VV              VV   HH       HH       3333333
!    MMMM    MMMM     VV            VV    HH       HH      333    333
!    MM MM  MM MM      VV          VV     HH       HH              333
!    MM  MMMM  MM       VV        VV      HH       HH            333
!    MM   MM   MM        VV      VV       HHHHHHHHHHH          333
!    MM        MM         VV    VV        HH       HH            333
!    MM        MM          VV  VV         HH       HH              333
!    MM        MM           VVVV          HH       HH      333    333
!    MM        MM            VV           HH       HH       3333333
!
!
!                   MPI - VIRGINIA HYDRODYNAMICS - 3D
!
!--------------------------------------------------------------------------
!  The Virginia Numerical Bull Session ideal hydrodynamics PPMLR
!
!  Version 3.1 July 2008
!    Cleaned up code, minor changes to algorithm, 2/3D output
!    Diced MPI version uses a 'julienne' domain decomposition for better scaling
!  Version 3.0 c. 2003
!    Converted to F90 free-format, use netcdf for binary output
!  Version 2.0 July 1997
!    Many small modifications, mainly brought BCs into only one call to sweepbc
!  Version 1.0 October 1991
!    This version was removed from the ``loop'' in the continued development
!    of VH-1 on Sep 1 1990, but has followed a similar evolution until this
!    release date.
!
! Output channels:
!                 4 = aaaaadaa.####,   binary dump files for restarting
!                 8 = aaaaa.hst,   history file
!                     aaaaaXY.nc,   netCDF movie of XY slice
!                     aaaaa_1000.NNN, netCDF output of dataset (all variables) for slab NNN
!-------------------------------------------------------------------------------

! GLOBALS
use global
use zone
use sweepsize
use mpi

IMPLICIT NONE

! LOCALS
CHARACTER(len=50) :: hstfile
CHARACTER(len=8)  :: dmpfile
CHARACTER(len=4)  :: tmp4
CHARACTER(len=2)  :: rstrt
CHARACTER(len=8)  :: todayis
CHARACTER(len=MPI_MAX_PROCESSOR_NAME) :: myname

INTEGER :: jcol, krow, n, nfile_start
INTEGER :: ncycend, nprin, ndump, nmovie, tmpcyc, mpierr,start_cycl, namelength
REAL :: endtime,tprin,tmovie, olddt
REAL(8) :: start_time,end_time,run_time,zones

NAMELIST / hinput / rstrt, prefix, ncycend, ndump, nprin, nmovie, endtime, tprin, tmovie

!-----------------------------------------------------------------------------------------
! Initialize MPI
call MPI_INIT(mpierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD,  npe, mpierr)
call MPI_COMM_RANK(MPI_COMM_WORLD, mype, mpierr)

! Set VH1_DATATYPE for MPI calls
if (SIZEOF(endtime)==8) then
  VH1_DATATYPE = MPI_DOUBLE_PRECISION
elseif (SIZEOF(endtime)==4) then
  VH1_DATATYPE = MPI_REAL
else
  if(mype==0) write(*,*) 'Mode not recognized. MPI commands will fail.'
  stop
endif

! set dimensions of local simulation grid  (imax X js X ks)
js   = jmax / pey
ks   = kmax / pez
isy  = imax / pey
isz  = imax / pez
ndim = 3; if (kmax==1) ndim = 2

! set size of send/receive buffers for alltoall calls
Za2abuff_size = ks * isz * js * nvar
Ya2abuff_size = ks * isy * js * nvar

jcol = mod(mype,pey)   ! processor rank in the Y direction
krow = mype / pey      ! processor rank in the Z direction

! Create communicators for each value of krow (for XY transpose)
call MPI_COMM_SPLIT(MPI_COMM_WORLD, krow, mype, MPI_COMM_ROW, mpierr)
  call MPI_COMM_RANK(MPI_COMM_ROW, mypey, mpierr)
  call MPI_COMM_SIZE(MPI_COMM_ROW, npey, mpierr)

! Create communicators for each value of jcol (for XZ transpose)
call MPI_COMM_SPLIT(MPI_COMM_WORLD, jcol, mype, MPI_COMM_COL, mpierr)
  call MPI_COMM_SIZE(MPI_COMM_COL, npez, mpierr)
  call MPI_COMM_RANK(MPI_COMM_COL, mypez, mpierr)

! should have npey = pey, npez = pez, mypey = jcol, mypez = krow

! Check that code is running with desired number of PE's
if (pey*pez /= npe) then
  write(*,*) 'sorry, I was compiled for ',pey*pez,' PEs, but npe= ', npe
  stop
endif

! Check that arrays are large enough for desired number of physical zones
if (max(imax,jmax,kmax)+12 > maxsweep) then
  write(*,*) 'maxsweep too small'
  stop
endif

! Check that imax and jmax are multiples of npey
if (isy*npey /= imax) then
  write(*,*) 'imax is not an integer multiple of pey', imax, pey
  stop
endif
if (js*npey /= jmax) then
  write(*,*) 'jmax is not an integer multiple of pey', jmax, pey
  stop
endif

! Check that imax and kmax are multiples of npez
if (isz*npez /= imax) then
  write(*,*) 'imax is not an integer multiple of pez', imax, pez
  stop
endif
if (ks*npez /= kmax) then
  write(*,*) 'kmax is not an integer multiple of pez', kmax, pez
  stop
endif

! Begin by reading input deck, and defining file names

open (unit=15,file='indat',status='old',form='formatted')
read (15,nml=hinput)
close(15)

write(tmp4,"(i4)") mype
do n = 1, 4
  if ((tmp4(n:n)) == ' ') tmp4(n:n) = '0'
enddo
dmpfile = 'daa.' // tmp4

if ((rstrt == 'NO').or.(rstrt == 'no')) then ! Initialize variables for new problem;

  if (mype == 0) then

   hstfile = 'output/' // trim(prefix) // '.hst'
   open (unit=8,file=hstfile,form='formatted')
   call date_and_time(todayis)
   write (8,*) 'History File for VH1-MPI simulation run on ', todayis(5:6), ' / ', todayis(7:8), ' / ', todayis(1:4)

   call MPI_GET_PROCESSOR_NAME(myname, namelength, mpierr)
   write (8,"(' machine id: ',a25)") myname
   if (ndim==3) then
    write (8,"(' Running 3 dimensions on ',i4,' processors, split ',i3, ' X ', i3)") npe,npey,npez
   else
    write (8,"(' Running 2 dimensions on ',i3,' processors' )") npe
   endif

   if(VH1_DATATYPE==MPI_DOUBLE_PRECISION) then
     write(8,*) 'Running in double precision mode'
   else
     write(8,*) 'Running in single precision mode'
   endif
   write (8,*)

  endif

  call init
  nfile_start = nfile
  call prin

else ! Restart from old dumpfile...

  dmpfile = 'd' // rstrt(1:2) // dmpfile(4:8)
  if (mype == 0) then
   hstfile = 'output/' // trim(prefix) // '.hst'
   open (unit=8,file=hstfile,form='formatted',position='append')
   call date_and_time(todayis)
   write (8,*) 'Restarting run on ', todayis(5:6), ' / ', todayis(7:8), ' / ', todayis(1:4)
  endif
  call undump(dmpfile)
  if(timep >= tprin)  timep = tprin -2.0*dt    ! adjust so that dt is not set to zero on first step
  if(timem >= tmovie) timem = tmovie-2.0*dt
  nfile_start = nfile

endif

if(mype == 0) then
  start_time = MPI_WTIME()
  start_cycl = ncycle
  write(8,*) 'Starting on cycle number ',ncycle
endif

!############################################################################
!                         MAIN COMPUTATIONAL LOOP

do while (ncycle < ncycend)

!  if(mype == 0) write(*,*) 'STEP = ',ncycle

  ncycle = ncycle + 2
  ncycp  = ncycp  + 2
  ncycd  = ncycd  + 2
  ncycm  = ncycm  + 2
  olddt  = dt
  svel   = 0.

  if ( time + 2*dt > endtime ) then ! set dt to land on endtime
    if(mype==0) write(8,*) 'cutting to the end...', ncycle, ncycend
    dt = 0.5*(endtime - time)
    ncycend = ncycle-1
    ncycp   = nprin
    ncycd   = ndump
  else if ( timep+2.0*dt > tprin ) then ! set dt to land on tprin
    dt = 0.5*(tprin - timep)
    ncycp = nprin
  else if ( timem+2*dt > tmovie ) then ! set dt to land on tmovie
    dt = 0.5*(tmovie - timem)
    ncycm = nmovie
  endif

! Alternate sweeps to approximate 2nd order operator splitting

  call sweepx1
  call sweepy

  if (ndim==3) then
   call sweepz
   call sweepy
  endif

  call sweepx2

  time  = time  + 2.0*dt
  timep = timep + 2.0*dt
  timem = timem + 2.0*dt
  dt = olddt

  call dtcon   ! Check constraints on the timestep

  ! output movie images/datasets/dumpfiles based on simulation time or cycle #

  if ( ncycm >= nmovie .or. timem >= tmovie ) then
    if (mypez == 0) call imagesxy
    if ((mypey == 0).and.(ndim==3)) call imagesxz
    timem = 0.0
    ncycm = 0
  endif

  if ( ncycp >= nprin .or. timep >= tprin ) then
    call prin
    timep = 0.
    ncycp = 0
  endif

  if ( ncycd >= ndump ) then
    ncycd = 0
    call dump(dmpfile)
  endif

enddo

!                           END OF MAIN LOOP
!#########################################################################

if(mype == 0) then

  end_time = MPI_WTIME()
  zones = (imax*js*ks)*(ncycle - start_cycl)
  run_time = end_time - start_time
  write(8,*) 'successful stop at cycle number', ncycle
  if (run_time>4000.0) then
    write(8,*) 'elapsed time = ',run_time/3600., ' hours'
  else
    write(8,*) 'elapsed time = ',run_time/60., ' minutes'
  endif
  write(8,"('speed = ',f5.1,' kz/s/pe')") 1.0e-3*zones/run_time
  close( 8 )

  if (ndim==3) then ! open up a file to store data needed for post-processing
   open(9,file='output/postprocess')
     write(9,*) trim(prefix)
     write(9,*) nfile_start
     write(9,*) nfile - nfile_start
     write(9,*) npez
   close(9)
  endif

endif

call MPI_FINALIZE(mpierr)

stop
end


        SUBROUTINE UMD2FB (XX, XSIZE, II, ISIZE, N, NZ, NZDIA, NZOFF,
     $          NBLKS, CP, CPERM, RPERM, PR, PC,
     $          W, ZPERM, BP, OFFP,
     $          PRESRV, ICNTL)
        INTEGER N, NZ, ISIZE, II (ISIZE), NZDIA, NZOFF, NBLKS, CP (N+1),
     $          CPERM (N), RPERM (N), PR (N), PC (N), W (N), ZPERM (N),
     $          BP (N+1), OFFP (N+1), ICNTL (20), XSIZE
        LOGICAL PRESRV
        DOUBLE PRECISION
     $          XX (XSIZE)

C=== UMD2FB ============================================================
C
C  Unsymmetric-pattern MultiFrontal Package (UMFPACK). Version 2.2d
C  Copyright (C) 1997, Timothy A. Davis, University of Florida, USA.
C  ALL RIGHTS RESERVED.
C  Joint work with Iain S. Duff, Rutherford Appleton Laboratory, UK.
C  July 7, 1997. Work supported by the National Science Foundation
C  (DMS-9223088 and DMS-9504974) and the State of Florida; and by CRAY
C  Research Inc. through the allocation of supercomputing resources.

C***********************************************************************
C* NOTICE:  "The UMFPACK Package may be used SOLELY for educational,   *
C* research, and benchmarking purposes by non-profit organizations and *
C* the U.S. government.  Commercial and other organizations may make   *
C* use of UMFPACK SOLELY for benchmarking purposes only.  UMFPACK may  *
C* be modified by or on behalf of the User for such use but at no time *
C* shall UMFPACK or any such modified version of UMFPACK become the    *
C* property of the User.  UMFPACK is provided without warranty of any  *
C* kind, either expressed or implied.  Neither the Authors nor their   *
C* employers shall be liable for any direct or consequential loss or   *
C* damage whatsoever arising out of the use or misuse of UMFPACK by    *
C* the User.  UMFPACK must not be sold.  You may make copies of        *
C* UMFPACK, but this NOTICE and the Copyright notice must appear in    *
C* all copies.  Any other use of UMFPACK requires written permission.  *
C* Your use of UMFPACK is an implicit agreement to these conditions."  *
C*                                                                     *
C* The MA38 Package in Release 12 of the Harwell Subroutine Library    *
C* (HSL) has equivalent functionality (and identical calling interface)*
C* as UMFPACK (the HSL has single and double precision versions only,  *
C* however).  It is available for commercial use.   Technical reports, *
C* information on HSL, and matrices are available via the World Wide   *
C* Web at http://www.cis.rl.ac.uk/struct/ARCD/NUM.html, or by          *
C* anonymous ftp at seamus.cc.rl.ac.uk/pub.  Also contact Dr. Scott    *
C* Roberts, Harwell Subroutine Library, B 552, AEA Technology,         *
C* Harwell, Didcot, Oxon OX11 0RA, England.                            *
C* telephone (44) 1235 434988, fax (44) 1235 434136                    *
C* email Scott.Roberts@aeat.co.uk, who will provide details of price   *
C* and conditions of use.                                              *
C***********************************************************************

C=======================================================================
C  NOT USER-CALLABLE.

C=======================================================================
C  DESCRIPTION:
C=======================================================================
C
C  Find permutations to block triangular form:
C       1) permute the matrix so that it has a zero-free diagonal.
C       2) find strongly-connected components of the corresponding
C          graph.  Each diagonal block corresponds to exactly one
C          strongly-connected component.
C       3) convert the matrix to block triangular form, unless it is
C          to be preserved in its original form.

C  Calls Harwell MA28 routines MC21B and MC13E, which can be obtained
C  separately from Netlib.  Send email to netlib@ornl.gov with the
C  message:
C       send mc13e.f mc21b.f from harwell

C=======================================================================
C  INSTALLATION NOTE:
C=======================================================================
C
C  If the MA28 Harwell Subroutine Library routines MC21B and MC13E
C  (which perform the permutation to block-triangular-form) are not
C  available, then you may comment out all executable code in this
C  routine, or place a "return" statement as the first executable
C  statement (see below).  If you do make this modification, please do
C  not delete any original code.  Add a comment and date to your
C  modifications.

C=======================================================================
C  INPUT:
C=======================================================================
C
C       presrv:         true if original matrix is to be preserved
C       n:              order of matrix
C       nz:             entries in matrix
C       isize:          size of II
C       xsize:          size of XX
C       Cp (1..n+1):    column pointers
C       XX (1..nz):     values
C       II (1..nz):     row indices
C       Icntl:          integer control arguments
C
C          input matrix in column form is in:
C          XX (1..nz), II (1..nz), n, nz, Cp (1..n+1), where
C               II (Cp(col) ... Cp(col+1)-1): row indices
C               XX (Cp(col) ... Cp(col+1)-1): values
C          if presrv is false then xsize and isize must be >= 2*nz
C          otherwise, xsize and isize must be >= nz

C=======================================================================
C  WORKSPACE:
C=======================================================================
C
C       Pr (1..n), Pc (1..n), W (1..n), Zperm (1..n)

C======================================================================
C  OUTPUT:
C=======================================================================
C
C       nblks: number of blocks
C       if (nblks > 1):
C
C           Cperm (1..n), Rperm (1..n): permutation to block form:
C               Rperm (newrow) = oldrow
C               Cperm (newcol) = oldcol
C
C           Bp (n-nblks+1...n+1) holds the start/end of blocks 1..nblks
C
C           if (presrv is false) then
C
C              input matrix is converted to block-upper-tri. form,
C              using II/XX (nz+1..2*nz) as workspace.
C              nzdia: nonzeros in diagonal blocks
C              nzoff: nonzeros in off-diagonal blocks
C              (nz = nzdia + nzoff)
C
C              off-diagonal column-oriented form in XX/II (1..nzoff)
C              col is located in
C              XX/II (Offp (col) ... Offp (col+1)-1)
C
C              diagonal blocks now in XX/II (nzoff+1 .. nzoff+nzdia)
C              col is located in
C              XX/II (Cp (col) ... Cp (col+1)-1)
C
C       else, nblks=1: and no other output is generated.

C=======================================================================
C  SUBROUTINES AND FUNCTIONS CALLED / CALLED BY:
C=======================================================================
C
C       called by subroutine:   UMD2F0
C       subroutines called:     MC21B, MC13E (in MA28 HSL package)

C=======================================================================
C  LOCAL SCALARS:
C=======================================================================

        INTEGER COL, NDIAG, I, PO, PB, BLK, P, ROW, K1, K

C  ndiag:   number of entries on the diagonal
C  po:      pointer into off-diagonal part
C  pb:      pointer into diagonal blocks
C  blk:     block number for current diagonal block
C  k1:      column col is in diagonal block A (k1.., k1...)
C  k:       kth row/col in BTF form is Rperm(k)/Cperm(k) in input matrix
C  p:       pointer
C  row:     row index
C  col:     column index
C  i:       general loop index

C=======================================================================
C  EXECUTABLE STATEMENTS:
C       if (MC21B and MC13E not available during installation) return
C=======================================================================

        NZDIA = NZ
        NZOFF = 0

C-----------------------------------------------------------------------
C compute the length of each column
C-----------------------------------------------------------------------

        DO 10 COL = 1, N
           W (COL) = CP (COL+1) - CP (COL)
10      CONTINUE

C-----------------------------------------------------------------------
C find a column permutation for a zero-free diagonal
C-----------------------------------------------------------------------

        CALL MC21B (N, II, NZ, CP, W, ZPERM, NDIAG, OFFP, CPERM, PR, PC)
C          MC21B calling interface:
C          input:       n, II (1..nz), nz, Cp (n), W (n):
C                       n-by-n matrix, col is of length W (col),
C                       and its pattern is located in
C                       II (Cp (col) ... Cp (col)+W(col)-1)
C          output:      Zperm (n), the permutation, such that
C                       colold = Zperm (col), and ndiag (number of
C                       structural nonzeros on the diagonal.
C                       matrix is structurally singular if ndiag < n
C          workspace:   Offp, Cperm, Pr, Pc

C-----------------------------------------------------------------------
C  permute the columns of the temporary matrix to get zero-free diagonal
C-----------------------------------------------------------------------

        DO 20 COL = 1, N
           OFFP (COL) = CP (ZPERM (COL))
           W (COL) = CP (ZPERM (COL)+1) - CP (ZPERM (COL))
20      CONTINUE

C-----------------------------------------------------------------------
C  find a symmetric permutation into upper block triangular form
C  (that is, find the strongly-connected components in the graph).
C-----------------------------------------------------------------------

        CALL MC13E (N, II, NZ, OFFP, W, RPERM, BP, NBLKS, CPERM, PR, PC)
C          MC13E calling interface:
C          input:       n, II (1..nz), nz, Offp (n), W (n)
C                       n-by-n matrix, col of length W(col),
C                       in II (Offp(col) ... Offp(col)+W(col)-1), where
C                       this permuted matrix has a zero-free diagonal
C                       (unless the matrix is structurally singular).
C          output:      Rperm (n), Bp (n+1), nblks
C                       old = Rperm (new) is the symmetric permutation,
C                       there are nblks diagonal blocks, Bp (i) is
C                       the position in new order of the ith block.
C          workspace:   Cperm, Pr, Pc

C-----------------------------------------------------------------------
C  if more than one block, get permutations and block pointers,
C  and convert to block-upper-triangular form (unless matrix preserved)
C-----------------------------------------------------------------------

        IF (NBLKS .NE. 1) THEN

C          -------------------------------------------------------------
C          find the composite column permutation vector (Cperm):
C          -------------------------------------------------------------

           DO 30 COL = 1, N
              CPERM (COL) = ZPERM (RPERM (COL))
30         CONTINUE

C          -------------------------------------------------------------
C          convert to block-upper-triangular form, if not preserved
C          -------------------------------------------------------------

           IF (.NOT. PRESRV) THEN

C             ----------------------------------------------------------
C             find the inverse permutation vectors, Pr and Pc
C             ----------------------------------------------------------

              DO 40 K = 1, N
                 PC (CPERM (K)) = K
                 PR (RPERM (K)) = K
40            CONTINUE

C             ----------------------------------------------------------
C             construct flag array to determine if entry in block or not
C             ----------------------------------------------------------

              BP (NBLKS+1) = N+1
              DO 60 BLK = 1, NBLKS
                 DO 50 I = BP (BLK), BP (BLK+1)-1
                    W (I) = BP (BLK)
50               CONTINUE
60            CONTINUE

C             ----------------------------------------------------------
C             construct block-diagonal form in XX/II (nz+1..nz+nzdia)
C             ----------------------------------------------------------

C             These blocks are in a permuted order (according to Rperm
C             and Cperm).  The row indices in each block range from 1
C             to the size of the block.

              PB = NZ + 1
              DO 80 COL = 1, N
                 ZPERM (COL) = PB
                 K1 = W (COL)
CFPP$ NODEPCHK L
                 DO 70 P = CP (CPERM (COL)), CP (CPERM (COL)+1)-1
                    ROW = PR (II (P))
                    IF (W (ROW) .EQ. K1) THEN
C                      entry is in the diagonal block:
                       II (PB) = ROW - K1 + 1
                       XX (PB) = XX (P)
                       PB = PB + 1
                    ENDIF
70               CONTINUE
80            CONTINUE
C             Zperm (n+1) == pb  ( but Zperm (n+1) does not exist )
              NZDIA = PB - (NZ + 1)
              NZOFF = NZ - NZDIA

C             diagonal blocks now in XX/II (nz+1..nz+nzdia)
C             col is located in XX/II (Zperm (col) ... Zperm (col+1)-1)

C             ----------------------------------------------------------
C             compress original matrix to off-diagonal part, in place
C             ----------------------------------------------------------

C             The rows/cols of off-diagonal form correspond to rows/cols
C             in the original, unpermuted matrix.  They are permuted to
C             the final pivot order and stored in a row-oriented form,
C             after the factorization is complete (by UMD2OF).

              PO = 1
              DO 100 COL = 1, N
                 OFFP (COL) = PO
                 K1 = W (PC (COL))
CFPP$ NODEPCHK L
                 DO 90 P = CP (COL), CP (COL+1)-1
                    ROW = PR (II (P))
                    IF (W (ROW) .NE. K1) THEN
C                      offdiagonal entry
                       II (PO) = II (P)
                       XX (PO) = XX (P)
                       PO = PO + 1
                    ENDIF
90               CONTINUE
100           CONTINUE
              OFFP (N+1) = PO

C             off-diagonal form now in XX/II (1..nzoff)
C             col is located in XX/II(Offp(col)..Offp(col+1)-1)

C             ----------------------------------------------------------
C             move block-diagonal part into place
C             ----------------------------------------------------------

              PB = NZ + 1
CFPP$ NODEPCHK L
              DO 110 I = 0, NZDIA - 1
                 II (PO+I) = II (PB+I)
                 XX (PO+I) = XX (PB+I)
110           CONTINUE
              DO 120 COL = 1, N
                 CP (COL) = ZPERM (COL) - NZDIA
120           CONTINUE
C             Cp (n+1) == nz+1  ( this is unchanged )

C             diagonal blocks now in XX/II (nzoff+1 .. nzoff+nzdia)
C             col is located in XX/II (Cp (col) ... Cp (col+1)-1)

           ENDIF

C          -------------------------------------------------------------
C          shift Bp (1 .. nblks+1) down to Bp (1+n-nblks .. n+1), which
C          then becomes the Blkp (1 .. nblks+1) array.
C          -------------------------------------------------------------

           BP (NBLKS+1) = N+1
CFPP$ NODEPCHK L
           DO 130 BLK = NBLKS + 1, 1, -1
              BP (BLK + (N-NBLKS)) = BP (BLK)
130        CONTINUE
        ENDIF

        RETURN
        END