C           SUBROUTINE INSTG
      SUBROUTINE INSTG
C     INTERSTAGE OUTPUT
C      NUMBER OF SECTORS IS THREE OR LESS,HUB AND CASING VALUES ARE
C         CALCULATED AND PRINTED
C     NUMBER OF SECTORS IS MORE THAN THREE,ONLY SECTOR PITCHLINE
C         VALUES ARE PRINTED
C
      REAL MFSTOP
      LOGICAL PREVER
      COMMON /SNTCP/G,AJ,PRPC,ICASE,PREVER,MFSTOP,JUMP,LOPIN,ISCASE,
     1KN,GAMF,IP,SCRIT,PTRN,ISECT,KSTG,WTOL,RHOTOL,PRTOL,TRLOOP,LSTG,
     2LBRC,IBRC,ICHOKE,ISORR,CHOKE,PT0PS1(6,8),PTRS2(6,8),TRDIAG,SC,RC,
     3DELPR,PASS,IPC,LOPC,ISS
C
      COMMON/GEBE/DRBARR,DRBARS,E1,E2,E3,E4,E5,E6,HBRRH,HBRSH,IAFE
     1,IALF,IBT2,ICPR,ICPS,ISR2,ISTR,ISTS,L,R1,R3,R4,R5,
     2TALF,WGT0(8),WT(7),HBARS,HBARR,I
C
      COMMON /SINIT/H1(6,8),H2(6,8),DP0(6,8),DP1(6,8),DP1A(6,8),DP2(6,8)
     1,DP2A(6,8),CSALF1(6,8),ALF1(6,8),CSBET2(6,8),BET2(6,8),RADSD(6,8),
     2RADRD(6,8),ANN1(6,8),ANN2(6,8),ANN2A(6,8),ANN1A(6,8),U1A(6,8),
     3U2(6,8),ANN0(6,8),PT0(6,8),TT0(6,8),ALPHA0(6,8),PTP(6,8)
C
      COMMON /SINPUT/
     1PTPS,PTIN,TTIN,WAIR,FAIR,DELC,DELL,DELA,AACS,VCTD,STG,SECT,EXPN,
     2EXPP,EXPRE,RG,RPM,PAF,SLI,STGCH,ENDJOB,XNAME(20),TITLE(20),
     3PCNH(6),GAM(6,8),DR(6,8),DT(6,8),RWG(6,8),ALPHAS(6,8),ALPHA1(6,8),
     4ETARS(6,8),ETAS(6,8),CFS(6,8),ANDO(6,8),BETA1(6,8),BETA2(6,8),ETAR
     5R(6,8),ETAR(6,8),CFR(6,8),TFR(6,8),ANDOR(6,8),OMEGAS(6,8),AS0(6,8)
     6,ASMP0(6,8),ACMN0(6,8),A1(6,8),A2(6,8),A3(6,8),A4(6,8),A5(6,8),A6(
     76,8),OMEGAR(6,8),BSIA(6,8),BSMPIA(6,8),BCMNIA(6,8),B1(6,8),B2(6,8)
     8,B3(6,8),B4(6,8),B5(6,8),B6(6,8),SESTHI(8),RERTHI(8)
     9,fairx(5,8),wairx(5,8),rg1(8),rg1a(8),rg2(8),rg2a(8)
C
      REAL M0
      COMMON /SSTA01/CP0(8),w0(6),               PS0(6,8),V0(6,8),TS0(6,
     18),VU0(6,8),VZ0(6,8),RHOS0(6,8),PS1(6,8),WGT1(8),TA1(8),WG1(6,8),
     2            DPDR1(6,8),SI(6,8),  CP1(8),PHI1(6,8),TS1(6,8),V1(6,8)
     3,RHOS1(6,8),ALF1E(6,8),VU1(6,8),VZ1(6,8),M0(6,8)
C
      REAL MR1A
      COMMON /SSTA1A/VU1A(6,8),WG1A(6,8),WGT1A(8),VZ1A(6,8),  CP1A(8),
     1PS1A(6,8),RU1A(6,8),R1A(6,8),BET1A(6,8),RI(6,8),TTR1A(6,8),PTR1A(6
     2,8),MR1A(6,8)
C
      COMMON /SSTA2/V2(6,8),TTR2(6,8),PTR2(6,8),WG2(6,8),WGT2(8),TA2(8),
     1           PS2(6,8),PHI2(6,8)
C
      REAL MR2,M2     ,MF2
      COMMON /SFLOW2/TS2(6,8),CP2(8),R2(6,8),RHOS2(6,8),BET2E(6,8),RU2(6
     1,8),VU2(6,8),DPDR2(6,8),VZ2(6,8),MR2(6,8),MF2(6,8),M2(6,8)
C
      REAL M2A,MF2A
      COMMON /SSTA2A/WG2A(6,8),WGT2A(8),VU2A(6,8),VZ2A(6,8),PS2A(6,8),
     1ALF2A(6,8),TT2A(6,8),PT2A(6,8),TTBAR(8),PTBAR(8),STT0(8),SPT0(8),
     2M2A(6,8),MF2A(6,8),CP2A(8),V2A(6,8),TS2A(6,8),TAS(8),PAS(8),GAMS(8
     3),CPO(8),DELHVD(6,8)
C
      COMMON /SOVRAL/DELHT(6,8),DELHTI(6,8),DELHSI(6,8),DEHATI(6,8),
     1ETATT(6,8),ETATS(6,8),ETATAT(6,8),delhtu(6,8)
C
      COMMON /C1FIT1/ STDP0(7),STTT0(7),STPT0(7),STALF(7)
     1,STSI(7),STV0(7),STVU0(7),STVZ0(7),STTS0(7),
     2STPS0(7),STDEN0(7),STM0(7),STDP1(7),STTT1(7),
     3STALFE(7),STDELA(7),STV1(7),STVU1(7),STVZ1(7),
     4STTS1(7),STPS1(7),STDEN1(7),STM1(7),ZWIINC(7),
     5CPS(7),STDP1A(7),STTTR1(7),STPTR1(7),STBET1(7),
     6STRI(7),STR1A(7),STRU1A(7),STMR1A(7),STU1A(7),
     7STDP2(7),STBET2(7),SDBETA(7),SR2(7),SRU2(7),
     8SMR2(7),SU2(7),RX(7),STDELH(7),STPSI(7),
     9SETATT(7),SETATS(7),SETAAT(7),RZWINC(7),CPR(7),
     1STDP2A(7),STPT2(7),STTT2(7),STV2(7),STVU2(7),
     2STALF2(7),STMF2(7),STVZ2(7),STTS2(7),STPS2(7),
     3STDEN2(7),STM2(7),LJ,JJ,K
      COMMON /C2FIT1/  DBARS(7),FTANS(7),FAXS(7),DBARR(7),
     1FTANR(7),FAXR(7)
      COMMON RES(8),DALF(6),DSTS(6),DALFE(6),DCPS(6),DSTR(6),
     *DBT2(6),DCPR(6),DSR2(6)
      COMMON/TPT1/PT1(6),TT1(6,8)
      COMMON/DESOPT/RVU1(6,8),RVU2(6,8),WG,EPR
      dimension tangms(6,8),tangmr(6,8),tangm1(6,8),tangm2(6,8),tang0(6)
      common/slope/tangms,tangmr,tangm1,tangm2,tang0,iar,icyl
      K=1
      ETAO1=1.
1     CONTINUE
      E1=(GAMS(K)-1.)/GAMS(K)
      E2=GAM(1,K)/(GAM(1,K)-1.)
      E3=GAM(2,K)/(GAM(2,K)-1.)
      E4=GAM(3,K)/(GAM(3,K)-1.)
      E5=GAM(4,K)/(GAM(4,K)-1.)
      E6=GAM(5,K)/(GAM(5,K)-1.)
C     RELOCATE PITCHLINE VALUES
      HBARS= (DT(1,K)-DR(1,K)+DT(2,K)-DR(2,K))/4.
      WGT0(K)= WGT1(K)/RWG(2,K)*RWG(1,K)
      DW0= WGT0(K)/(G*HBARS)
      DW0D0= DW0/DP0(IP,K)
      DW0D1= DW0/DP1(IP,K)
      HBARR= (DT(3,K)-DR(3,K)+DT(4,K)-DR(4,K))/4.
      DW1A= WGT1A(K)/(G*HBARR)
      DW1AD1= DW1A/DP1A(IP,K)
      DW1AD2= DW1A/DP2(IP,K)
      DRBARS=(DR(1,K)+DR(2,K))/2.
      DRBARR=(DR(3,K)+DR(4,K))/2.
      HBRSH=HBARS/(DT(2,K)-DR(2,K))
      HBRRH=HBARR/(DT(4,K)-DR(4,K))
      GO TO(21,22,23,24,25,26),ISECT
21    KS1=1
      KS=4
      KF=7
c     ks=2
c     kf=2
      KSD=4
      GO TO 97
22    KS=2
      KF=4
      KSD=2
      GO TO 97
23    KS=2
      KF=4
      KSD=1
      GO TO 97
24    KS=2
      KF=6
      KSD=1
      GO TO 97
25    KS=2
      KF=6
      KSD=1
      GO TO 97
26    KS=1
      KF=7
      KSD=1
      GO TO 97
97    GO TO(91,92,93,94,95,96),ISECT
91    KS1=1
      GO TO 27
92    KS1=KS/2
      GO TO 27
93    KS1=KS-1
      GO TO 27
C94    IF(KS-4)32,5,29
C     replaced by ............
94    IF((KS-4).LT.0) THEN
         GO TO 32
      ELSEIF((KS-4).EQ.0) THEN
         GO TO 5
      ELSEIF((KS-4).GT.0) THEN
         GO TO 29
      ENDIF
32    KS1=KS-1
      GO TO 27
29    KS1=KS-2
      GO TO 27
95    KS1=KS-1
      GO TO 27
C96    IF(KS-4)30,5,31
C     replaced by ............
96    IF((KS-4).LT.0) THEN
         GO TO 30
      ELSEIF((KS-4).EQ.0) THEN
         GO TO 5
      ELSEIF((KS-4).GT.0) THEN
         GO TO 31
      ENDIF
30    KS1=KS
      GO TO 27
31    KS1=KS-1
      GO TO 27
27    STTT0(KS)=TT0(KS1,K)
      STDP0(KS)=DP0(KS1,K)
      STPT0(KS)=PTP(KS1,K)
      STALF(KS)=ALPHA0(KS1,K)*57.2958
      STSI(KS)=SI(KS1,K)*57.2958
      STV0(KS)=V0(KS1,K)
      STVU0(KS)=VU0(KS1,K)
      STVZ0(KS)=VZ0(KS1,K)
      STTS0(KS)=TS0(KS1,K)
      STPS0(KS)=PS0(KS1,K)
      rg0=rg
      if (k.gt.1) rg0=rg2a(k-1)
      STDEN0(KS)=144.*STPS0(KS)/STTS0(KS)/RG0
      STM0(KS)=M0(KS1,K)
      STDP1(KS)=DP1(KS1,K)
      STTT1(KS)=TT1(KS1,K)
      STALFE(KS)=ALF1E(KS1,K)*57.2958
      STDELA(KS)=(ALPHA0(KS1,K)+ALF1E(KS1,K))*57.2958
      STV1(KS)=V1(KS1,K)
      STVU1(KS)=VU1(KS1,K)
      STVZ1(KS)=VZ1(KS1,K)
      STTS1(KS)=TS1(KS1,K)
      STPS1(KS)=PS1(KS1,K)
      STDEN1(KS)=RHOS1(KS1,K)
      STM1(KS)=V1(KS1,K)/(SQRT(GAM(2,K)*G*rg1(k)*TS1(KS1,K)))
      ZS=-2.*ALF1E(KS1,K)-1.570796
      ZWIINC(KS)=-2.*COS(ZS)/(1.0+ANN0(KS1,K)/ANN1(KS1,K))
     1*(SIN(ALPHA0(KS1,K))/COS(ALPHA0(KS1,K))*COS(ALF1E(KS1,K))
     2/SIN(ALF1E(KS1,K))*ANN1(KS1,K)/ANN0(KS1,K)+1.)
      IF(EPR.GT.0.)
     *CALL ETAPR(PT0PS1(KS1,K),etaO1)
      CPS(KS)=ETAO1*ETAS(KS1,K)
      STDP1A(KS)=DP1A(KS1,K)
      STPTR1(KS)=PTR1A(KS1,K)
      STTTR1(KS)=TTR1A(KS1,K)
      STBET1(KS)=BET1A(KS1,K)*57.2958
      STRI(KS)=RI(KS1,K)*57.2958
      STR1A(KS)=R1A(KS1,K)
      STRU1A(KS)=RU1A(KS1,K)
      STMR1A(KS)=MR1A(KS1,K)
      STU1A(KS)=U1A(KS1,K)
      STDP2(KS)=DP2(KS1,K)
      STBET2(KS)=BET2E(KS1,K)*57.2958
      SDBETA(KS)=(BET1A(KS1,K)+BET2E(KS1,K))*57.2958
      SR2(KS)=R2(KS1,K)
      SRU2(KS)=RU2(KS1,K)
      SMR2(KS)=MR2(KS1,K)
      SU2(KS)=U2(KS1,K)
      RX(KS)=1.-(1.-(PS1(KS1,K)/PTP(KS1,K))**E1)/(1.-(PS2(KS1,K)
     1/PTP(KS1,K))**E1)
      STDELH(KS)=DELHTu(KS1,K)
      STPSI(KS)=   G*AJ*DELHT(KS1,K)/(U1A(KS1,K)*U1A(KS1,K)
     1+U2(KS1,K)*U2(KS1,K))
      SETATT(KS)=ETATT(KS1,K)
      SETATS(KS)=ETATS(KS1,K)
      SETAAT(KS)=ETATAT(KS1,K)
      ZR=-2.*BET2E(KS1,K)-1.570796
      RZWINC(KS)=-2.*COS(ZR)/(1.+ANN1A(KS1,K)/ANN2(KS1,K))
     1*(SIN(BET1A(KS1,K))/COS(BET1A(KS1,K))*COS(BET2E(KS1,K))
     2/SIN(BET2E(KS1,K))*ANN2(KS1,K)/ANN1A(KS1,K)+1.)
      IF(EPR.GT.0.)
     *CALL ETAPR(PTRS2 (KS1,K),etaO1)
      CPR(KS)=ETAO1*ETAR(KS1,K)
      STDP2A(KS)=DP2A(KS1,K)
      STPT2(KS)=PT2A(KS1,K)
      STTT2(KS)=TT2A(KS1,K)
      STV2(KS)=V2A(KS1,K)
      STVU2(KS)=VU2A(KS1,K)
      STALF2(KS)=ALF2A(KS1,K)*57.2958
      STMF2(KS)=MF2A(KS1,K)
      STVZ2(KS)=VZ2A(KS1,K)
      STPS2(KS)=PS2A(KS1,K)
      STTS2(KS)=TS2A(KS1,K)
      STM2(KS)=M2A(KS1,K)
      STDEN2(KS)=144.*STPS2(KS)/STTS2(KS)/rg2(k)
      DBARS(KS)=DRBARS+HBRSH*(STDP1(KS)-DR(2,K))*2.0
      HBRS=H1(KS1,K)*HBRSH*2.
      HBRR=H2(KS1,K)*HBRRH*2.
      FTANS(KS)=-WG1(KS1,K)*(STDP1(KS)*STVU1(KS)+STDP0(KS)
     1*STVU0(KS))/DBARS(KS)/G/HBRS
      if (k.eq.1) then
        cat0=cos(atan(tang0(ks1)))
      else
        cat0=cos(atan(tangm2(ks1,k-1)))
      end if
      cat1=cos(atan(tangm1(ks1,k)))
      cat2=cos(atan(tangm2(ks1,k)))
      FAXS(KS)=((STPS0(KS)-STPS1(KS))*(ANN1(KS1,K) +ANN0(KS1,K))*72.
     1+WG1(KS1,K)/G*(STVZ0(KS)*cat0-STVZ1(KS)*cat1))/HBRS
      DBARR(KS)=DRBARR+HBRRH*(STDP2(KS)-DR(4,K))*2.0
      FTANR(KS)=WG2(KS1,K)*(STDP2A(KS)*STVU2(KS)+STDP1(KS)*STVU1(KS))
     1/DBARR(KS)/G/HBRR*TFR(KS1,K)
      FAXR(KS)=((PS1A(KS1,K)-PS2(KS1,K))*(ANN1A(KS1,K)+ANN2(KS1,K))*72.
     1+WG2(KS1,K)/G*(VZ1A(KS1,K)*cat1-VZ2(KS1,K)*cat2))/HBRR
5     KS=KS+KSD
      IF(KS.GT.KF) GO TO 28
      GO TO 97
28    CALL INST2
      IF(K.LE.KSTG) GO TO 1
      RETURN
      END


#version 300 es
out mediump vec4 outColour;

in mediump vec3 position;
in mediump vec3 normal;
in mediump vec2 texUV;
in mediump vec2 lightUV;
in mediump vec3 reflectivityColour;

uniform sampler2D activeTexture; /* NOT AN ATLAS*/
uniform sampler2D activeLightmap;

void main()
{
	mediump vec4 Ka = vec4(0.75, 0.75, 0.75, 1);
	//mediump float normColour = normal.x / 3 + 1/3 * normal.y / 3 + 2/3 * normal.z / 3;
	mediump vec4 Kd = vec4(1, 1, 1, 1);
	mediump vec4 albedo = texture2D(activeTexture, texUV);
	mediump vec4 lightmap = texture2D(activeLightmap, lightUV);

	//outColour = (Ka + Kd) * albedo;
	//outColour = vec4(texUV.x, texUV.y, 1, 1);
	outColour = vec4(reflectivityColour, 1) * albedo;
}


      SUBROUTINE PHO_DIFPRO(Ip,Icut,Id1,Id2,Xmass,P2v1,P2v2,Sprob,Iproc,
     &                      Isam,Jsam,Ksam,Idir)
C*********************************************************************
C
C     sampling of diffraction dissociation process
C
C     input:  IP       particle combination
C             ICUT     user imposed limitations
C             ID1/2    PDG particle code of scattering particles
C             XMASS    diffractively produced mass (GeV)
C             P2V1/2   virtuality of scattering particles (Gev**2)
C             SPROB    suppression factor for resolved single and
C                      double diffraction dissociation
C
C     output: IRPOC    process ID
C             ISAM     number of cut pomerons (soft)
C             JSAM     number of cut reggeons
C             KSAM     number of cut pomerons (hard)
C             IDIR     direct hard interaction
C
C*********************************************************************
      IMPLICIT NONE
      INTEGER Icut , Id1 , Id2 , Idir , Ip , Iproc , Isam , Jsam , Ksam
      DOUBLE PRECISION P2v1 , P2v2 , spro , Sprob , Xmass
      SAVE

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  general process information
      INCLUDE 'inc/poprcs'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C**anfe COMMON not needed here
C  energy-interpolation table
C      include 'inc/potabl'

      Isam = 0
      Jsam = 0
      Ksam = 0
      Idir = 0

      IF ( Xmass.GT.3.D0 ) THEN
C  rapidity gap survival probability
         spro = 1.D0
         IF ( ISWmdl(28).GE.1 ) spro = Sprob
C  sample interaction
         Iproc = 0
         CALL PHO_SAMPRO(Ip,Id1,Id2,Xmass,P2v1,P2v2,spro,Iproc)
      ELSE
         Iproc = 1
      END IF
      IF ( Iproc.EQ.1 ) CALL PHO_SAMPRB(Xmass,Ip,Isam,Jsam,Ksam)
C  non-diffractive hadron-pomeron interaction
      IF ( (Iproc.EQ.1) .OR. (Iproc.EQ.8) ) THEN
C  option for suppression of multiple interaction
         IF ( Icut.EQ.0 ) THEN
            Iproc = 1
            IF ( Isam+Ksam+Idir.GT.0 ) THEN
               Isam = 1
               Jsam = 0
            ELSE
               Jsam = 1
            END IF
            Ksam = 0
            Idir = 0
         ELSE IF ( Icut.EQ.1 ) THEN
            IF ( Idir.GT.0 ) THEN
            ELSE IF ( Ksam.GT.0 ) THEN
               Ksam = 1
               Isam = 0
               Jsam = 0
            ELSE IF ( Isam.GT.0 ) THEN
               Isam = 1
               Jsam = 0
            ELSE
               Jsam = 1
            END IF
         ELSE IF ( Icut.EQ.2 ) THEN
            Ksam = MIN(Ksam,1)
         ELSE IF ( Icut.EQ.3 ) THEN
            Isam = MIN(Isam,1)
         END IF
      END IF
      END SUBROUTINE


C
C	$Id: drawpv.f,v 1.6 2008-07-27 00:23:04 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE DRAWPV (IX,IY,IND)
C
C DRAWPV INTERCEPTS THE CALL TO PLOTIT.
C FOR IND=1 (PEN DOWN) IT CHECKS IF A LINE (PART OF IT) HAS TO BE DRAWN
C OR REMOVED.
C FOR IND=0 (PEN UP) IT CHECKS IF THE PEN HAS TO BE MOVED OR IF IT IS
C ALREADY CLOSE ENOUGH TO THE WANTED POSITION.
C FOR IND=2 DO NOT MOVE PEN.JUST SET POSITION OF PEN TO (IMPOS,IMPOS).
C
      COMMON/INTPR/IPAU,FPART,TENSN,NP,SMALL,L1,ADDLR,ADDTB,MLLINE,
     1    ICLOSE
C IOFFS IS AN INTERNAL PARAMETER. IT IS REFERENCED IN  DRAWPV AND
C FDVDLD AND INITIALIZED IN DASHBDX.
C
      COMMON /SMFLAG/ IOFFS
C
C IN DSAVE3 THE STARTING POINT OF THE NEXT LINE SEGMENT TO BE DRAWN
C OR REMOVED IS SAVED.
C
      COMMON /DSAVE3/ IXSTOR,IYSTOR
C
C IX1,IY1,IX2 AND IY2 ARE USED TO STORE THE NEXT LINE SEGMENT TO BE
C MARKED, WHICH IS THE SEGMENT THAT WAS DRAWN LAST.
C
      COMMON /DSAVE4/ IX1,IY1,IX2,IY2
C
C ISKIP IS USED TO ADJUST DASHSUPR TO THE SIZE OF THE MODEL PICTURE AS
C DEFINED IN SUBROUTINE REMOVE. ISKIP IS INITIALIZED IN DASHBDX.
C
      COMMON /DSUP1/ ISKIP
C
      LOGICAL LI, LM, HID
      LOGICAL LDUMMY
      SAVE
C
      DATA LDUMMY /.TRUE./
C
C BRANCH DEPENDING ON FUNCTION TO BE PERFORMED.
C
      IIND = IND + 1
      GOTO (2,1,3), IIND
C
    1 CONTINUE
C
C *************************************
C
C INTERCEPT PLOTIT(IX,IY,1) TO CHECK IF THE LINE TO BE DRAWN (PART OF
C IT) HAS TO BE REMOVED. DRAW AND MARK LINE IF FEASIBLE.
C
C
      IF (IOFFS .EQ. 0) GO TO 10
C
C DO NOT MARK LINES IF NOT REQUIRED.
C
      IXSTOR = IX
      IYSTOR = IY
      CALL PLOTIT (IX,IY,1)
      RETURN
C
C LINE HAS TO BE DRAWN AND MARKED.
C
   10 CONTINUE
      MX = IXSTOR
      MY = IYSTOR
      IXSTOR = IX
      IYSTOR = IY
      DX = IXSTOR - MX
      DY = IYSTOR - MY
C
C CHECK BEGINNING AND END POINT OF LINE, IF THEY ARE ALREADY MARKED.
C
      CALL REMOVE (IXSTOR,IYSTOR,LI,3)
      CALL REMOVE (MX,MY,LM,3)
C
C NOTHING TO DO , IF BEGINNING AND END POINT ARE ALREADY MARKED.
C
      IF (LI .AND. LM) RETURN
C
C DRAW A POINT IF LINE IS OF LENGTH 0.
C
      IF (DX .NE. 0. .OR. DY .NE. 0.) GO TO 15
      CALL PLOTIT (IXSTOR,IYSTOR,1)
      RETURN
   15 CONTINUE
C
      IF (LI .OR. LM) GO TO 20
C
C IF NEITHER STARTING NOR END POINT IS MARKED, DRAW LINE AND MARK IT.
C
      CALL PLOTIT (IXSTOR,IYSTOR,1)
      GO TO 80
C
C EITHER BEGINNING OR END POINT OF LINE WERE ALREADY MARKED.
C
   20 D = MAX(ABS(DX),ABS(DY))
      ID = D/REAL(ISKIP)
      DX = (DX/D)*REAL(ISKIP)
      DY = (DY/D)*REAL(ISKIP)
      IF (LM) GO TO 50
C
C STARTING POINT WAS NOT MARKED. FIND THE FIRST MARKED POINT.
C
      X = MX
      Y = MY
      DO 30 I=1,ID
         X = X+DX
         Y = Y+DY
         CALL REMOVE (INT(X+.5),INT(Y+.5),HID,3)
         IF (HID) GO TO 40
   30 CONTINUE
      X = REAL(IXSTOR)+DX
      Y = REAL(IYSTOR)+DY
   40 IXP = X+.5-DX
      IYP = Y+.5-DY
C FIRST MARKED POINT FOUND.
C DRAW LINE, SET PEN, MARK LINE.
      CALL PLOTIT (IXP,IYP,1)
      CALL PLOTIT (IXSTOR,IYSTOR,0)
      GO TO 80
C
C     FIRST PART IS HIDDEN
C       FIND THE FIRST VISIBLE POINT
C
   50 X = MX
      Y = MY
      DO 60 I=1,ID
         X = X+DX
         Y = Y+DY
         CALL REMOVE (INT(X+.5),INT(Y+.5),HID,3)
         IF (.NOT.HID) GO TO 70
   60 CONTINUE
      X = IXSTOR
      Y = IYSTOR
   70 IXP = X+.5
      IYP = Y+.5
C FIRST VISIBLE POINT FOUND.
C SET PEN, DRAW LINE, MARK LINE.
      CALL PLOTIT (IXP,IYP,0)
      CALL PLOTIT (IXSTOR,IYSTOR,1)
C
C
   80 CONTINUE
      CALL MARKL (IX1,IY1,IX2,IY2)
      IX1 = MX
      IY1 = MY
      IX2 = IXSTOR
      IY2 = IYSTOR
      RETURN
C
    2 CONTINUE
C
C *************************************
C
C INTERCEPT PLOTIT(IX,IY,0) TO SET THE STARTING POINT FOR THE NEXT
C LINE TO BE DRAWN OR REMOVED.
C
C CHECK IF PEN IS ALREADY CLOSE ENOUGH TO THE WANTED POSITION.
      DIFF = REAL(ABS(IXSTOR-IX)+ABS(IYSTOR-IY))
      IF (DIFF .LE. REAL(ICLOSE)) GO TO 110
C
      IXSTOR = IX
      IYSTOR = IY
      CALL PLOTIT (IXSTOR,IYSTOR,0)
      RETURN
C
    3 CONTINUE
C
C ****************************
C
C DO NOT MOVE PEN. JUST SET POSITION OF PEN TO (IMPOS,IMPOS).
C
      IXSTOR = IX
      IYSTOR = IY
C
  110 CONTINUE
C
      RETURN
      END


      subroutine paths (ckspc, fbetac, xlamc, pcritk, pcrith, critpw,
     1                  nncrit, rmax, nlegxx, rfms,
     2                  nat, ratdp, iphat, ibounc)

c     finds multiple scattering paths
c     This is single precision, units are Angstroms.  BE CAREFUL!

c     pcrith is cut-off fraction used when building paths
c            (path criterion for heap)
c     pcritk is cut-off fraction used on output
c            (path criterion for keeping)

      include '../HEADERS/dim.h'
      parameter (necrit=9, nbeta=40)
      dimension fbetac(-nbeta:nbeta,0:nphx,necrit), ckspc(necrit)
      dimension xlamc(necrit)

c     This common in pathsd, mpprm
      common /atoms/ rat(3,0:natx), ipot(0:natx), i1b(0:natx)
      double precision ratdp(3,natx)
      integer  iphat(natx), ibounc(natx)

      dimension m(-1:natx,0:natx)
      dimension mindex(natx+1)
c     Used for packed integers
      dimension iout(3)

c     ok true if all paths to rmax found.  If heap full, npx exceeded,
c     etc., last general shell may be incomplete, set ok=.false.
      logical ok
c     is label nfound, etc, written yet?
      logical wlabel

c     Heap data structure:
c     index is the pointer to the element of the data structure.
c     Each element contains
c        r        total path length
c                 Note that r is sorted along with index -- this keeps
c                 the heap maintenance routines fast.
c        mi, mj   m matrix elements used to place last atom in this path
c        npat     number of atoms in this path
c        ipat(npatx) indices of atoms in this path
c     next is the index of the next data structure element available.
c     If an element is freed, npat is the index of the free element
c     to use after using current "next" element.
c     nx is max number in heap
      integer    nx
c     parameter (nx = 10 000)
      parameter (nx = 6000 000)
c     r also used in making m matrix, must have nx >= natx+1
      integer   index(nx), npx, np, n, ip, i, iat0, idum
c     parameter (npx = 100 000)
      parameter (npx = 100000000)
      dimension r(nx), mi(nx), mj(nx)
      dimension npat(nx)
      dimension ipat (npatx,nx)
c     Keep this path on output
      logical keep1(nx), kp1tmp
c     to remmember atoms outside rfms
      dimension iclus(0:natx)

c     Used with ipack, so need ipat(8)
      dimension ipat0(8)

c     paths are typically about 10 or 20 Ang
      parameter (big = 1.0e3)

      character*80  title

c     Returned from criterion checker, false if path fails criterion
      logical keep
      character*512 slog

      external sdist

c     transform to single precision for pathfinder
c     also count in pathfinder starts with 0, not with 1
      do 15 iat = 1, nat
        j = iat-1
        do 10 i = 1, 3
          rat(i, j) = real (ratdp(i,iat))
 10     continue
        ipot(j) = iphat(iat)
        i1b(j) = ibounc(iat)
 15   continue
      nat = nat - 1

c     nlegxx is max number of legs user wants to consider.
c     nlegs = npat+1, so set npatxx = min (npatx, nlegxx-1)
      npatxx = min (npatx, nlegxx-1)
c     Input rmax is one-way distances
      rmax = rmax*2
c     ratx is distance to most distant atom, used to check rmax
      ratx = 0
      iat0 = -1
      i1b(0) = 0

c     find index for the central atom
      do 20 iat = 0, nat
         if (ipot(iat).eq.0 .and. iat0.lt.0) iat0=iat
   20 continue

c     iclus = 0 for atoms inside rfms cluster, 1 for atoms outside
      do 21 iat = 0,nat
        rtmp = sdist(rat(1,iat),rat(1,iat0))
        if (rtmp.gt.rfms) iclus(iat)=1
        iclus(iat)=0
        if (rtmp.gt.rfms) iclus(iat)=1
   21 continue

      if (iat0.ne. 0) then
c       permute atoms 0 and iat0
c       do not need to permute i1b, since all of them are 1 in
c       this case, except i1b(0) = 0, which we want to keep.
        do 25 j=1,3
          temp = rat(j,0)
          rat(j,0) = rat(j,iat0)
          rat(j,iat0) = temp
   25   continue
        idum = ipot(0)
        ipot(0) = ipot(iat0)
        ipot(iat0) = idum
        idum = iclus(0)
        iclus(0) = iclus(iat0)
        iclus(iat0) = idum
      endif

c     Warn user if rmax > dist to most distant atom
c     1.01 to avoid roundoff error, matches rdinp where rmax default set
      if (rmax/2 .gt. 1.01 * ratx)  then
         call wlog('   WARNING:  rmax > distance to most distant atom.')
         call wlog('             Some paths may be missing.')
         write(slog,22) rmax/2, ratx
         call wlog(slog)
   22    format('             rmax, ratx ', 1p, 2e13.5)
      endif

c     Count number of 1st bounce atoms (at least 1 required).
      n1b = 0
      do 30  i = 1, nat
         if (i1b(i) .gt. 0)  n1b = n1b + 1
   30 continue
      if (n1b .lt. 1)
     .  call par_stop('At least one 1st bounce atoms required.')

      if (rmax .ge. big)  call par_stop('Hey, get real with rmax!')

c     Make title for this run, include carriage control because head
c     (read above) includes carriage control.
      write(title,32)  rmax/2, pcritk, pcrith, critpw
   32 format('PATH  Rmax=', f6.3, ',  Keep_limit=', f5.2,
     1       ', Heap_limit', f5.2,'  Pwcrit=', f5.2, '%')

      write(slog,34) rmax/2, pcritk, pcrith
      call wlog(slog)
   34 format ('    Rmax', f8.4,
     1        '  keep and heap limits', 2f12.7)

      call wlog('    Preparing neighbor table')

c   36 format (1x, a)
c     prepare table telling distance from atom i to atom j and then
c     back to central atom
c     First bounce is m(-1,...), m(0,...) is bounces from central
c     atom that are not first bounces.
      do 60  i = -1, nat
         ir = i
         if (i .eq. -1)  ir = 0
         do 40  j = 0, nat
c           r begins with element 1 so sort routine later will work
            r(j+1) = sdist (rat(1,ir), rat(1,j))
            r(j+1) = r(j+1) + sdist (rat(1,j), rat(1,0))
c           we don't need m(i,i), since this will be = shortest
c           of the r(j), so just set it to something very big,
c           it will sort to the end of this row and it won't
c           bother us
            if (j .eq. ir)  r(j+1) = big
c           If we're doing first bounce, use only the allowed first
c           bounce paths.
            if (i .eq. -1)  then
               if (i1b(j) .le. 0)  r(j+1) = big
            endif
   40    continue

c        prepare row i of m table
c        m is a distance table ordered such that distance from
c               i to m(i,0) to 0 <
c               i to m(i,1) to 0 <
c               i    m(i,2)    0 <
c               :    :    :
c               i    m(i,nat)  0
c
c        That is, m(i,0) is index of atom that gives shortest path,
c                 m(i,1)                        next shortest path, etc.
c        Note that m(0,0) is shortest single bounce path.

c        Again, r and mindex go from 1 to nat+1, m goes from 0 to nat
         call sortir (nat+1, mindex, r)
         do 50  j = 0, nat
            m(i,j) = mindex(j+1)-1
   50    continue
   60 continue

c     label for nfound, heap size, etc written?
      wlabel = .false.
c     initialize heap data space "next" pointers
      do 70  i = 1, nx-1
         npat(i) = i+1
   70 continue
      npat(nx) = -1
c     initial condition:  make the first path
c     n    number in heap
c     nna  number skipped counter
c     nhx  number used in heap max, a counter
      n = 1
      nna = 0
      nhx = n
      nwrote = 0
      index(n) = 1
      ip = index(n)
      next = 2
      mi(ip) = -1
      mj(ip) = 0
      npat(ip) = 1
      ipat(npat(ip),1) = m(mi(ip),mj(ip))

c     Someday change keep and keep1 to lkeep and lheap to match
c     ccrit variable names.
c     Initialize keep criterion
      xcalcx = -1
      call ccrit (npat(ip), ipat(1,ip), ckspc,
     1    fbetac, xlamc, rmax, pcrith, pcritk, nncrit, ipot,
     2    r(n), keep, keep1(ip), xcalcx, iclus)

      open (file='paths.bin', unit=3, access='sequential',
     1      form='unformatted', status='unknown', iostat=ios)
      call chopen (ios, 'paths.bin', 'paths')
c     These strings are all char*80 and include carriage control
c     temporary fix for zero title lines: fix later
      nhead = 1
      write(3) nhead
      write(3) title
      write(3)  nat
      do 90  i = 0, nat
         write(3) (rat(j,i),j=1,3), ipot(i), i1b(i)
   90 continue

c     r is the heap, index is the pointer to the rest of the data
c     np is the number of paths found and saved
      np = 0
c     nbx  mpat max (Number of Bounces maX)
      nbx = 0

c     done if path at top of heap is longer than longest path we're
c        interested in
c     done if max number of paths we want have been found
c     begin 'while not done' loop
      ok = .false.
  800 continue
         if (r(1) .gt. rmax  .or.  np .ge. npx .or. n.le.0)  then
c           n=0 means heap is empty
            if (n.le.0)  ok=.true.
            goto 2000
         endif

c        save element at top of heap in arrays labeled 0
c        dump to unit 3 (unformatted)
         ip = index(1)
         npat0 = npat(ip)
         do 100  i = 1, npat0
            ipat0(i) = ipat(i,ip)
  100    continue
         r0 = r(1)

c        Don't write out path if last atom is central atom, or
c        if it doesn't meet pcritk
         if (ipat0(npat0).ne.0 .and. keep1(ip))  then
            np = np+1
c           pack integers
            call ipack (iout, npat0, ipat0)
            write(3)  r0, iout
            nwrote = nwrote+1
c           write status report to screen
            if (mod(np,1000) .eq. 0)  then
               if (.not. wlabel)  then
                  call wlog('    nfound  heapsize  maxheap' //
     1               '  maxscatt   reff')
                  wlabel = .true.
               endif
               write(slog,132) np, n, nhx, nbx, r0/2
               call wlog(slog)
  132          format (4x, i6, i9, i9, i7, f12.4)
            endif
         endif

         if (np .ge. npx)  then
            write(slog,134) np
            call wlog(slog)
  134       format(i15, ' paths found.  (np .ge. npx)')
            goto 2000
         endif

c        Make new path by replacing last atom in path from top of heap,
c        put this path on top of heap and buble it down.  If row is
c        finished, or new path is too long, don't add it, instead
c        move last path in heap to the top.
c        If working on row mi=-1 (first bounce atoms), don't
c        use them if not allowed 1st bounce atoms.
         mj(ip) = mj(ip) + 1
         if (mi(ip).eq.-1  .and.  i1b(m(mi(ip),mj(ip))).le.0)  then
c           not allowed first bounce atom
            r(1) = big
            keep = .false.
c           type*, '1st bounce limit!'
         elseif (mj(ip) .ge. nat)  then
c           we've finished a row of m matrix
            r(1) = big
            keep = .false.
         else
c           new path has same indices, etc.  Only need to replace
c           last atom.
            ipat(npat(ip),ip) = m(mi(ip),mj(ip))
            call ccrit (npat(ip), ipat(1,ip), ckspc,
     1                  fbetac, xlamc, rmax, pcrith, pcritk, nncrit,
     2                  ipot, r(1), keep, keep1(ip), xcalcx, iclus)
         endif

c        If r is bigger than rmax or keep=false, remove element from
c        heap by taking the last element in the heap and moving it to
c        the top.  Then bubble it down.  When removing an element
c        from the heap, be sure to save the newly freed up index.
c        r(1) and index(1) are new path, set above
         if (r(1).gt.rmax .and. keep)  then
            call wlog(' odd case rmax...')
         endif
         if (r(1).gt.rmax .or. .not.keep)  then
            index(1) = index(n)
            r(1) = r(n)
c           use npat as pointer to next free location
            npat(ip) = next
            next = ip
            n = n-1
c           nna is Number Not Added to heap
            nna = nna + 1
c           Maybe heap may be empty here, but that's alright
         endif
         if (npat(index(1)).gt.nbx .and. n.gt.0)  nbx = npat(index(1))

c        If heap is empty, don't call hdown.
         if (n.gt.0)  call hdown (r, index, n)

c        and make a new path by adding an atom onto the end of the path
c        we saved, put this at the end of the heap and bubble it up.
c        Do this only if it won't be too many bounces.
         if (npat0+1 .le. npatxx)  then
            ip = next
            if (ip .lt. 0)  then
c              call wlog('   Heap full')
               goto 2000
            endif
            next0 = npat(ip)
            do 200  i = 1, npat0
               ipat(i,ip) = ipat0(i)
  200       continue
            mi(ip) = ipat0(npat0)
            mj(ip) = 0
            npat(ip) = npat0+1
            ipat(npat(ip),ip) = m(mi(ip),mj(ip))
            call ccrit (npat(ip), ipat(1,ip), ckspc,
     1                  fbetac, xlamc, rmax, pcrith, pcritk, nncrit,
     2                  ipot, rtmp, keep, kp1tmp, xcalcx, iclus)
            if (rtmp .gt. rmax  .and.  keep)  then
               call wlog(' odd case rmax and tmp...')
            endif
            if (rtmp .gt. rmax  .or.  .not.keep)  then
               npat(ip) = next0
               nna = nna+1
            else
c              add it to the heap
               next = next0
               n = n+1
               if (n .gt. nhx)  nhx = n
               index(n) = ip
               r(n) = rtmp
               keep1(ip) = kp1tmp
               if (npat(index(n)) .gt. nbx)  nbx = npat(index(n))
               call hup (r, index, n)
            endif
         endif

      goto 800
 2000 continue
c     end of 'while not done' loop
      if (.not. ok)  then
         call wlog('   Internal path finder limit exceeded -- ' //
     1             'path list may be incomplete.')
      endif
      close (unit=3)
      write(slog,2010) np, nhx, nbx
      call wlog(slog)
 2010 format ('    Paths found', i9, 3x,
     1        '(maxheap, maxscatt', i8, i4, ')')

c     restore the value of rmax
      rmax = rmax/2

      end


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module dart_cice_mod

use        types_mod, only : r8, rad2deg, PI, SECPERDAY
use time_manager_mod, only : time_type, get_date, set_date, get_time, set_time, &
                             set_calendar_type, get_calendar_string, &
                             print_date, print_time, operator(==), operator(-)
use    utilities_mod, only : get_unit, open_file, close_file, file_exist, &
                             register_module, error_handler, &
                             find_namelist_in_file, check_namelist_read, &
                             E_ERR, E_MSG, find_textfile_dims

use  netcdf_utilities_mod, only : nc_check

use typesizes
use netcdf

implicit none
private

public :: get_cice_calendar, set_model_time_step, &
          get_horiz_grid_dims, get_ncat_dim,      &
          read_horiz_grid, read_topography,       &
          write_cice_namelist, get_cice_restart_filename, &
          set_binary_file_conversion

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

character(len=256) :: msgstring
logical, save :: module_initialized = .false.

character(len=256) :: ic_filename      = 'cice.r.nc'

! set this to true if you want to print out the current time
! after each N observations are processed, for benchmarking.
logical :: print_timestamps = .false.
integer :: print_every_Nth  = 10000

! if the binary grid files are big_endian and you are running on
! a little_endian machine, set this string so the convert will
! happen correctly.  options are:  'native', 'big_endian', 'little_endian'

character(len=64) :: conversion = 'native'    ! no conversion

!------------------------------------------------------------------
! The CICE grid info namelist
!------------------------------------------------------------------
!
! CICE grid information comes in several files:
!   horizontal grid lat/lons in one,
!   topography (used to get land/ocean cells) in another
!
!------------------------------------------------------------------
!
! Here is what we can get from the (binary) horiz grid file:
!   real (r8), dimension(:,:), allocatable :: &
!      ULAT,            &! latitude  (radians) of U points
!      ULON,            &! longitude (radians) of U points
!      HTN ,            &! length (cm) of north edge of T box
!      HTE ,            &! length (cm) of east  edge of T box
!      HUS ,            &! length (cm) of south edge of U box
!      HUW ,            &! length (cm) of west  edge of U box
!      ANGLE             ! angle
!
! Here is what we can get from the topography file:
!   integer, dimension(:,:), allocatable :: &
!      KMT               ! k index of deepest grid cell on T grid
!
! These must be derived or come from someplace else ...
!      KMU               ! k index of deepest grid cell on U grid
!      HT                ! real(r8) value of deepest valid T depth (in cm)
!      HU                ! real(r8) value of deepest valid U depth (in cm)
!
!------------------------------------------------------------------

character(len=256) :: grid_file, grid_format,  grid_type, &     ! CMB verified types
                      gridcpl_file, kmt_file
integer :: kcatbound

! CMB stole code from ice_domain.F90
   integer, parameter :: log_kind  = kind(.true.), &
                         int_kind  = selected_int_kind(6)

   character (len=80) :: &
      ew_boundary_type, &! type of domain bndy in each logical
      ns_boundary_type   !    direction (ew is i, ns is j)

   logical (kind=log_kind) :: &
      maskhalo_dyn   , & ! if true, use masked halo updates for dynamics
      maskhalo_remap , & ! if true, use masked halo updates for transport
      maskhalo_bound     ! if true, use masked halo updates for bound_state

   character (len=80) :: &
       distribution_type,   &! method to use for distributing blocks
       distribution_wght     ! method for weighting work per block

   integer (int_kind) :: nprocs                ! num of processors

   character (len=80) :: processor_shape

! code from cesm1_5_beta06c/cime/share/csm_share/shr/shr_kind_mod.F990
   integer,parameter :: SHR_QTY_CS = 80                     ! short char
   integer,parameter :: SHR_QTY_IN = kind(1)                ! native integer

! code from cesm1_5_beta06c/cime/driver_cpl/shr/seq_timemgr_mod.F90
    character(SHR_QTY_CS)  :: calendar              ! Calendar type
    character(SHR_QTY_CS)  :: stop_option           ! Stop option units
    integer(SHR_QTY_IN)    :: stop_n                ! Number until stop
    integer(SHR_QTY_IN)    :: stop_ymd              ! Stop date (YYYYMMDD)
    integer(SHR_QTY_IN)    :: stop_tod              ! Stop time-of-day
    character(SHR_QTY_CS)  :: restart_option        ! Restart option units
    integer(SHR_QTY_IN)    :: restart_n             ! Number until restart interval
    integer(SHR_QTY_IN)    :: restart_ymd           ! Restart date (YYYYMMDD)
    character(SHR_QTY_CS)  :: pause_option
    integer(SHR_QTY_IN)    :: pause_n
    character(SHR_QTY_CS)  :: pause_component_list
    character(SHR_QTY_CS)  :: history_option        ! History option units
    integer(SHR_QTY_IN)    :: history_n             ! Number until history interval
    integer(SHR_QTY_IN)    :: history_ymd           ! History date (YYYYMMDD)
    character(SHR_QTY_CS)  :: histavg_option        ! Histavg option units
    integer(SHR_QTY_IN)    :: histavg_n             ! Number until histavg interval
    integer(SHR_QTY_IN)    :: histavg_ymd           ! Histavg date (YYYYMMDD)
    character(SHR_QTY_CS)  :: barrier_option        ! Barrier option units
    integer(SHR_QTY_IN)    :: barrier_n             ! Number until barrier interval
    integer(SHR_QTY_IN)    :: barrier_ymd           ! Barrier date (YYYYMMDD)
    character(SHR_QTY_CS)  :: tprof_option          ! tprof option units
    integer(SHR_QTY_IN)    :: tprof_n               ! Number until tprof interval
    integer(SHR_QTY_IN)    :: tprof_ymd             ! tprof date (YYYYMMDD)
    integer(SHR_QTY_IN)    :: start_ymd             ! Start date (YYYYMMDD)
    integer(SHR_QTY_IN)    :: start_tod             ! Start time of day (seconds)
    integer(SHR_QTY_IN)    :: curr_ymd              ! Current ymd (YYYYMMDD)
    integer(SHR_QTY_IN)    :: curr_tod              ! Current tod (seconds)
    integer(SHR_QTY_IN)    :: ref_ymd               ! Reference date (YYYYMMDD)
    integer(SHR_QTY_IN)    :: ref_tod               ! Reference time of day (seconds)
    integer(SHR_QTY_IN)    :: atm_cpl_dt            ! Atmosphere coupling interval
    integer(SHR_QTY_IN)    :: lnd_cpl_dt            ! Land coupling interval
    integer(SHR_QTY_IN)    :: ice_cpl_dt            ! Sea-Ice coupling interval
    integer(SHR_QTY_IN)    :: ocn_cpl_dt            ! Ocean coupling interval
    integer(SHR_QTY_IN)    :: glc_cpl_dt            ! Glc coupling interval
    character(SHR_QTY_CS)  :: glc_avg_period
    integer(SHR_QTY_IN)    :: rof_cpl_dt            ! Runoff coupling interval
    integer(SHR_QTY_IN)    :: wav_cpl_dt            ! Wav coupling interval
    integer(SHR_QTY_IN)    :: esp_cpl_dt            ! Esp coupling interval
    integer(SHR_QTY_IN)    :: atm_cpl_offset        ! Atmosphere coupling interval
    integer(SHR_QTY_IN)    :: lnd_cpl_offset        ! Land coupling interval
    integer(SHR_QTY_IN)    :: ice_cpl_offset        ! Sea-Ice coupling interval
    integer(SHR_QTY_IN)    :: ocn_cpl_offset        ! Ocean coupling interval
    integer(SHR_QTY_IN)    :: glc_cpl_offset        ! Glc coupling interval
    integer(SHR_QTY_IN)    :: wav_cpl_offset        ! Wav coupling interval
    integer(SHR_QTY_IN)    :: rof_cpl_offset        ! Runoff coupling interval
    integer(SHR_QTY_IN)    :: esp_cpl_offset        ! Esp coupling interval
    logical                 :: end_restart           ! Write restart at end of run
    logical                :: esp_run_on_pause

   namelist /grid_nml/ grid_file, grid_format, grid_type, &
         gridcpl_file, kcatbound, kmt_file

   namelist /domain_nml/ nprocs, &
                         processor_shape,   &
                         distribution_type, &
                         distribution_wght, &
                         ew_boundary_type,  &
                         ns_boundary_type,  &
                         maskhalo_dyn,      &
                         maskhalo_remap,    &
                         maskhalo_bound

   namelist /seq_timemgr_inparm/  calendar, curr_ymd, curr_tod,  &
         stop_option, stop_n, stop_ymd, stop_tod,        &
         restart_option, restart_n, restart_ymd,         &
         history_option, history_n, history_ymd,         &
         histavg_option, histavg_n, histavg_ymd,         &
         pause_option, pause_n, pause_component_list,   &
         barrier_option, barrier_n, barrier_ymd,         &
         tprof_option, tprof_n, tprof_ymd,               &
         start_ymd, start_tod, ref_ymd, ref_tod,         &
         atm_cpl_dt, ocn_cpl_dt, ice_cpl_dt, lnd_cpl_dt, &
         atm_cpl_offset, lnd_cpl_offset, ocn_cpl_offset, &
         ice_cpl_offset, glc_cpl_dt, glc_avg_period, glc_cpl_offset,     &
         wav_cpl_dt, wav_cpl_offset, esp_cpl_dt, esp_cpl_offset,     &
         esp_run_on_pause, rof_cpl_dt, rof_cpl_offset, end_restart

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

subroutine initialize_module

integer :: iunit, io

! Read calendar information
! In 'restart' mode, this is primarily the calendar type and 'stop'
! information. The time attributes of the restart file override
! the namelist time information.

! FIXME : Real observations are always GREGORIAN dates ...
! but stomping on that here gets in the way of running
! a perfect_model experiment for pre-1601 AD cases.

! STOMP if ( allow_leapyear ) then
   call set_calendar_type('gregorian')
! STOMP else
! STOMP    call set_calendar_type('noleap')
! STOMP endif

! Make sure we have a cice restart file (for grid dims)
if ( .not. file_exist(ic_filename) ) then
   msgstring = 'dart_cice_mod: '//trim(ic_filename)//' not found'
   call error_handler(E_ERR,'initialize_module', &
          msgstring, source, revision, revdate)
endif

! Read CICE grid information (for grid filenames)
call find_namelist_in_file('cice_in', 'grid_nml', iunit)
read(iunit, nml = grid_nml, iostat = io)
call check_namelist_read(iunit, io, 'grid_nml')

! Read CICE grid information (for grid filenames)
call find_namelist_in_file('cice_in', 'domain_nml', iunit)
read(iunit, nml = domain_nml, iostat = io)
call check_namelist_read(iunit, io, 'domain_nml')

! Read CESM "driver" restart information
call find_namelist_in_file('drv_in', 'seq_timemgr_inparm', iunit)
read(iunit, nml = seq_timemgr_inparm, iostat = io)
call check_namelist_read(iunit, io, 'seq_timemgr_inparm')

module_initialized = .true.

! Print module information to log file and stdout.
call register_module(source, revision, revdate)

end subroutine initialize_module

!------------------------------------------------------------------

subroutine get_ncat_dim(Ncat)

!
! Read the ncat size from the restart netcdf file.

integer, intent(out) :: Ncat   ! Number of categories in ice-thick dist

integer :: grid_id, dimid, nc_rc

if ( .not. module_initialized ) call initialize_module

call nc_check(nf90_open(trim(ic_filename), nf90_nowrite, grid_id), &
         'get_ncat_dim','open '//trim(ic_filename))

! ncat : get dimid for 'ncat' and then get value
nc_rc = nf90_inq_dimid(grid_id, 'ncat', dimid)
if (nc_rc /= nf90_noerr) then
   nc_rc = nf90_inq_dimid(grid_id, 'Ncat', dimid)
   if (nc_rc /= nf90_noerr) then
      msgstring = "unable to find either 'ncat' or 'Ncat' in file "//trim(ic_filename)
      call error_handler(E_ERR, 'get_horiz_grid_dims', msgstring, &
                         source,revision,revdate)
   endif
endif

call nc_check(nf90_inquire_dimension(grid_id, dimid, len=Ncat), &
         'get_ncat_dim','inquire_dimension ni '//trim(ic_filename))

! tidy up

call nc_check(nf90_close(grid_id), &
         'get_ncat_dim','close '//trim(ic_filename) )

end subroutine get_ncat_dim

!------------------------------------------------------------------

subroutine get_horiz_grid_dims(Nx, Ny)

!
! Read the lon, lat grid size from the restart netcdf file.
! The actual grid file is a binary file with no header information.
!
! The file name comes from module storage ... namelist.

integer, intent(out) :: Nx   ! Number of Longitudes
integer, intent(out) :: Ny   ! Number of Latitudes

integer :: grid_id, dimid, nc_rc

if ( .not. module_initialized ) call initialize_module

call nc_check(nf90_open(trim(ic_filename), nf90_nowrite, grid_id), &
         'get_horiz_grid_dims','open '//trim(ic_filename))

! Longitudes : get dimid for 'ni' or 'nlon', and then get value
nc_rc = nf90_inq_dimid(grid_id, 'ni', dimid)
if (nc_rc /= nf90_noerr) then
   nc_rc = nf90_inq_dimid(grid_id, 'nlon', dimid)
   if (nc_rc /= nf90_noerr) then
      msgstring = "unable to find either 'ni' or 'nlon' in file "//trim(ic_filename)
      call error_handler(E_ERR, 'get_horiz_grid_dims', msgstring, &
                         source,revision,revdate)
   endif
endif

call nc_check(nf90_inquire_dimension(grid_id, dimid, len=Nx), &
         'get_horiz_grid_dims','inquire_dimension ni '//trim(ic_filename))

! Latitudes : get dimid for 'nj' or 'nlat' ... and then get value
nc_rc = nf90_inq_dimid(grid_id, 'nj', dimid)
if (nc_rc /= nf90_noerr) then
   nc_rc = nf90_inq_dimid(grid_id, 'nlat', dimid)
   if (nc_rc /= nf90_noerr) then
      msgstring = "unable to find either 'nj' or 'nlat' in "//trim(ic_filename)
      call error_handler(E_ERR, 'get_horiz_grid_dims', msgstring, &
                         source,revision,revdate)
   endif
endif

call nc_check(nf90_inquire_dimension(grid_id, dimid, len=Ny), &
         'get_horiz_grid_dims','inquire_dimension ni '//trim(ic_filename))

! tidy up

call nc_check(nf90_close(grid_id), &
         'get_horiz_grid_dims','close '//trim(ic_filename) )

end subroutine get_horiz_grid_dims

!------------------------------------------------------------------

! CMB removed get_vert_grid_dim(Nz)

!------------------------------------------------------------------

subroutine get_cice_calendar(calstring)

! the initialize_module ensures that the cice namelists are read and
! the DART time manager gets the cice calendar setting.
!
! Then, the DART time manager is queried to return what it knows ...
!
character(len=*), INTENT(OUT) :: calstring

if ( .not. module_initialized ) call initialize_module

call get_calendar_string(calstring)

end subroutine get_cice_calendar

!------------------------------------------------------------------

function set_model_time_step()

! the initialize_module ensures that the cice namelists are read.
! The restart times in the cice_in&restart_nml are used to define
! appropriate assimilation timesteps.
!
type(time_type) :: set_model_time_step

if ( .not. module_initialized ) call initialize_module

! Check the 'restart_option' and 'restart_n' to determine
! when we can stop the model
! CMB not sure if nday is actually different than ndays, no matter here though
!if ( (trim(restart_option) == 'ndays') .or. (trim(restart_option) == 'nday' ) ) then
!   set_model_time_step = set_time(0, restart_n) ! (seconds, days)
!else if ( trim(restart_option) == 'nyears' ) then
   ! FIXME ... CMB I guess we ignore it and make the freq 1 day anyway?
   set_model_time_step = set_time(0, 1) ! (seconds, days)
!else
!   call error_handler(E_ERR,'set_model_time_step', &
!              'restart_option must be ndays or nday', source, revision, revdate)
!endif

end function set_model_time_step

!------------------------------------------------------------------

subroutine write_cice_namelist(model_time, adv_to_time)
!
type(time_type), INTENT(IN) :: model_time, adv_to_time
type(time_type) :: offset

integer :: iunit, secs, days

if ( .not. module_initialized ) call initialize_module

offset = adv_to_time - model_time
call get_time(offset, secs, days)

if (secs /= 0 ) then
   write(msgstring,*)'adv_to_time has seconds == ',secs,' must be zero'
   call error_handler(E_ERR,'write_cice_namelist', msgstring, source, revision, revdate)
endif

! call print_date( model_time,'write_cice_namelist:dart model date')
! call print_date(adv_to_time,'write_cice_namelist:advance_to date')
! call print_time( model_time,'write_cice_namelist:dart model time')
! call print_time(adv_to_time,'write_cice_namelist:advance_to time')
! call print_time(     offset,'write_cice_namelist:a distance of')
! write( *,'(''write_cice_namelist:TIME_MANAGER_NML   STOP_COUNT '',i10,'' days'')') days

!Convey the information to the namelist 'stop option' and 'stop count'

if ( (trim(stop_option) == 'nday') .or. (trim(stop_option) == 'ndays') ) then
   stop_n = days
else
   call error_handler(E_ERR,'write_cice_namelist', &
              'stop_option must be "ndays or nday"', source, revision, revdate)
endif

iunit = open_file('cice_in.DART',form='formatted',action='rewind')
write(iunit, nml=seq_timemgr_inparm)
write(iunit, '('' '')')
close(iunit)

end subroutine write_cice_namelist

!------------------------------------------------------------------

  subroutine read_horiz_grid(nx, ny, ULAT, ULON, TLAT, TLON)

! Open and read the binary grid file

integer,                    intent(in)  :: nx, ny
real(r8), dimension(nx,ny), intent(out) :: ULAT, ULON, TLAT, TLON

!real(r8), dimension(nx,ny) :: &
!     HTN ,  &! length (cm) of north edge of T box
!     HTE ,  &! length (cm) of east  edge of T box
!     HUS ,  &! length (cm) of south edge of U box
!     HUW ,  &! length (cm) of west  edge of U box
!     ANGLE  ! angle

integer :: grid_unit, reclength

if ( .not. module_initialized ) call initialize_module

! Check to see that the file exists.

if ( .not. file_exist(grid_file) ) then
   msgstring = 'cice_in:grid_file '//trim(grid_file)//' not found'
   call error_handler(E_ERR,'read_horiz_grid', &
          msgstring, source, revision, revdate)
endif

! Open it and read them in the EXPECTED order.
! Actually, we only need the first two, so I'm skipping the rest.

grid_unit = get_unit()
INQUIRE(iolength=reclength) ULAT

open(grid_unit, file=trim(grid_file), form='unformatted', &
     access='direct', recl=reclength, status='old', action='read', convert=conversion)
read(grid_unit, rec=1) ULAT
read(grid_unit, rec=2) ULON
!read(grid_unit, rec=3) HTN
!read(grid_unit, rec=4) HTE
!read(grid_unit, rec=5) HUS
!read(grid_unit, rec=6) HUW
!read(grid_unit, rec=7) ANGLE
close(grid_unit)

call calc_tpoints(nx, ny, ULAT, ULON, TLAT, TLON)

! convert from radians to degrees

ULAT = ULAT * rad2deg
ULON = ULON * rad2deg
TLAT = TLAT * rad2deg
TLON = TLON * rad2deg

! ensure [0,360) [-90,90]

where (ULON <   0.0_r8) ULON = ULON + 360.0_r8
where (ULON > 360.0_r8) ULON = ULON - 360.0_r8
where (TLON <   0.0_r8) TLON = TLON + 360.0_r8
where (TLON > 360.0_r8) TLON = TLON - 360.0_r8

where (ULAT < -90.0_r8) ULAT = -90.0_r8
where (ULAT >  90.0_r8) ULAT =  90.0_r8
where (TLAT < -90.0_r8) TLAT = -90.0_r8
where (TLAT >  90.0_r8) TLAT =  90.0_r8

end subroutine read_horiz_grid

  subroutine calc_tpoints(nx, ny, ULAT, ULON, TLAT, TLON)
!------------------------------------------------------------------
! subroutine calc_tpoints(nx, ny, ULAT, ULON, TLAT, TLON)
!
! mimic POP grid.F90:calc_tpoints(), but for one big block.

integer,                    intent( in) :: nx, ny
real(r8), dimension(nx,ny), intent( in) :: ULAT, ULON
real(r8), dimension(nx,ny), intent(out) :: TLAT, TLON

integer  :: i, j
real(r8) :: xc,yc,zc,xs,ys,zs,xw,yw,zw   ! Cartesian coordinates for
real(r8) :: xsw,ysw,zsw,tx,ty,tz,da      ! nbr points

real(r8), parameter ::  c0 = 0.000_r8, c1 = 1.000_r8
real(r8), parameter ::  c2 = 2.000_r8, c4 = 4.000_r8
real(r8), parameter :: p25 = 0.250_r8, p5 = 0.500_r8
real(r8)            :: pi, pi2, pih, radian

if ( .not. module_initialized ) call initialize_module

! Define some constants as in cice

pi     = c4*atan(c1)
pi2    = c2*pi
pih    = p5*pi
radian = 180.0_r8/pi

! initialize these arrays to 0. in the code below there is
! a column that is referenced by a where() construct before
! those values are set.  make sure that it doesn't cause a
! floating point exception from random memory bits which aren't
! valid floating point numbers.
TLAT(:,:) = c0
TLON(:,:) = c0

do j=2,ny
do i=2,nx

   !*** convert neighbor U-cell coordinates to 3-d Cartesian coordinates
   !*** to prevent problems with averaging near the pole

   zsw = cos(ULAT(i-1,j-1))
   xsw = cos(ULON(i-1,j-1))*zsw
   ysw = sin(ULON(i-1,j-1))*zsw
   zsw = sin(ULAT(i-1,j-1))

   zs  = cos(ULAT(i  ,j-1))
   xs  = cos(ULON(i  ,j-1))*zs
   ys  = sin(ULON(i  ,j-1))*zs
   zs  = sin(ULAT(i  ,j-1))

   zw  = cos(ULAT(i-1,j  ))
   xw  = cos(ULON(i-1,j  ))*zw
   yw  = sin(ULON(i-1,j  ))*zw
   zw  = sin(ULAT(i-1,j  ))

   zc  = cos(ULAT(i  ,j  ))
   xc  = cos(ULON(i  ,j  ))*zc
   yc  = sin(ULON(i  ,j  ))*zc
   zc  = sin(ULAT(i  ,j  ))

   !*** straight 4-point average to T-cell Cartesian coords

   tx = p25*(xc + xs + xw + xsw)
   ty = p25*(yc + ys + yw + ysw)
   tz = p25*(zc + zs + zw + zsw)

   !*** convert to lat/lon in radians

   da = sqrt(tx**2 + ty**2 + tz**2)

   TLAT(i,j) = asin(tz/da)

   if (tx /= c0 .or. ty /= c0) then
      TLON(i,j) = atan2(ty,tx)
   else
      TLON(i,j) = c0
   endif

end do
end do

!*** for bottom row of domain where sw 4pt average is not valid,
!*** extrapolate from interior
!*** NOTE: THIS ASSUMES A CLOSED SOUTH BOUNDARY - WILL NOT
!***       WORK CORRECTLY FOR CYCLIC OPTION

do i=1,nx
   TLON(i,1) =    TLON(i,1+1)
   TLAT(i,1) = c2*TLAT(i,1+1) - TLAT(i,1+2)
end do

where (TLON(:,:) > pi2) TLON(:,:) = TLON(:,:) - pi2
where (TLON(:,:) < c0 ) TLON(:,:) = TLON(:,:) + pi2

!*** this leaves the leftmost/western edge to be filled
!*** if the longitudes wrap, this is easy.
!*** the gx3v5 grid TLON(:,2) and TLON(:,nx) are both about 2pi,
!*** so taking the average is reasonable.
!*** averaging the latitudes is always reasonable.

if ( trim(ew_boundary_type) == 'cyclic' ) then

   TLAT(1,:) = (TLAT(2,:) + TLAT(nx,:))/c2
   TLON(1,:) = (TLON(2,:) + TLON(nx,:))/c2

else
   write(msgstring,'(''cice_in&domain_nml:ew_boundary_type '',a,'' unknown.'')') &
                                    trim(ew_boundary_type)
   call error_handler(E_ERR,'calc_tpoints',msgstring,source,revision,revdate)
endif

end subroutine calc_tpoints

  subroutine read_topography(nx, ny, KMT, KMU)
!------------------------------------------------------------------
! subroutine read_topography(nx, ny, KMT, KMU)
!
! Open and read the binary topography file

integer,                   intent(in)  :: nx, ny
integer, dimension(nx,ny), intent(out) :: KMT, KMU

integer  :: i, j, topo_unit, reclength

if ( .not. module_initialized ) call initialize_module

! Check to see that the file exists.

if ( .not. file_exist(kmt_file) ) then
   msgstring = 'cice_in:kmt_file '//trim(kmt_file)//' not found'
   call error_handler(E_ERR,'read_topography', &
          msgstring, source, revision, revdate)
endif

! read the binary file

topo_unit = get_unit()
INQUIRE(iolength=reclength) KMT

open( topo_unit, file=trim(kmt_file), form='unformatted', &
            access='direct', recl=reclength, status='old', action='read', convert=conversion)
read( topo_unit, rec=1) KMT
close(topo_unit)

! the equation numbered 3.2 on page 15 of this document:
!  http://www.cesm.ucar.edu/models/cesm1.0/cice2/doc/sci/POPRefManual.pdf
! is WRONG.  (WRONG == inconsistent with the current POP source code.)
!
! for any U(i,j), the T(i,j) point with the same index values is located
! south and west. so the T points which surround any U(i,j) point are
! in fact at indices i,i+1, and j,j+1 .
!
!  NO: KMU(i,j) = min(KMT(i, j), KMT(i-1, j), KMT(i, j-1), KMT(i-1, j-1))
! YES: KMU(i,j) = min(KMT(i, j), KMT(i+1, j), KMT(i, j+1), KMT(i+1, j+1))
!
! the latter matches the POP source code, on yellowstone, lines 908 and 909 in:
!  /glade/p/cesm/releases/cesm1_2_2/models/ocn/pop2/source/grid.F90
!
! wrap around longitude boundary at i == nx.  set the topmost (last) latitude
! U row to the same value in all cases. in the shifted pole grid currently in
! use all these points are on land and so are 0.  in the original unshifted
! lat/lon grid these last row U points are above the final T row and are believed
! to be unused.  for completeness we set all values in the last U row to the
! minimum of the all T row values immediately below it, for all longitudes.

do j=1,ny-1
   do i=1,nx-1
      KMU(i,j) = min(KMT(i, j), KMT(i+1, j), KMT(i, j+1), KMT(i+1, j+1))
   enddo
   KMU(nx,j) = min(KMT(nx, j), KMT(1, j), KMT(nx, j+1), KMT(1, j+1))
enddo
KMU(:,ny) = minval(KMT(:,ny))

end subroutine read_topography

!------------------------------------------------------------------
! CMB removed read_vert_grid
!------------------------------------------------------------------

subroutine get_cice_restart_filename( filename )
character(len=*), intent(OUT) :: filename

if ( .not. module_initialized ) call initialize_module

filename   = trim(ic_filename)

end subroutine get_cice_restart_filename

!------------------------------------------------------------------

subroutine set_binary_file_conversion(convertstring)
character(len=*), intent(in) :: convertstring

if ( .not. module_initialized ) call initialize_module

conversion = convertstring

end subroutine set_binary_file_conversion

!------------------------------------------------------------------

end module dart_cice_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$