#version 450 core
layout(location = 0) out vec4 outColour;

/* Vertex Data */
in vec3 position;
in smooth vec3 normal;
in vec2 albedoUV;

in float fakeKd;
in vec3 vertexIndexColour;

in vec4 gl_FragCoord;

void main()
{
	vec4 Ka = vec4(0.5, 0.5, 0.5, 1);

	// float stripe = mod((albedoUV.x + albedoUV.y) / 64.0, 1.0);
	// stripe = (stripe > 0.5 ? 1.0 : 0.25);

	outColour = vec4(vertexIndexColour, 1) * min(fakeKd + Ka, 1);// * stripe;

	float z = (gl_FragCoord.z / gl_FragCoord.w) / 32000.0;
	outColour = mix(outColour, vec4(1, 1, 1, 1), z);

}


      SUBROUTINE MRED2G (KODE)
C
C     THIS SUBROUTINE CALCULATES THE FINAL STRUCTURAL MATRICES FOR THE
C     MRED2 MODULE.
C
C     INPUT DATA
C     GINO -   KBB    - STIFFNESS PARTITION MATRIX
C              KIB    - KIB  STIFFNESS PATTITION MATRIX
C              HIE    - HIE  PARTITION MATRIX
C              KII    - KII  PARTITION MATRIX
C              HGH    - HORG PARTITION MATRIX
C              MAA    - MASS INPUT MATRIX
C              BAA    - DAMPING INPUT MATRIX
C              K4AA   - STIFFNESS INPUT MATRIX
C              PAA    - LOADS INPUT MATRIX
C     SOF  -   GIMS   - G TRANSFORMATION MATRIX
C
C     OUTPUT DATA
C     GINO -   KHH    - STIFFNESS MATRIX
C              MHH    - MASS MATRIX
C              BHH    - DAMPING MATRIX
C              K4HH   - K4HH  MATRIX
C              PHH    - LOADS MATRIX
C     SOF  -   KMTX   - STIFFNESS MATRIX
C              MMTX   - MASS  MATRIX
C              PVEC   - LOADS MATRIX
C              PAPP   - APPENDED LOADS MATRIX
C              BMTX   - DAMPING MATRIX
C              K4MX   - K4MX STIFFNESS MATRIX
C
C     PARAMETERS
C     INPUT  - POPT   - LOADS OPTION FLAG
C              GBUF   - GINO BUFFERS
C              INFILE - INPUT   FILE NUMBERS
C              OTFILE - OUTPUT  FILE NUMBERS
C              ISCR   - SCRATCH FILE NUMBERS
C              KORLEN - LENGTH OF OPEN CORE
C              KORBGN - BEGINNING ADDRESS OF OPEN CORE
C              OLDNAM - NAME OF SUBSTRUCTURE BEING REDUCED
C     OTHERS - PAA    - LOADS INPUT FILE NUMBER
C              KHH    - STIFFNESS I
C              KHH    - STIFFNESS OUTPUT FILE NUMBER
C              POVE   - LOADS OUTPUT FILE NUMBER
C              UPRT   - PARTITION VECTOR FILE NUMBER
C              ZEROEB - ZERO PARTITION FILE NUMBER
C              KBB    - KBB INPUT FILE NUMBER
C              ZEROBE - ZERO PARTITION MATRIX
C              KIB    - KIB INPUT FILE NUMBER
C              KII    - KII INPUT FILE NUMBER
C              KBARBB - KBARBB FILE NU BER
C              GIB    - GIB INPUT FILE NUMBER
C              KEE    - KEE FILE NUMBER
C              HGH    - HORG INPUT FILE NUMBER
C
      LOGICAL          FREBDY,BOUNDS,MODES,PONLY
      INTEGER          DRY,POPT,GBUF1,SBUF1,SBUF2,SBUF3,OTFILE,OLDNAM,Z,
     1                 T,SIGNAB,SIGNC,PREC,SCR,TYPIN,TYPOUT,UN,UB,UI,
     2                 FUSET,PREC3,ZEROBE,ZEROEB,BLANKS,PAPP,PAA,POVE,
     3                 UPRT,GIB,HGH,HIE,RPRTN,CPRTN,USETMR,DBLKOR,EQST
      DOUBLE PRECISION DZ
      DIMENSION        MODNAM(2),ITRLR1(7),ITRLR2(7),ITRLR3(7),ISUB(4),
     1                 ITMLST(11),ITMNAM(2),RZ(1),DZ(1)
      CHARACTER        UFM*23
      COMMON /XMSSG /  UFM
      COMMON /BLANK /  IDUM1,DRY,POPT,GBUF1,IDUM2(2),SBUF1,SBUF2,SBUF3,
     1                 INFILE(12),OTFILE(6),ISCR(10),KORLEN,KORBGN,
     2                 OLDNAM(2),NEWNAM(2),FREBDY,IDUM6(5),BOUNDS,MODES,
     3                 IDUM7(4),PONLY,LSTZWD
      COMMON /ZZZZZZ/  Z(1)
      COMMON /SYSTEM/  IDUM3,IPRNTR
      COMMON /MPYADX/  ITRLRA(7),ITRLRB(7),ITRLRC(7),ITRLRD(7),NZ,T,
     1                 SIGNAB,SIGNC,PREC,SCR,DUMM
      COMMON /PACKX /  TYPIN,TYPOUT,IROW,NROW,INCR
      COMMON /BITPOS/  IDUM4(9),UN,IDUM5(10),UB,UI
      COMMON /PATX  /  LCORE,NSUB(3),FUSET
      COMMON /MPY3TL/  JTRLRA(7),JTRLRB(7),JTRLRE(7),JTRLRC(7),JSCR(3),
     1                 LKORE,ICODE,PREC3,DUMMY(13)
      EQUIVALENCE      (EQST,INFILE(5)),(USETMR,INFILE(5)),
     1                 (PAA,INFILE(10)),(KHH,OTFILE(1)),(POVE,OTFILE(6))
      EQUIVALENCE      (ZEROBE,ISCR(1)),(UPRT,ISCR(1)),(KIB,ISCR(2)),
     1                 (ZEROEB,ISCR(3)),(KII,ISCR(3)),(KBB,ISCR(1)),
     2                 (GIB,ISCR(4)),(KBARBB,ISCR(5)),(KEE,ISCR(6)),
     3                 (HIE,ISCR(7)),(HGH,ISCR(8)),(RPRTN,ISCR(2)),
     4                 (CPRTN,ISCR(4)),(RZ(1),Z(1)),(DZ(1),Z(1))
      DATA    MODNAM/  4HMRED,4H2G  /,      PAPP  ,BLANKS/4HPAPP,4H    /
      DATA    ITMLST/  4HKMTX,4HMMTX,4HBMTX,4HK4MX,4HPVEC,4HPAPP,4HPOVE,
     1                 4HGIMS,4HHORG,4HPOAP,4HUPRT/
      DATA    MRED2 /  27 /
C
C     SELECT OPERATION
C     KODE = 1, NO SETLVL, NO STIFFNESS CALCULATIONS
C     KODE = 2, SETLVL, STIFFNESS CALCULATIONS
C     KODE = 3, NO SETLVL, NO STIFFNESS CALCULATIONS
C     KODE = 4, SETLVL, NO STIFFNESS CALCULATIONS
C
      IF (DRY .EQ. -2) GO TO 300
      GO TO (90,1,90,1), KODE
C
C     SET UP NEW SUBSTRUCTURE
C
    1 IF (BOUNDS .OR. MODES) GO TO 5
      NUMB = 1
      CALL SETLVL (NEWNAM,NUMB,OLDNAM,ITEST,MRED2)
      IF (ITEST .EQ. 8) GO TO 290
    5 IF (KODE  .EQ. 4) GO TO 90
C
C     FORM PRELIMINARY STIFFNESS CALCULATION
C
C                                      T
C        **      **   **   **   **   ** **   **
C        *        *   *     *   *     * *     *
C        * KBARBB * = * KBB * + * GIB * * KIB *
C        *        *   *     *   *     * *     *
C        **      **   **   **   **   ** **   **
C
      ITRLR1(1) = KBB
      CALL RDTRL (ITRLR1)
      ITEM = ITMLST(8)
      ITMNAM(1) = OLDNAM(1)
      ITMNAM(2) = OLDNAM(2)
      CALL SOFTRL (OLDNAM,ITEM,ITRLR2)
      ITEST = ITRLR2(1)
      IF (ITEST .NE. 1) GO TO 200
      CALL MTRXI (GIB,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 1) GO TO 200
      CALL SOFCLS
      ITRLR2(1) = GIB
      CALL RDTRL (ITRLR2)
      ITRLR3(1) = KIB
      CALL RDTRL (ITRLR3)
      DO 10 I = 1,7
      ITRLRA(I) = ITRLR2(I)
      ITRLRB(I) = ITRLR3(I)
   10 ITRLRC(I) = ITRLR1(I)
      IFORM = 6
      IPRC  = 1
      ITYP  = 0
      IF ((ITRLRA(5) .EQ. 2) .OR. (ITRLRA(5) .EQ. 4)) IPRC = 2
      IF ((ITRLRB(5) .EQ. 2) .OR. (ITRLRB(5) .EQ. 4)) IPRC = 2
      IF ((ITRLRC(5) .EQ. 2) .OR. (ITRLRC(5) .EQ. 4)) IPRC = 2
      IF (ITRLRA(5) .GE. 3) ITYP = 2
      IF (ITRLRB(5) .GE. 3) ITYP = 2
      IF (ITRLRC(5) .GE. 3) ITYP = 2
      ITYPE = IPRC + ITYP
      CALL MAKMCB (ITRLRD,KBARBB,ITRLR1(3),IFORM,ITYPE)
      T      = 1
      SIGNAB = 1
      SIGNC  = 1
      PREC   = 0
      SCR    = ISCR(9)
      DBLKOR = KORBGN/2 + 1
      NZ = LSTZWD - (2*DBLKOR - 1)
      CALL MPYAD  (DZ(DBLKOR),DZ(DBLKOR),DZ(DBLKOR))
      CALL WRTTRL (ITRLRD)
      KBAROW = ITRLRD(3)
      KCOL   = ITRLRD(2)
C
C     FORM PRELIMINARY STIFFNESS CALCULATION
C
C                         T
C        **   **   **   ** **   ** **   **
C        *     *   *     * *     * *     *
C        * KEE * = * HIE * * KII * * HIE *
C        *     *   *     * *     * *     *
C        **   **   **   ** **   ** **   **
C
      ITRLR1(1) = HIE
      ITRLR2(1) = KII
      CALL RDTRL (ITRLR1)
      CALL RDTRL (ITRLR2)
      DO 20 I = 1,7
      JTRLRA(I) = ITRLR1(I)
      JTRLRB(I) = ITRLR2(I)
   20 JTRLRE(I) = 0
      IPRC = 1
      ITYP = 0
      IF (JTRLRA(5).EQ.2 .OR. JTRLRA(5).EQ.4) IPRC = 2
      IF (JTRLRB(5).EQ.2 .OR. JTRLRB(5).EQ.4) IPRC = 2
      IF (JTRLRA(5).GE.3 .OR. JTRLRB(5).GE.3) ITYP = 2
      ITYPE = IPRC + ITYP
      CALL MAKMCB (JTRLRC,KEE,ITRLR1(2),IFORM,ITYPE)
      JSCR(1) = ISCR(9)
      JSCR(2) = ISCR(2)
      JSCR(3) = ISCR(1)
      LKORE   = NZ
      ICODE   = 0
      PREC3   = 0
      CALL MPY3DR (DZ(DBLKOR))
      CALL WRTTRL (JTRLRC)
      KEEROW = JTRLRC(3)
      KEECOL = JTRLRC(2)
C
C     GENERATE MERGE PARTITION VECTOR
C
      NROW = KCOL + KEECOL
      DO 80 I = 1,NROW
      RZ(KORBGN+I-1) = 0.0
      IF (I .GT. KCOL) RZ(KORBGN+I-1) = 1.0
   80 CONTINUE
      TYPIN  = 1
      TYPOUT = 1
      IROW   = 1
      INCR   = 1
      IFORM  = 7
      CALL MAKMCB (ITRLR1,RPRTN,NROW,IFORM,TYPIN)
      CALL GOPEN  (RPRTN,Z(GBUF1),1)
      CALL PACK   (RZ(KORBGN),RPRTN,ITRLR1)
      CALL CLOSE  (RPRTN,1)
      CALL WRTTRL (ITRLR1)
C
C     FORM STIFFNESS MATRIX
C
C                  **            **
C                  *        .     *
C        **   **   * KBARBB .  0  *
C        *     *   *        .     *
C        * KHH * = *..............*
C        *     *   *        .     *
C        **   **   *   0    . KEE *
C                  *        .     *
C                  **            **
C
      ISUB(1) = KCOL
      ISUB(2) = KEECOL
      ISUB(3) = KBAROW
      ISUB(4) = KEEROW
      IFORM   = 6
      CALL GMMERG (KHH,KBARBB,0,0,KEE,RPRTN,RPRTN,ISUB,IFORM,Z(KORBGN),
     1             KORLEN)
C
C     STORE KHH AS KMTX ON SOF
C
      CALL SOFOPN (Z(SBUF1),Z(SBUF2),Z(SBUF3))
      ITMNAM(1) = NEWNAM(1)
      ITMNAM(2) = NEWNAM(2)
      CALL MTRXO (KHH,NEWNAM,ITMLST(1),0,ITEST)
      ITEM = ITMLST(1)
      IF (ITEST .NE. 3) GO TO 200
      GO TO 100
C
C     LOCATE HGH MATRIX
C
   90 CALL MTRXI (HGH,OLDNAM,ITMLST(9),0,ITEST)
      ITEM = ITMLST(9)
      ITMNAM(1) = OLDNAM(1)
      ITMNAM(2) = OLDNAM(2)
      IF (ITEST .NE. 1) GO TO 200
  100 SIGNAB = 1
      SIGNC  = 1
      SCR    = ISCR(1)
      DBLKOR = KORBGN/2 + 1
      LCORE  = LSTZWD - (2*DBLKOR - 1)
C
C     GENERATE MATRICES REQUESTED
C     I = 2, GENERATE MHH MATRIX
C     I = 3, GENERATE BHH MATRIX
C     I = 4, GENERATE K4HH MATRIX
C     I = 5, GENERATE PHH MATRIX
C
      DO 180 I = 2,5
      ITRLR1(1) = INFILE(I+5)
      CALL RDTRL (ITRLR1)
      IF (ITRLR1(1) .LT. 0) GO TO 180
      CALL SOFCLS
C
C     CALCULATE MATRIX REQUIRED
C
C                                T
C        **          **   **   ** **          ** **   **
C        *            *   *     * *            * *     *
C        * (M,B,K4)HH * = * HGH * * (M,B,K4)AA * * HGH *
C        *            *   *     * *            * *     *
C        **          **   **   ** **          ** **   **
C
C                         T
C        **   **   **   ** **   **
C        *     *   *     * *     *
C        * PHH * = * HGH * * PAA *
C        *     *   *     * *     *
C        **   **   **   ** **   **
C
      ITRLR2(1) = HGH
      CALL RDTRL (ITRLR2)
      ITEM = ITMLST(I)
      IF (I.EQ.5 .AND. POPT.EQ.PAPP) ITEM = ITMLST(6)
      DO 120 J = 1,7
      JTRLRA(J) = ITRLR2(J)
      JTRLRB(J) = ITRLR1(J)
  120 JTRLRE(J) = 0
      IFORM = 6
      IPRC  = 1
      ITYP  = 0
      IF (JTRLRA(5).EQ.2 .OR. JTRLRA(5).EQ.4) IPRC = 2
      IF (JTRLRB(5).EQ.2 .OR. JTRLRB(5).EQ.4) IPRC = 2
      IF (JTRLRA(5).GE.3 .OR. JTRLRB(5).GE.3) ITYP = 2
      ITYPE = IPRC + ITYP
      CALL MAKMCB (JTRLRC,OTFILE(I),ITRLR2(2),IFORM,ITYPE)
      JSCR(1) = ISCR(9)
      JSCR(2) = ISCR(2)
      JSCR(3) = ISCR(1)
      ICODE   = 0
      IF (I .EQ. 5) ICODE = 1
      PREC3 = 0
      CALL MPY3DR (DZ(DBLKOR))
      CALL WRTTRL (JTRLRC)
C
C     STORE MATRIX ON SOF
C     I = 2, STORE MHH AS MMTX
C     I = 3, STORE BHH AS BMTX
C     I = 4, STORE K4HH AS K4MX
C     I = 5, STORE PHH AS PVEC OR PAPP
C
      CALL SOFOPN (Z(SBUF1),Z(SBUF2),Z(SBUF3))
      ITMNAM(1) = NEWNAM(1)
      ITMNAM(2) = NEWNAM(2)
      CALL MTRXO (OTFILE(I),NEWNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 3) GO TO 200
  180 CONTINUE
C
C     TEST FOR LOAD PROCESSING
C
      IF (POPT .EQ. BLANKS) GO TO 190
      IF (.NOT. PONLY) GO TO 184
      ITRLR1(1) = EQST
      CALL RDTRL (ITRLR1)
      NSUB(1 )  = ITRLR1(6)
      NSUB(2)   = ITRLR1(7)
      ITEM      = ITMLST(11)
      ITMNAM(1) = OLDNAM(1)
      ITMNAM(2) = OLDNAM(2)
      CALL MTRXI (UPRT,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 1) GO TO 200
      GO TO 188
C
C     PARTITION PAA VECTOR
C
  184 LCORE = KORLEN
      FUSET = USETMR
      CALL CALCV (UPRT,UN,UI,UB,Z(KORBGN))
  188 CONTINUE
      CALL GMPRTN (PAA,POVE,0,0,0,0,UPRT,NSUB(1),NSUB(2),Z(KORBGN),
     1             KORLEN)
C
C     SAVE POVE AS POVE OR POAP ON SOF
C
      IF (MODES) GO TO 190
      ITEM = ITMLST(7)
      IF (POPT .EQ. PAPP) ITEM = ITMLST(10)
      CALL MTRXO (POVE,OLDNAM,ITEM,0,ITEST)
      IF (ITEST .NE. 3) GO TO 200
  190 CONTINUE
      GO TO 300
C
C     PROCESS MODULE ERRORS
C
  200 GO TO (210,220,230,240,250,270), ITEST
  210 IMSG = -9
      GO TO 280
  220 IMSG = -11
      GO TO 280
  230 IMSG = -1
      GO TO 260
  240 IMSG = -2
      GO TO 260
  250 IMSG = -3
  260 CALL SMSG (IMSG,ITEM,ITMNAM)
      GO TO 300
  270 IMSG = -10
  280 DRY  = -2
      CALL SMSG1 (IMSG,ITEM,ITMNAM,MODNAM)
      GO TO 300
  290 WRITE  (IPRNTR,295) UFM
  295 FORMAT (A23,' 6518, ONE OF THE COMPONENT SUBSTRUCTURES HAS BEEN ',
     1       'USED IN A PREVIOUS COMBINE OR REDUCE.')
      DRY = -2
  300 RETURN
      END


C
C $Id: pjindp.f,v 1.7 2008-07-27 00:17:12 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 PJINDP (ISYS,ZONE,ISPH,DATA)
C
      IMPLICIT DOUBLE PRECISION (A-Z)
      REAL SECS(5)
      INTEGER ITEMP
      INTEGER LAND, PATH, LIMIT, IND02, IND06, IND09, ISYS, KEEPZN
      INTEGER I,ZONE,ISPH,DEGS(5),MINS(5)
      INTEGER ID, IND, MODE, N
      INTEGER NAD27(134), NAD83(134)
C
      COMMON /STPLCH/ NM27,NM83
        CHARACTER*32 NM27(134),NM83(134)
      SAVE   /STPLCH/
      COMMON /STPLDP/ PA27,PA83
        DOUBLE PRECISION PA27(9,134),PA83(9,134)
      SAVE   /STPLDP/
      COMMON /STPLIR/ ID27,ID83
        INTEGER ID27(134),ID83(134)
      SAVE   /STPLIR/
C
      CHARACTER*32 PNAME
      CHARACTER*1 SGNA(5)
C
      DIMENSION DATA(15),BUFFL(15)
      DIMENSION TABLE(9)
      DIMENSION PR(20),XLR(20)
      DIMENSION ACOEF(6),BCOEF(6)
      COMMON /ERRMZ0/ IERR
        INTEGER IERR
      SAVE   /ERRMZ0/
      COMMON /PRINZ0/ IPEMSG,IPELUN,IPPARM,IPPLUN
        INTEGER IPEMSG,IPELUN,IPPARM,IPPLUN
      SAVE   /PRINZ0/
      COMMON /ELLPDP/ AZ,EZ,ESZ,E0Z,E1Z,E2Z,E3Z,E4Z
      COMMON /SPHRDP/ AZZ
      COMMON /NORMDP/ Q,T,U,W,ES22,P22,SA,CA,XJ
      COMMON /PC03DP/ A03,LON003,X003,Y003,C,E03,ES03,NS03,RH003
      COMMON /PC04DP/ A04,LON004,X004,Y004,E04,F04,NS04,RH004
      COMMON /PC05DP/ A05,LON005,X005,Y005,E05,M1
      COMMON /PC06DP/ A06,LON006,X006,Y006,E06,E4,FAC,MCS,TCS,IND06
      COMMON /PC07DP/ A07,LON007,X007,Y007,E07,E007,E107,E207,E307,ES07,
     .                ML007
      COMMON /PC08DP/ A08,LON008,X008,Y008,E008,E108,E208,E308,GL,NS08,
     .                RH008
      COMMON /PC09DP/ A09,LON009,X009,Y009,ES09,ESP,E009,E109,E209,E309,
     .                KS009,LAT009,ML009,IND09
      COMMON /PC10DP/ A10,LON010,X010,Y010,COSP10,LAT010,SINP10
      COMMON /PC11DP/ A11,LON011,X011,Y011,COSP11,LAT011,SINP11
      COMMON /PC12DP/ A12,LON012,X012,Y012,COSP12,LAT012,SINP12
      COMMON /PC13DP/ A13,LON013,X013,Y013,COSP13,LAT013,SINP13
      COMMON /PC14DP/ A14,LON014,X014,Y014,COSP14,LAT014,SINP14
      COMMON /PC15DP/ A15,LON015,X015,Y015,COSP15,LAT015,P,SINP15
      COMMON /PC16DP/ A16,LON016,X016,Y016
      COMMON /PC17DP/ A17,LON017,X017,Y017,LAT1
      COMMON /PC18DP/ A18,LON018,X018,Y018
      COMMON /PC19DP/ A19,LON019,X019,Y019
      COMMON /PC20DP/ LON020,X020,Y020,AL,BL,COSALF,COSGAM,E20,EL,
     +                SINALF,SINGAM,U0
      COMMON /PC21DP/ A21,LON021,X021,Y021,PR,XLR
      COMMON /PC22DP/ A22,X022,Y022,A2,A4,B,C1,C3,LAND,PATH
      COMMON /PC23DP/ A23,LON023,X023,Y023,ACOEF,BCOEF,EC,LAT023,
     .                CCHIO,SCHIO,N
C
      COMMON /USGSC1/  UTPA(15),UUMN,UUMX,UVMN,UVMX,IPRF
      DOUBLE PRECISION UTPA,UUMN,UUMX,UVMN,UVMX
      INTEGER IPRF
      SAVE   /USGSC1/
C
      DATA PI /3.14159265358979323846D0/
      DATA HALFPI /1.5707963267948966D0/
      DATA ZERO,HALF,ONE,TWO /0.0D0,0.5D0,1.0D0,2.0D0/
      DATA EPSLN /1.0D-10/
      DATA TOL /1.0D-7/
      DATA TOL09 /1.0D-5/
      DATA NINTYD /90000000.0D0/
      DATA DG1 /0.01745329252D0/
C
      DATA NAD27/0101,0102,5010,5300,0201,0202,0203,0301,0302,0401,0402,
     .           0403,0404,0405,0406,0407,0501,0502,0503,0600,0700,0901,
     .           0902,0903,1001,1002,5101,5102,5103,5104,5105,1101,1102,
     .           1103,1201,1202,1301,1302,1401,1402,1501,1502,1601,1602,
     .           1701,1702,1703,1801,1802,1900,2001,2002,2101,2102,2103,
     .           2111,2112,2113,2201,2202,2203,2301,2302,2401,2402,2403,
     .           2501,2502,2503,2601,2602,2701,2702,2703,2800,2900,3001,
     .           3002,3003,3101,3102,3103,3104,3200,3301,3302,3401,3402,
     .           3501,3502,3601,3602,3701,3702,3800,3901,3902,4001,4002,
     .           4100,4201,4202,4203,4204,4205,4301,4302,4303,4400,4501,
     .           4502,4601,4602,4701,4702,4801,4802,4803,4901,4902,4903,
     .           4904,5001,5002,5003,5004,5005,5006,5007,5008,5009,5201,
     .           5202,5400/
C
      DATA NAD83/0101,0102,5010,5300,0201,0202,0203,0301,0302,0401,0402,
     .           0403,0404,0405,0406,   0,0501,0502,0503,0600,0700,0901,
     .           0902,0903,1001,1002,5101,5102,5103,5104,5105,1101,1102,
     .           1103,1201,1202,1301,1302,1401,1402,1501,1502,1601,1602,
     .           1701,1702,1703,1801,1802,1900,2001,2002,2101,2102,2103,
     .           2111,2112,2113,2201,2202,2203,2301,2302,2401,2402,2403,
     .           2500,   0,   0,2600,   0,2701,2702,2703,2800,2900,3001,
     .           3002,3003,3101,3102,3103,3104,3200,3301,3302,3401,3402,
     .           3501,3502,3601,3602,3701,3702,3800,3900,   0,4001,4002,
     .           4100,4201,4202,4203,4204,4205,4301,4302,4303,4400,4501,
     .           4502,4601,4602,4701,4702,4801,4802,4803,4901,4902,4903,
     .           4904,5001,5002,5003,5004,5005,5006,5007,5008,5009,5200,
     .              0,5400/
C
C -- I N I T I A L I Z A T I O N   O F   P R O J E C T I O N S
C
      IPRF=0
      IERR=0
      IF (ISYS.NE.2) CALL SPHDDP (ISPH,DATA)
C
      GO TO ( 100, 200, 300, 400, 500, 600, 700, 800, 900,1000,
     +       1100,1200,1300,1400,1500,1600,1700,1800,1900,2000,
     +       2100,2200,2300) , ISYS
C
C -- U T M
C
  100    KEEPZN = ZONE
         ZONE = ABS(ZONE)
         IF (ZONE.LT.1 .OR. ZONE.GT.60) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,140) KEEPZN
  140       FORMAT (/' ERROR PJ01DP'/
     .               ' ILLEGAL ZONE NO. : ',I10)
            IERR = 011
            RETURN
         END IF
         DATA(3) = 0.9996D0
         DATA(4) = ZERO
         DATA(5) = DBLE(6*ZONE-183)
         DATA(6) = ZERO
         DATA(7) = 500000.0D0
         DATA(8) = ZERO
         IF (KEEPZN .LT. 0) DATA(8) = 10000000.0D0
         ITEMP = IPPARM
         IPPARM = 1
         AZ = DATA(1)
         EZ = DATA(2)
         GO TO 900
C
C -- S T A T E   P L A N E
C
  200    IF (ISPH.NE.0.AND.ISPH.NE.8) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,205) ISPH
  205       FORMAT(/' ERROR PJ02DP'/
     .              ' SPHEROID NO. ',I4,' IS INVALID FOR STATE PLANE',
     .              ' TRANSFORMATIONS')
            IERR = 020
            RETURN
         END IF
         IF (ZONE .GT. 0) THEN
            IND02 = 0
            IF (ISPH.EQ.0) THEN
               DO 210 I = 1,134
                  IF (ZONE .EQ. NAD27(I)) IND02 = I
  210          CONTINUE
            END IF
            IF (ISPH.EQ.8) THEN
               DO 220 I = 1,134
                  IF (ZONE .EQ. NAD83(I)) IND02 = I
  220          CONTINUE
            END IF
            IF (IND02 .EQ. 0) THEN
               IF (IPEMSG .EQ. 0) WRITE (IPELUN,240) ZONE,ISPH
               IERR = 021
               RETURN
            END IF
         ELSE
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,240) ZONE,ISPH
            IERR = 021
            RETURN
         END IF
         IF (ISPH.EQ.0) THEN
            PNAME=NM27(IND02)
            ID=ID27(IND02)
            TABLE(1)=PA27(1,IND02)
            TABLE(2)=PA27(2,IND02)
            TABLE(3)=PA27(3,IND02)
            TABLE(4)=PA27(4,IND02)
            TABLE(5)=PA27(5,IND02)
            TABLE(6)=PA27(6,IND02)
            TABLE(7)=PA27(7,IND02)
            TABLE(8)=PA27(8,IND02)
            TABLE(9)=PA27(9,IND02)
         ELSE IF (ISPH.EQ.8) THEN
            PNAME=NM83(IND02)
            ID=ID83(IND02)
            TABLE(1)=PA83(1,IND02)
            TABLE(2)=PA83(2,IND02)
            TABLE(3)=PA83(3,IND02)
            TABLE(4)=PA83(4,IND02)
            TABLE(5)=PA83(5,IND02)
            TABLE(6)=PA83(6,IND02)
            TABLE(7)=PA83(7,IND02)
            TABLE(8)=PA83(8,IND02)
            TABLE(9)=PA83(9,IND02)
         END IF
         IF (ID .LE. 0) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,240) ZONE,ISPH
  240       FORMAT(/' ERROR PJ02DP'/
     .              ' ILLEGAL ZONE NO. : ',I8,' FOR SPHEROID NO. : ',I4)
            IERR = 021
            RETURN
         END IF
         AZ = TABLE(1)
         ES = TABLE(2)
         ESZ = ES
         EZ  = SQRT(ES)
         E0Z = E0FNDP(ES)
         E1Z = E1FNDP(ES)
         E2Z = E2FNDP(ES)
         E3Z = E3FNDP(ES)
         E4Z = E4FNDP(EZ)
         ITEMP = IPPARM
         IPPARM = 1
C
C TRANSVERSE MERCATOR PROJECTION
C
         IF (ID.EQ.1) THEN
            DATA(3) = TABLE(4)
            DATA(5) = PAKRDP(PAKCDP(TABLE(3)))/.017453292519943D0
            DATA(6) = PAKRDP(PAKCDP(TABLE(7)))/.017453292519943D0
            DATA(7) = TABLE(8)
            DATA(8) = TABLE(9)
            GO TO 900
         END IF
C
C LAMBERT CONFORMAL PROJECTION
C
         IF (ID.EQ.2) THEN
            DATA(3) = PAKRDP(PAKCDP(TABLE(6)))/.017453292519943D0
            DATA(4) = PAKRDP(PAKCDP(TABLE(5)))/.017453292519943D0
            DATA(5) = PAKRDP(PAKCDP(TABLE(3)))/.017453292519943D0
            DATA(6) = PAKRDP(PAKCDP(TABLE(7)))/.017453292519943D0
            DATA(7) = TABLE(8)
            DATA(8) = TABLE(9)
            GO TO 400
         END IF
C
C POLYCONIC PROJECTION
C
         IF (ID.EQ.3) THEN
            DATA(5) = PAKRDP(PAKCDP(TABLE(3)))/.017453292519943D0
            DATA(6) = PAKRDP(PAKCDP(TABLE(4)))/.017453292519943D0
            DATA(7) = TABLE(5)
            DATA(8) = TABLE(6)
            GO TO 700
         END IF
C
C OBLIQUE MERCATOR PROJECTION
C
         IF (ID.EQ.4) THEN
            DATA(3) = TABLE(4)
            DATA(4) = PAKRDP(PAKCDP(TABLE(6)))/.017453292519943D0
            DATA(5) = PAKRDP(PAKCDP(TABLE(3)))/.017453292519943D0
            DATA(6) = PAKRDP(PAKCDP(TABLE(7)))/.017453292519943D0
            DATA(7) = TABLE(8)
            DATA(8) = TABLE(9)
            DATA(13) = ONE
            GO TO 2000
         END IF
C
C -- A L B E R S   C O N I C A L   E Q U A L   A R E A
C
  300    A03 = AZ
         E03 = EZ
         ES03 = ESZ
         LAT1 = .017453292519943D0 * DATA(3)
         LAT2 = .017453292519943D0 * DATA(4)
         IF (ABS(LAT1+LAT2) .LT. EPSLN) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,340)
  340       FORMAT (/' ERROR PJ03DP'/
     .               ' EQUAL LATITUDES FOR ST. PARALLELS ON OPPOSITE',
     .               ' SIDES OF EQUATOR')
            IERR = 031
            RETURN
         END IF
         LON003 = .017453292519943D0 * DATA(5)
         LAT003 = .017453292519943D0 * DATA(6)
         X003 = DATA(7)
         Y003 = DATA(8)
         SINP03 = SIN (LAT1)
         CON = SINP03
         COSP03 = COS (LAT1)
         MS1 = MSFNDP (E03,SINP03,COSP03)
         QS1 = QSFNDP (E03,SINP03,COSP03)
         SINP03 = SIN (LAT2)
         COSP03 = COS (LAT2)
         MS2 = MSFNDP (E03,SINP03,COSP03)
         QS2 = QSFNDP (E03,SINP03,COSP03)
         SINP03 = SIN (LAT003)
         COSP03 = COS (LAT003)
         QS0 = QSFNDP (E03,SINP03,COSP03)
         IF (ABS(LAT1-LAT2) .GE. EPSLN) THEN
            NS03 = (MS1 * MS1 - MS2 * MS2) / (QS2 - QS1)
         ELSE
            NS03 = CON
         END IF
         C = MS1 * MS1 + NS03 * QS1
         RH003 = A03 * SQRT (C - NS03 * QS0) / NS03
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LAT1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT2,SGNA(2),DEGS(2),MINS(2),SECS(2))
         CALL RADDDP (LON003,SGNA(3),DEGS(3),MINS(3),SECS(3))
         CALL RADDDP (LAT003,SGNA(4),DEGS(4),MINS(4),SECS(4))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,350) A03,ES03,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,4),
     .            X003,Y003
  350   FORMAT (/' INITIALIZATION PARAMETERS (ALBERS CONICAL EQUAL-AREA'
     .          ,' PROJECTION)'/
     .           ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .           ' ECCENTRICITY SQUARED         =',F12.9/
     .           ' LATITUDE OF 1ST ST. PARALLEL = ',A1,2I3,F7.3/
     .           ' LATITUDE OF 2ND ST. PARALLEL = ',A1,2I3,F7.3/
     .           ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .           ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .           ' FALSE EASTING                =',F12.2,' METERS'/
     .           ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=3
         GO TO 9900
C
C -- L A M B E R T   C O N F O R M A L   C O N I C
C
  400    A04 = AZ
         E04 = EZ
         ES = ESZ
         LAT1 = .017453292519943D0 * DATA(3)
         LAT2 = .017453292519943D0 * DATA(4)
         IF (ABS(LAT1+LAT2) .LT. EPSLN) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,440)
  440       FORMAT (/' ERROR PJ04DP'/
     .               ' EQUAL LATITUDES FOR ST. PARALLELS ON OPPOSITE',
     .               ' SIDES OF EQUATOR')
            IERR = 041
            RETURN
         END IF
         LON004 = .017453292519943D0 * DATA(5)
         LAT004 = .017453292519943D0 * DATA(6)
         X004 = DATA(7)
         Y004 = DATA(8)
         SINP04 = SIN (LAT1)
         CON = SINP04
         COSP04 = COS (LAT1)
         MS1 = MSFNDP (E04,SINP04,COSP04)
         TS1 = TSFNDP (E04,LAT1,SINP04)
         SINP04 = SIN (LAT2)
         COSP04 = COS (LAT2)
         MS2 = MSFNDP (E04,SINP04,COSP04)
         TS2 = TSFNDP (E04,LAT2,SINP04)
         SINP04 = SIN (LAT004)
         TS0 = TSFNDP (E04,LAT004,SINP04)
         IF (ABS(LAT1-LAT2) .GE. EPSLN) THEN
            NS04 = LOG (MS1 / MS2) / LOG (TS1 / TS2)
         ELSE
            NS04 = CON
         END IF
         F04 = MS1 / (NS04 * TS1 ** NS04)
         RH004 = A04 * F04 * TS0 ** NS04
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LAT1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT2,SGNA(2),DEGS(2),MINS(2),SECS(2))
         CALL RADDDP (LON004,SGNA(3),DEGS(3),MINS(3),SECS(3))
         CALL RADDDP (LAT004,SGNA(4),DEGS(4),MINS(4),SECS(4))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,450) A04,ES,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,4),
     .            X004,Y004
  450    FORMAT (/' INITIALIZATION PARAMETERS (LAMBERT CONFORMAL CONIC',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LATITUDE OF 1ST ST. PARALLEL = ',A1,2I3,F7.3/
     .            ' LATITUDE OF 2ND ST. PARALLEL = ',A1,2I3,F7.3/
     .            ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         DATA(1) = A04
         DATA(2) = ES
C
C LIST STATE PLANE INITIALIZATION PARAMETERS IF NECESSARY
C
         IF (ISYS .EQ. 2) THEN
            IPPARM = ITEMP
            IF (IERR .NE. 0) RETURN
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,470) ZONE, PNAME
  470    FORMAT (/' INITIALIZATION PARAMETERS (STATE PLANE PROJECTION)'/
     .            ' ZONE NUMBER = ',I4,5X,' ZONE NAME = ',A32)
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,451) A04,ES,
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,4),
     .               X004,Y004
  451    FORMAT ( ' USING LAMBERT CONFORMAL CONIC PROJECTION'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LATITUDE OF 1ST ST. PARALLEL = ',A1,2I3,F7.3/
     .            ' LATITUDE OF 2ND ST. PARALLEL = ',A1,2I3,F7.3/
     .            ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         END IF
C
         IPRF=4
         GO TO 9900
C
C -- M E R C A T O R
C
  500    A05 = AZ
         E05 = EZ
         ES = ESZ
         LON005 = .017453292519943D0 * DATA(5)
         LAT1 = .017453292519943D0 * DATA(6)
         M1 = COS(LAT1) / (SQRT( ONE - ES * SIN(LAT1) **2))
         X005 = DATA(7)
         Y005 = DATA(8)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LAT1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LON005,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,550) A05,ES,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X005,Y005
  550    FORMAT (/' INITIALIZATION PARAMETERS (MERCATOR',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LATITUDE OF TRUE SCALE       = ',A1,2I3,F7.3/
     .            ' CENTRAL LONGITUDE            = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=5
         GO TO 9900
C
C -- P O L A R   S T E R E O G R A P H I C
C
  600    A06 = AZ
         E06 = EZ
         ES = ESZ
         E4 = E4Z
         LON006 = .017453292519943D0 * DATA(5)
         SAVE = DATA(6)
         LATC = .017453292519943D0 * SAVE
         X006 = DATA(7)
         Y006 = DATA(8)
         FAC = ONE
         IF (SAVE .LT. ZERO) FAC =-ONE
         IND06 = 0
         IF (ABS(SAVE) .NE. NINTYD) THEN
            IND06 = 1
            CON1 = FAC * LATC
            SINPHI = SIN (CON1)
            COSPHI = COS (CON1)
            MCS = MSFNDP (E06,SINPHI,COSPHI)
            TCS = TSFNDP (E06,CON1,SINPHI)
         END IF
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON006,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LATC,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,650) A06,ES,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X006,Y006
  650    FORMAT (/' INITIALIZATION PARAMETERS (POLAR STEREOGRAPHIC',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LONGITUDE OF Y-AXIS          = ',A1,2I3,F7.3/
     .            ' LATITUDE OF TRUE SCALE       = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=6
         GO TO 9900
C
C -- P O L Y C O N I C
C
  700    A07 = AZ
         E07 = EZ
         ES07 = ESZ
         E007 = E0Z
         E107 = E1Z
         E207 = E2Z
         E307 = E3Z
         LON007 = .017453292519943D0 * DATA(5)
         LAT007 = .017453292519943D0 * DATA(6)
         X007 = DATA(7)
         Y007 = DATA(8)
         ML007 = MLFNDP (E007,E107,E207,E307,LAT007)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON007,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT007,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,750) A07,ES07,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X007,Y007
  750    FORMAT (/' INITIALIZATION PARAMETERS (POLYCONIC',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         DATA(1) = A07
         DATA(2) = ES07
C
C LIST STATE PLANE INITIALIZATION PARAMETERS IF NECESSARY
C
         IF (ISYS .EQ. 2) THEN
            IPPARM = ITEMP
            IF (IERR .NE. 0) RETURN
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,470) ZONE, PNAME
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,751) A07,ES07,
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .               X007,Y007
  751    FORMAT ( ' USING POLYCONIC PROJECTION'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         END IF
C
         IPRF=7
         GO TO 9900
C
C -- E Q U I D I S T A N T   C O N I C
C
  800    A08 = AZ
         E = EZ
         ES = ESZ
         E008 = E0Z
         E108 = E1Z
         E208 = E2Z
         E308 = E3Z
         LAT1 = .017453292519943D0 * DATA(3)
         LAT2 = .017453292519943D0 * DATA(4)
         IF (ABS(LAT1+LAT2) .LT. EPSLN) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,840)
  840       FORMAT (/' ERROR PJ08DP'/
     .               ' EQUAL LATITUDES FOR ST. PARALLELS ON OPPOSITE',
     .               ' SIDES OF EQUATOR')
            IERR = 081
            RETURN
         END IF
         LON008 = .017453292519943D0 * DATA(5)
         LAT0 = .017453292519943D0 * DATA(6)
         X008 = DATA(7)
         Y008 = DATA(8)
         SINPHI = SIN (LAT1)
         COSPHI = COS (LAT1)
         MS1 = MSFNDP (E,SINPHI,COSPHI)
         ML1 = MLFNDP (E008,E108,E208,E308,LAT1)
         IND = 0
         IF (DATA(9) .NE. ZERO) THEN
            IND = 1
            SINPHI = SIN (LAT2)
            COSPHI = COS (LAT2)
            MS2 = MSFNDP (E,SINPHI,COSPHI)
            ML2 = MLFNDP (E008,E108,E208,E308,LAT2)
            IF (ABS(LAT1-LAT2) .GE. EPSLN) THEN
               NS08 = (MS1 - MS2) / (ML2 - ML1)
            ELSE
               NS08 = SINPHI
            END IF
         ELSE
            NS08 = SINPHI
         END IF
         GL = ML1 + MS1 / NS08
         ML0 = MLFNDP (E008,E108,E208,E308,LAT0)
         RH008 = A08 * (GL - ML0)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LAT1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT2,SGNA(2),DEGS(2),MINS(2),SECS(2))
         CALL RADDDP (LON008,SGNA(3),DEGS(3),MINS(3),SECS(3))
         CALL RADDDP (LAT0,SGNA(4),DEGS(4),MINS(4),SECS(4))
         IF (IND .NE. 0) THEN
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,850) A08,ES,
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,4),
     .               X008,Y008
  850       FORMAT (/' INITIALIZATION PARAMETERS (EQUIDISTANT CONIC',
     .               ' PROJECTION)'/
     .               ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .               ' ECCENTRICITY SQUARED         =',F12.9/
     .               ' LATITUDE OF 1ST ST. PARALLEL = ',A1,2I3,F7.3/
     .               ' LATITUDE OF 2ND ST. PARALLEL = ',A1,2I3,F7.3/
     .               ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .               ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .               ' FALSE EASTING                =',F12.2,' METERS'/
     .               ' FALSE NORTHING               =',F12.2,' METERS')
         ELSE
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,860) A08,ES,
     .                SGNA(1),DEGS(1),MINS(1),SECS(1),
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=3,4),
     .               X008,Y008
  860       FORMAT (/' INITIALIZATION PARAMETERS (EQUIDISTANT CONIC',
     .               ' PROJECTION)'/
     .               ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .               ' ECCENTRICITY SQUARED         =',F12.9/
     .               ' LATITUDE OF ST. PARALLEL     = ',A1,2I3,F7.3/
     .               ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .               ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .               ' FALSE EASTING                =',F12.2,' METERS'/
     .               ' FALSE NORTHING               =',F12.2,' METERS')
         END IF
         IPRF=8
         GO TO 9900
C
C -- T R A N S V E R S E   M E R C A T O R
C
  900    A09 = AZ
         E09 = EZ
         ES09 = ESZ
         E009 = E0Z
         E109 = E1Z
         E209 = E2Z
         E309 = E3Z
         KS009 = DATA(3)
         LON009 = .017453292519943D0 * DATA(5)
         LAT009 = .017453292519943D0 * DATA(6)
         X009 = DATA(7)
         Y009 = DATA(8)
         ML009 = A09 * MLFNDP (E009,E109,E209,E309,LAT009)
         IND09 = 1
         ESP = ES09
         IF (E09 .GE. TOL09) THEN
            IND09 = 0
            ESP = ES09 / (ONE - ES09)
         END IF
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON009,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT009,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,950) A09,ES09,KS009,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X009,Y009
  950    FORMAT (/' INITIALIZATION PARAMETERS (TRANSVERSE MERCATOR',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' SCALE FACTOR AT C. MERIDIAN  =',F9.6/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         DATA(1) = A09
         DATA(2) = ES09
C
C LIST UTM PROJECTION INITIALIZATION PARAMETERS IF NECESSARY
C
         IF (ISYS .EQ. 1) THEN
            IPPARM = ITEMP
            BUFFL(1) = A09
            BUFFL(2) = ES09
            ZONE = KEEPZN
            IF (IERR .NE. 0) RETURN
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,960) ZONE,BUFFL(1),
     .            BUFFL(2),BUFFL(3),
     .            SGNA(1),DEGS(1),MINS(1),SECS(1),
     .            BUFFL(7),BUFFL(8)
  960    FORMAT (/' INITIALIZATION PARAMETERS (U T M PROJECTION)'/
     .            ' ZONE = ',I3/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID = ',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         = ',F18.15/
     .            ' SCALE FACTOR AT C. MERIDIAN  = ',F9.6/
     .            ' LONGITUDE OF CENTRAL MERIDIAN= ',A1,2I3,F7.3/
     .            ' FALSE EASTING                = ',F12.2,' METERS'/
     .            ' FALSE NORTHING               = ',F12.2,' METERS')
         END IF
C
C LIST STATE PLANE INITIALIZATION PARAMETERS IF NECESSARY
C
         IF (ISYS .EQ. 2) THEN
            IPPARM = ITEMP
            IF (IERR .NE. 0) RETURN
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,470) ZONE, PNAME
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,951) A09,ES09,KS009,
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .               X009,Y009
  951    FORMAT ( ' USING TRANSVERSE MERCATOR PROJECTION'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' SCALE FACTOR AT C. MERIDIAN  =',F9.6/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         END IF
C
         IPRF=9
         GO TO 9900
C
C -- S T E R E O G R A P H I C
C
 1000    A10 = AZZ
         LON010 = .017453292519943D0 * DATA(5)
         LAT010 = .017453292519943D0 * DATA(6)
         X010 = DATA(7)
         Y010 = DATA(8)
         SINP10 = SIN (LAT010)
         COSP10 = COS (LAT010)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON010,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT010,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1050) A10,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X010,Y010
 1050    FORMAT (/' INITIALIZATION PARAMETERS (STEREOGRAPHIC',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=10
         GO TO 9900
C
C -- L A M B E R T   A Z I M U T H A L   E Q U A L - A R E A
C
 1100    A11 = AZZ
         LON011 = .017453292519943D0 * DATA(5)
         LAT011 = .017453292519943D0 * DATA(6)
         X011 = DATA(7)
         Y011 = DATA(8)
         SINP11 = SIN (LAT011)
         COSP11 = COS (LAT011)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON011,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT011,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1150) A11,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X011,Y011
 1150    FORMAT (/' INITIALIZATION PARAMETERS (LAMBERT AZIMUTHAL EQUAL',
     .            '-AREA PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=11
         GO TO 9900
C
C -- A Z I M U T H A L   E Q U I D I S T A N T
C
 1200    A12 = AZZ
         LON012 = .017453292519943D0 * DATA(5)
         LAT012 = .017453292519943D0 * DATA(6)
         X012 = DATA(7)
         Y012 = DATA(8)
         SINP12 = SIN (LAT012)
         COSP12 = COS (LAT012)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON012,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT012,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1250) A12,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X012,Y012
 1250    FORMAT (/' INITIALIZATION PARAMETERS (AZIMUTHAL EQUIDISTANT',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=12
         GO TO 9900
C
C -- G N O M O N I C
C
 1300    A13 = AZZ
         LON013 = .017453292519943D0 * DATA(5)
         LAT013 = .017453292519943D0 * DATA(6)
         X013 = DATA(7)
         Y013 = DATA(8)
         SINP13 = SIN (LAT013)
         COSP13 = COS (LAT013)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON013,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT013,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1350) A13,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X013,Y013
 1350    FORMAT (/' INITIALIZATION PARAMETERS (GNOMONIC',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=13
         GO TO 9900
C
C -- O R T H O G R A P H I C
C
 1400    A14 = AZZ
         LON014 = .017453292519943D0 * DATA(5)
         LAT014 = .017453292519943D0 * DATA(6)
         X014 = DATA(7)
         Y014 = DATA(8)
         SINP14 = SIN (LAT014)
         COSP14 = COS (LAT014)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON014,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT014,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1450) A14,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X014,Y014
 1450    FORMAT (/' INITIALIZATION PARAMETERS (ORTHOGRAPHIC',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=14
         GO TO 9900
C
C -- V E R T I C A L   N E A R - S I D E   P E R S P E C T I V E
C
 1500    A15 = AZZ
         P = ONE + DATA(3) / A15
         LON015 = .017453292519943D0 * DATA(5)
         LAT015 = .017453292519943D0 * DATA(6)
         X015 = DATA(7)
         Y015 = DATA(8)
         SINP15 = SIN (LAT015)
         COSP15 = COS (LAT015)
C
C     LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON015,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT015,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1550) A15,DATA(3),
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X015,Y015
 1550    FORMAT (/' INITIALIZATION PARAMETERS (GENERAL VERTICAL NEAR-S',
     .            'IDE PERSPECTIVE PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' HEIGHT OF PERSPECTIVE POINT'/
     .            ' ABOVE SPHERE                 =',F12.2,' METERS'/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=15
         GO TO 9900
C
C -- S I N U S O I D A L
C
 1600    A16 = AZZ
         LON016 = .017453292519943D0 * DATA(5)
         X016 = DATA(7)
         Y016 = DATA(8)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON016,SGNA(1),DEGS(1),MINS(1),SECS(1))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1650) A16,
     .            SGNA(1),DEGS(1),MINS(1),SECS(1),
     .            X016,Y016
 1650    FORMAT (/' INITIALIZATION PARAMETERS (SINUSOIDAL',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=16
         GO TO 9900
C
C -- E Q U I R E C T A N G U L A R
C
 1700    A17 = AZZ
         LAT1 = .017453292519943D0 * DATA(6)
         LON017 = .017453292519943D0 * DATA(5)
         X017 = DATA(7)
         Y017 = DATA(8)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LAT1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LON017,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1750) A17,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X017,Y017
 1750    FORMAT (/' INITIALIZATION PARAMETERS (EQUIRECTANGULAR PROJECT',
     .            'ION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LATITUDE OF TRUE SCALE       = ',A1,2I2,F7.3/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=17
         GO TO 9900
C
C -- M I L L E R   C Y L I N D R I C A L
C
 1800    A18 = AZZ
         LON018 = .017453292519943D0 * DATA(5)
         X018 = DATA(7)
         Y018 = DATA(8)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON018,SGNA(1),DEGS(1),MINS(1),SECS(1))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1850) A18,
     .             SGNA(1),DEGS(1),MINS(1),SECS(1),
     .             X018,Y018
 1850    FORMAT (/' INITIALIZATION PARAMETERS (MILLER CYLINDRICAL',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=18
         GO TO 9900
C
C -- V A N   D E R   G R I N T E N   I
C
 1900    A19 = AZZ
         LON019 = .017453292519943D0 * DATA(5)
         X019 = DATA(7)
         Y019 = DATA(8)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON019,SGNA(1),DEGS(1),MINS(1),SECS(1))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,1950) A19,
     .             SGNA(1),DEGS(1),MINS(1),SECS(1),
     .             X019,Y019
 1950    FORMAT (/' INITIALIZATION PARAMETERS (VAN DER GRINTEN I',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=19
         GO TO 9900
C
C -- O B L I Q U E   M E R C A T O R   ( H O T I N E )
C
 2000    MODE = 0
         IF (DATA(13) .NE. ZERO) MODE = 1
         A = AZ
         E20 = EZ
         ES = ESZ
         KS0 = DATA(3)
         LAT0 = .017453292519943D0 * DATA(6)
         X020 = DATA(7)
         Y020 = DATA(8)
         SINPH0 = SIN (LAT0)
         COSPH0 = COS (LAT0)
         CON = ONE - ES * SINPH0 * SINPH0
         COM = SQRT (ONE - ES)
         BL = SQRT (ONE + ES * COSPH0 ** 4 / (ONE - ES))
         AL = A * BL * KS0 * COM / CON
         IF (ABS(LAT0).LT.EPSLN) TS0 = 1.0D0
         IF (ABS(LAT0).LT.EPSLN) D=1.0D0
         IF (ABS(LAT0).LT.EPSLN) EL=1.0D0
         IF (ABS(LAT0).GE.EPSLN) THEN
            TS0 = TSFNDP (E20,LAT0,SINPH0)
            CON = SQRT (CON)
            D = BL * COM / (COSPH0 * CON)
            F = D + SIGN (SQRT (MAX ((D * D - ONE), 0.0D0)) , LAT0)
            EL = F * TS0 ** BL
         END IF
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2050) A,ES,KS0,X020,Y020
 2050    FORMAT (/' INITIALIZATION PARAMETERS (OBLIQUE MERCATOR ''HOTI',
     .            'NE'' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' SCALE AT CENTER              =',F12.9/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IF (MODE .NE. 0) THEN
            ALPHA = .017453292519943D0 * DATA(4)
            LONC = .017453292519943D0 * DATA(5)
            G = HALF * (F - ONE / F)
            GAMMA = ASINDP (SIN (ALPHA) / D)
            LON020 = LONC - ASINDP (G * TAN (GAMMA)) / BL
C
C LIST INITIALIZATION PARAMETERS (CASE B).
C
            CALL RADDDP (ALPHA,SGNA(1),DEGS(1),MINS(1),SECS(1))
            CALL RADDDP (LONC,SGNA(2),DEGS(2),MINS(2),SECS(2))
            CALL RADDDP (LAT0,SGNA(3),DEGS(3),MINS(3),SECS(3))
            IF (IPPARM .EQ. 0) WRITE (IPPLUN,2060)
     .               (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,3)
 2060       FORMAT (' AZIMUTH OF CENTRAL LINE      = ',A1,2I3,F7.3/
     .              ' LONGITUDE OF ORIGIN          = ',A1,2I3,F7.3/
     .              ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3)
            CON = ABS (LAT0)
            IF (CON.GT.EPSLN .AND. ABS(CON - HALFPI).GT.EPSLN) THEN
               SINGAM = SIN (GAMMA)
               COSGAM = COS (GAMMA)
               SINALF = SIN (ALPHA)
               COSALF = COS (ALPHA)
               U0 = SIGN((AL/BL)*ATAN(SQRT(D*D-ONE)/COSALF),LAT0)
               IF (IPPARM .EQ. 0) WRITE (IPPLUN,2080) X020,Y020
               DATA(1) = A
               DATA(2) = ES
C
C LIST STATE PLANE INITIALIZATION PARAMETERS IF NECESSARY
C
               IF (ISYS .EQ. 2) THEN
                  IPPARM = ITEMP
                  IF (IERR .NE. 0) RETURN
                  IF (IPPARM .EQ. 0) WRITE (IPPLUN,470) ZONE, PNAME
                  IF (IPPARM .EQ. 0) WRITE (IPPLUN,2051) A,ES,KS0,X020,
     .                                                            Y020
 2051 FORMAT ( ' USING OBLIQUE MERCATOR (''HOTINE'') PROJECTION'/
     .         ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .         ' ECCENTRICITY SQUARED         =',F12.9/
     .         ' SCALE AT CENTER              =',F12.9/
     .         ' FALSE EASTING                =',F12.2,' METERS'/
     .         ' FALSE NORTHING               =',F12.2,' METERS')
                  IF (IPPARM .EQ. 0) WRITE (IPPLUN,2060)
     .                     (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,3)
               END IF
C
               IPRF=20
               GO TO 9900
            ELSE
               IF (IPEMSG .EQ. 0) WRITE (IPELUN,2040)
 2040          FORMAT (/' ERROR PJ20DP'/
     .                  ' INPUT DATA ERROR')
               IERR = 201
               RETURN
            END IF
         END IF
         LON1 = .017453292519943D0 * DATA(9)
         LAT1 = .017453292519943D0 * DATA(10)
         LON2 = .017453292519943D0 * DATA(11)
         LAT2 = .017453292519943D0 * DATA(12)
         SINPHI = SIN (LAT1)
         TS1 = TSFNDP (E20,LAT1,SINPHI)
         SINPHI = SIN (LAT2)
         TS2 = TSFNDP (E20,LAT2,SINPHI)
         H = TS1 ** BL
         L = TS2 ** BL
         F = EL / H
         G = HALF * (F - ONE / F)
         J = (EL * EL - L * H) / (EL * EL + L * H)
         P = (L - H) / (L + H)
         CALL RADDDP (LON2,SGNA(3),DEGS(3),MINS(3),SECS(3))
         DLON = LON1 - LON2
         IF (DLON .LT. -PI) LON2 = LON2 - 2.D0 * PI
         IF (DLON .GT.  PI) LON2 = LON2 + 2.D0 * PI
         DLON = LON1 - LON2
         LON020 = HALF * (LON1 + LON2) - ATAN (J * TAN (HALF * BL *
     .          DLON) / P) / BL
         DLON = ADJLDP (LON1 - LON020)
         GAMMA = ATAN (SIN (BL * DLON) / G)
         ALPHA = ASINDP (D * SIN (GAMMA))
         CALL RADDDP (LON1,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT1,SGNA(2),DEGS(2),MINS(2),SECS(2))
         CALL RADDDP (LAT2,SGNA(4),DEGS(4),MINS(4),SECS(4))
         CALL RADDDP (LAT0,SGNA(5),DEGS(5),MINS(5),SECS(5))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2070)
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,5)
 2070    FORMAT (' LONGITUDE OF 1ST POINT       = ',A1,2I3,F7.3/
     .           ' LATITUDE OF 1ST POINT        = ',A1,2I3,F7.3/
     .           ' LONGITUDE OF 2ND POINT       = ',A1,2I3,F7.3/
     .           ' LATITUDE OF 2ND POINT        = ',A1,2I3,F7.3/
     .           ' LATITUDE OF ORIGIN           = ',A1,2I3,F7.3)
         IF (ABS(LAT1 - LAT2) .LE. EPSLN) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2040)
            IERR = 202
            RETURN
         ELSE
            CON = ABS (LAT1)
         END IF
         IF (CON.LE.EPSLN .OR. ABS(CON - HALFPI).LE.EPSLN) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2040)
            IERR = 202
            RETURN
         ELSE
            IF (ABS(ABS(LAT0) - HALFPI) .LE. EPSLN) THEN
               IF (IPEMSG .EQ. 0) WRITE (IPELUN,2040)
               IERR = 202
               RETURN
            END IF
         END IF
         SINGAM = SIN (GAMMA)
         COSGAM = COS (GAMMA)
         SINALF = SIN (ALPHA)
         COSALF = COS (ALPHA)
         U0 = SIGN((AL/BL)*ATAN(SQRT(D*D-ONE)/COSALF),LAT0)
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2080) X020,Y020
 2080    FORMAT (' FALSE EASTING                =',F12.2,' METERS'/
     .           ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=20
         GO TO 9900
C
C -- R O B I N S O N
C
 2100    A21 = AZZ
         LON021 = .017453292519943D0 * DATA(5)
         X021 = DATA(7)
         Y021 = DATA(8)
         PR(1)=-0.062D0
         XLR(1)=0.9986D0
         PR(2)=0.D0
         XLR(2)=1.D0
         PR(3)=0.062D0
         XLR(3)=0.9986D0
         PR(4)=0.124D0
         XLR(4)=0.9954D0
         PR(5)=0.186D0
         XLR(5)=0.99D0
         PR(6)=0.248D0
         XLR(6)=0.9822D0
         PR(7)=0.31D0
         XLR(7)=0.973D0
         PR(8)=0.372D0
         XLR(8)=0.96D0
         PR(9)=0.434D0
         XLR(9)=0.9427D0
         PR(10)=0.4958D0
         XLR(10)=0.9216D0
         PR(11)=0.5571D0
         XLR(11)=0.8962D0
         PR(12)=0.6176D0
         XLR(12)=0.8679D0
         PR(13)=0.6769D0
         XLR(13)=0.835D0
         PR(14)=0.7346D0
         XLR(14)=0.7986D0
         PR(15)=0.7903D0
         XLR(15)=0.7597D0
         PR(16)=0.8435D0
         XLR(16)=0.7186D0
         PR(17)=0.8936D0
         XLR(17)=0.6732D0
         PR(18)=0.9394D0
         XLR(18)=0.6213D0
         PR(19)=0.9761D0
         XLR(19)=0.5722D0
         PR(20)=1.0D0
         XLR(20)=0.5322D0
         DO 2110 I=1,20
 2110    XLR(I)=XLR(I) * 0.9858D0
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON021,SGNA(1),DEGS(1),MINS(1),SECS(1))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2150) A21,
     .             SGNA(1),DEGS(1),MINS(1),SECS(1),
     .             X021,Y021
 2150    FORMAT (/' INITIALIZATION PARAMETERS (ROBINSON',
     .            ' PROJECTION)'/
     .            ' RADIUS OF SPHERE             =',F12.2,' METERS'/
     .            ' LONGITUDE OF C. MERIDIAN     = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=21
         GO TO 9900
C
C -- S P A C E   O B L I Q U E   M E R C A T O R
C
 2200    A22 = AZ
         E = EZ
         ES22 = ESZ
         X022 = DATA(7)
         Y022 = DATA(8)
         LAND = INT(DATA(3)+TOL)
         PATH = INT(DATA(4)+TOL)
C
C CHECK IF LANDSAT NUMBER IS WITHIN RANGE 1 - 5
C
         IF (LAND .GT. 0 .AND. LAND .LE. 5) THEN
            IF (LAND .LE. 3) LIMIT = 251
            IF (LAND .GE. 4) LIMIT = 233
         ELSE
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2240) LAND, PATH
            IERR = 221
            RETURN
         END IF
C
C CHECK IF PATH NUMBER IS WITHIN RANGE 1 - 251 FOR LANDSATS 1 - 3
C OR RANGE 1 - 233 FOR LANDSATS 4 - 5
C
         IF (PATH .LE. 0 .OR. PATH .GT. LIMIT) THEN
            IF (IPEMSG .EQ. 0) WRITE (IPELUN,2240) LAND, PATH
 2240       FORMAT (/' ERROR PJ22DP'/
     .               ' LANDSAT NUMBER ',I2,' AND / OR PATH NUMBER ',I4,
     .               ' ARE OUT OF RANGE')
            IERR = 221
            RETURN
         END IF
         P1=1440.0D0
         IF (LAND.LE.3) THEN
            P2=103.2669323D0
            ALF=99.092D0*DG1
         ELSE
            P2=98.8841202D0
            ALF=98.20D0*DG1
         END IF
         SA=SIN(ALF)
         CA=COS(ALF)
         IF (ABS(CA).LT.1.D-9) CA=1.D-9
         ESC=ES22*CA*CA
         ESS=ES22*SA*SA
         W=((ONE-ESC)/(ONE-ES22))**TWO-ONE
         Q=ESS/(ONE-ES22)
         T=(ESS*(TWO-ES22))/(ONE-ES22)**TWO
         U=ESC/(ONE-ES22)
         XJ=(ONE-ES22)**3
         P22=P2/P1
C
C COMPUTE FOURIER COEFFICIENTS.  LAM IS CURRENT VALUE OF
C LAMBDA DOUBLE-PRIME.
C
         LAM=0
         CALL SERADP (FB,FA2,FA4,FC1,FC3,LAM)
         SUMA2=FA2
         SUMA4=FA4
         SUMB=FB
         SUMC1=FC1
         SUMC3=FC3
         DO 2210 I=9,81,18
         LAM=I
         CALL SERADP (FB,FA2,FA4,FC1,FC3,LAM)
         SUMA2=SUMA2+4.0D0*FA2
         SUMA4=SUMA4+4.0D0*FA4
         SUMB=SUMB+4.0D0*FB
         SUMC1=SUMC1+4.0D0*FC1
         SUMC3=SUMC3+4.0D0*FC3
 2210    CONTINUE
         DO 2220 I=18,72,18
         LAM=I
         CALL SERADP (FB,FA2,FA4,FC1,FC3,LAM)
         SUMA2=SUMA2+TWO*FA2
         SUMA4=SUMA4+TWO*FA4
         SUMB=SUMB+TWO*FB
         SUMC1=SUMC1+TWO*FC1
         SUMC3=SUMC3+TWO*FC3
 2220    CONTINUE
         LAM=90.0D0
         CALL SERADP (FB,FA2,FA4,FC1,FC3,LAM)
         SUMA2=SUMA2+FA2
         SUMA4=SUMA4+FA4
         SUMB=SUMB+FB
         SUMC1=SUMC1+FC1
         SUMC3=SUMC3+FC3
C
C THESE ARE THE VALUES OF FOURIER CONSTANTS.
C
         A2=SUMA2/30.D0
         A4=SUMA4/60.D0
         B=SUMB/30.D0
         C1=SUMC1/15.D0
         C3=SUMC3/45.D0
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2250) A22,ES22,LAND,PATH,
     .                                          X022,Y022
 2250    FORMAT (/' INITIALIZATION PARAMETERS (SPACE OBL. MERCATOR',
     .            ' PROJECTION)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LANDSAT NO.                  = ',I3/
     .            ' PATH                         = ',I5/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS'/)
         IPRF=22
         GO TO 9900
C
C -- M O D I F I E D   S T E R E O G R A P H I C   -   A L A S K A
C
 2300    A23 = AZ
         EC2 = 0.6768657997291094D-02
         EC  = SQRT (EC2)
         N=6
         LON023 = -152.0D0*DG1
         LAT023 = 64.0D0*DG1
         X023 = DATA(7)
         Y023 = DATA(8)
         ACOEF(1)=0.9945303D0
         ACOEF(2)=0.0052083D0
         ACOEF(3)=0.0072721D0
         ACOEF(4)=-0.0151089D0
         ACOEF(5)=0.0642675D0
         ACOEF(6)=0.3582802D0
         BCOEF(1)=0.0D0
         BCOEF(2)=-.0027404D0
         BCOEF(3)=0.0048181D0
         BCOEF(4)=-0.1932526D0
         BCOEF(5)=-0.1381226D0
         BCOEF(6)=-0.2884586D0
         ESPHI=EC*SIN(LAT023)
         CHIO=TWO*ATAN(TAN((HALFPI+LAT023)/TWO)*((ONE-ESPHI)/
     .       (ONE+ESPHI))**(EC/TWO)) - HALFPI
         SCHIO=SIN(CHIO)
         CCHIO=COS(CHIO)
C
C LIST RESULTS OF PARAMETER INITIALIZATION.
C
         CALL RADDDP (LON023,SGNA(1),DEGS(1),MINS(1),SECS(1))
         CALL RADDDP (LAT023,SGNA(2),DEGS(2),MINS(2),SECS(2))
         IF (IPPARM .EQ. 0) WRITE (IPPLUN,2350) A23,EC2,
     .            (SGNA(I),DEGS(I),MINS(I),SECS(I),I=1,2),
     .            X023,Y023
 2350    FORMAT (/' INITIALIZATION PARAMETERS (MOD. STEREOGRAPHIC',
     .            ' CONFORMAL PROJECTION, ALASKA)'/
     .            ' SEMI-MAJOR AXIS OF ELLIPSOID =',F12.2,' METERS'/
     .            ' ECCENTRICITY SQUARED         =',F12.9/
     .            ' LONGITUDE OF CENTER          = ',A1,2I3,F7.3/
     .            ' LATITUDE  OF CENTER          = ',A1,2I3,F7.3/
     .            ' FALSE EASTING                =',F12.2,' METERS'/
     .            ' FALSE NORTHING               =',F12.2,' METERS')
         IPRF=23
         GO TO 9900
C
 9900 DO 9999 I=1,15
        UTPA(I)=DATA(I)
 9999 CONTINUE
C
      RETURN
C
      END


C> @file drive2_cmt.f mid-level initialization drivers. Not long for this world.
c-----------------------------------------------------------------------
      subroutine nek_cmt_init
      include 'SIZE'
      include 'TOTAL'
      include 'DG'
      include 'CMTDATA'
      if (nio.eq.0) write(6,*)'Set up CMT-Nek'
      if (toteq.ne.5) then
         if (nio.eq.0) write(6,*)'toteq is low ! toteq = ',toteq
         if (nio.eq.0) write(6,*) 'Reset toteq in SIZE to 5'
         call exitt
      endif
      if (ifrestart) then
         ifheat = .true. ! almost certainly incorrect
      endif
      call setup_cmt_commo

      iostep2=iostep
      iostep=9999999

c     call setup_cmt_param
      return
      end

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

      subroutine izero8(a,n)
      integer*8 a(1)
      do i=1,n
         a(i)=0
      enddo
      return
      end
!-----------------------------------------------------------------------
      subroutine setup_cmt_param
      INCLUDE 'SIZE'
      INCLUDE 'INPUT'
      INCLUDE 'CMTDATA'
      INCLUDE 'CMTBCDATA'

      real  MixtPerf_R_CpG, MixtPerf_T_DPR, MixtPerf_C_GRT
     >                 ,MixtPerf_Ho_CpTUVW,MixtPerf_Cp_CvR,MixtPerf_R_M
     >                 ,MixtPerf_G_CpR
      external MixtPerf_R_CpG, MixtPerf_T_DPR, MixtPerf_C_GRT
     >                 ,MixtPerf_Ho_CpTUVW,MixtPerf_Cp_CvR,MixtPerf_R_M
     >                 ,MixtPerf_G_CpR

      cip_adhoc=10.0
      cvgref     = param(104)
c     gmaref     = param(105)
      molmass    = param(106)
      muref      = param(107)
      coeflambda = param(108)
      suthcoef   = param(109)
      reftemp    = param(110)
      prlam      = param(111)
      pinfty     = param(112)
      rgasref    = MixtPerf_R_M(molmass,dum)
      cpgref     = MixtPerf_Cp_CvR(cvgref,rgasref)
      gmaref     = MixtPerf_G_CpR(cpgref,rgasref)
! put these in rea file someday
      return
      end
c------------------------------------------------------------------------

      subroutine limiter
! EBDG Stuff. WHERE'S PHI????
      include 'SIZE'
      include 'TOTAL'
      include 'CMTDATA'
      include 'NEKUSE'
      parameter (lxyz=lx1*ly1*lz1)
      common /scrns/ scr(lxyz),avstate(toteq)
      real scr,avstate
      integer e,eg
      real kemax

      nxyz=lx1*ly1*lz1
      ntot=nxyz*nelt

      epslon=1.0e-9

!     rgam=rgasref/(gmaref-1.0)
!      do i=1,ntot
!         rho=max(vtrans(i,1,1,1,irho),1.0e-10)
!!        scr(i,1)=rgam*log(pr(i,1,1,1)/(rho**gmaref))
!         scr(i,1)=log(pr(i,1,1,1)/(rho**gmaref))
!      enddo
!!     call dsop(scr,'MIN',lx1,ly1,lz1)
!      call copy(t(1,1,1,1,4),scr,ntot)
!! elemental entropy minimum
!!     do e=1,nelt
!!        se0(e)=vlmin(scr(1,e),nxyz)
!!     enddo

      do e=1,nelt

!        rhomin=vlmin(vtrans(1,1,1,e,irho),nxyz)
         rhomin=vlmin(u(1,1,1,1,e),nxyz)

! positivity-preserving limiter of Zhang and Shu: density
         rho=vlsc2(bm1(1,1,1,e),u(1,1,1,1,e),nxyz)/volel(e)
!        if (abs(rho-rhomin) .gt. epslon) then
         theta=min((rho-epslon)/(rho-rhomin+epslon),1.0)
         if (rho .lt. epslon) then
            write(6,'(a33,2i5,1p3e15.7)')
     >        'rho<epslon,nid,e,rho,rhomin,theta',nid,e,rho,rhomin,theta
            do i=1,nxyz
               uold=u(i,1,1,1,e)
               u(i,1,1,1,e)=rho+theta*(uold-rho)
            enddo
         else
            do i=1,nxyz
               uold=u(i,1,1,1,e)
               u(i,1,1,1,e)=rho+abs(theta)*(uold-rho)
            enddo
         endif
         call cfill(t(1,1,1,e,4),theta,nxyz)
!        rho=vlsc2(bm1(1,1,1,e),u(1,1,1,1,e),nxyz)/volel(e)

! positivity-preserving limiter of Lv & Ihme: internal energy
! first compute kinetic energy density
         if (if3d) then
            call vdot3(scr,
     >             u(1,1,1,irpu,e),u(1,1,1,irpv,e),u(1,1,1,irpw,e),
     >             u(1,1,1,irpu,e),u(1,1,1,irpv,e),u(1,1,1,irpw,e),nxyz)
         else
            call vdot2(scr,u(1,1,1,irpu,e),u(1,1,1,irpv,e),
     >                     u(1,1,1,irpu,e),u(1,1,1,irpv,e),nxyz)
         endif
         call invcol2(scr,u(1,1,1,irg,e),nxyz)
         call cmult(scr,0.5,nxyz)
!-----------------------------------------------------------------------
! JH091818 thinking about limiter pegged to max KE. explore this alternate
!          diagnostically
!         kemax=vlmax(scr,nxyz)
!-----------------------------------------------------------------------
! then subtract it off to get internal energy density in scr
         call sub2(scr,u(1,1,1,iret,e),nxyz)
         call chsign(scr,nxyz)
! violation if negative energy density
         tau=vlmin(scr,nxyz)
         tau=min(tau,0.0)
!-----------------------------------------------------------------------
! JH091818
! overwrite scr to explore alternate limiter below
!-----------------------------------------------------------------------
!         kemax=-kemax
!         call cadd2(scr,u(1,1,1,5,e),kemax,nxyz)
!-----------------------------------------------------------------------

! now for rhoe(avstate)
         do m=1,toteq
            avstate(m)=vlsc2(bm1(1,1,1,e),u(1,1,1,m,e),nxyz)/volel(e)
         enddo
         rhoeavg=avstate(5)-
     >              0.5*(avstate(2)**2+avstate(3)**2+avstate(4)**2)/
     >                   avstate(1)

         if (rhoeavg .lt. 0.0) then
            write(6,*) 'duh sir , can''t get positive e(avg)',e,rhoeavg,
     >                 tau,nid
            epsebdg(e)=1.0
         else
            epsebdg(e)=tau/(tau-rhoeavg)
         endif
!        epsebdg(e)=1.0 ! Godunov test
         do m=1,toteq
            do i=1,nxyz
               uold=u(i,1,1,m,e)
               u(i,1,1,m,e)=uold+epsebdg(e)*(avstate(m)-uold)
            enddo
         enddo

!-----------------------------------------------------------------------
! diagnostics
!-----------------------------------------------------------------------
         call cfill(t(1,1,1,e,5),epsebdg(e),nxyz)
! JH091818
! alternate limiter trying to keep U5 > kemax (at best ultraconservative)
!         tau=vlmin(scr,nxyz)
!         tau=min(tau,0.0)
!         epsalot=tau/(tau-(avstate(5)+kemax))
!         call cfill(t(1,1,1,e,5),epsalot,nxyz)
!-----------------------------------------------------------------------

!         rho=avstate(1)
!! Entropy-bounded limiter of Lv and Ihme
!-----------------------------------------------------------------------
! JH091118 This isn't ready for non-ideal state equations or volume fraction
!-----------------------------------------------------------------------
!         e_internal=avstate(5)-
!     >              0.5*(avstate(2)**2+avstate(3)**2+avstate(4)**2)/
!     >                   rho
!         e_internal=e_internal/rho
!         eg=gllel(e)
!         call cmt_userEOS(1,1,1,eg) ! assigns elm avg to  pres and temp
!         do i=1,nxyz
!            scr(i)=pr(i,1,1,e)-exp(se0const)*
!     >                         (u(i,1,1,1,e)**gmaref)
!         enddo
!         tau=vlmin(scr,nxyz)
!         tau=min(tau,0.0)
!         epsebdg(e)=tau/
!     >          (tau-(pres-exp(se0const)*rho**gmaref))
!         epsebdg(e)=min(epsebdg(e),1.0)
!         epsebdg(e)=max(epsebdg(e),0.0)
!! diagnostic
!         call cfill(t(1,1,1,e,5),epsebdg(e),nxyz)
!
!         do m=1,toteq
!            do i=1,nxyz
!               uold=u(i,1,1,m,e)
!               u(i,1,1,m,e)=uold+epsebdg(e)*(avstate(m)-uold)
!            enddo
!         enddo
!-----------------------------------------------------------------------

      enddo

      return
      end

!-----------------------------------------------------------------------
! JH082118 shock detectors. Test shock detectors in usr file extensively.
!          port them here after they have earned our trust.
!-----------------------------------------------------------------------

      subroutine AVeverywhere(shkdet)
      include 'SIZE'
      include 'TOTAL'
      real shkdet(nelt)
      call rone(shkdet,nelt)
      return
      end

      subroutine limiter_only(shkdet)
! worst ad hoc shock detector ever. read a limiter function from CMTDATA
! epsebdg is the only one we have so far. If it's bigger than some threshold,
! apply AV there too.
      include 'SIZE'
      include 'CMTDATA'
      real shkdet(nelt)
      integer e

      call rzero(shkdet,nelt)
      tol=1.0e-5

      if (.not.time4av) then
         do e=1,nelt
            if (abs(epsebdg(e)) .gt. tol) shkdet(e)=1.0
         enddo
      endif

      emax=glamax(shkdet,nelt)
      if (nio.eq.0) write(6,*) 'max shock detector =',emax

      return
      end


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1993  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine kangang  --  angle-angle parameter assignment  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "kangang" assigns the parameters for angle-angle cross term
c     interactions and processes new or changed parameter values
c
c
      subroutine kangang
      implicit none
      include 'sizes.i'
      include 'angang.i'
      include 'angle.i'
      include 'atmlst.i'
      include 'atmtyp.i'
      include 'atoms.i'
      include 'couple.i'
      include 'inform.i'
      include 'iounit.i'
      include 'kanang.i'
      include 'keys.i'
      include 'potent.i'
      integer i,j,k,m,next
      integer it,ia,ic
      integer nang,jang,kang
      real*8 fa,faa,aak(3)
      logical header
      character*20 keyword
      character*120 record
      character*120 string
c
c
c     process keywords containing angle-angle parameters
c
      header = .true.
      do i = 1, nkey
         next = 1
         record = keyline(i)
         call gettext (record,keyword,next)
         call upcase (keyword)
         if (keyword(1:7) .eq. 'ANGANG ') then
            it = 0
            do j = 1, 3
               aak(j) = 0.0d0
            end do
            string = record(next:120)
            read (string,*,err=10,end=10)  it,(aak(j),j=1,3)
   10       continue
            if (.not. silent) then
               if (header) then
                  header = .false.
                  write (iout,20)
   20             format (/,' Additional Angle-Angle Parameters :',
     &                    //,5x,'Atom Class',8x,'K(AA) 1',4x,'K(AA) 2',
     &                       4x,'K(AA) 3',/)
               end if
               write (iout,30)  it,(aak(j),j=1,3)
   30          format (9x,i3,7x,3f11.3)
            end if
            do j = 1, 3
               anan(j,it) = aak(j)
            end do
         end if
      end do
c
c     assign the angle-angle parameters for each angle pair
c
      nangang = 0
      do i = 1, n
         nang = n12(i) * (n12(i)-1) / 2
         it = class(i)
         do j = 1, nang-1
            jang = anglist(j,i)
            ia = iang(1,jang)
            ic = iang(3,jang)
            m = 1
            if (atomic(ia) .le. 1)  m = m + 1
            if (atomic(ic) .le. 1)  m = m + 1
            fa = anan(m,it)
            do k = j+1, nang
               kang = anglist(k,i)
               ia = iang(1,kang)
               ic = iang(3,kang)
               m = 1
               if (atomic(ia) .le. 1)  m = m + 1
               if (atomic(ic) .le. 1)  m = m + 1
               faa = fa * anan(m,it)
               if (faa .ne. 0.0d0) then
                  nangang = nangang + 1
                  iaa(1,nangang) = jang
                  iaa(2,nangang) = kang
                  kaa(nangang) = faa
               end if
            end do
         end do
      end do
c
c     turn off the angle-angle potential if it is not used
c
      if (nangang .eq. 0)  use_angang = .false.
      return
      end


!> ------------------------------------------------------------------------------
!! REMESH
!!  Adjust the mesh spacing of a model.
!! ------------------------------------------------------------------------------
!!  Input:
!!     KH2 - new number of meshpoints
!!           KH in the common block holds the current number of meshpoints
!!     JCH - How to remesh:
!!           1, 2: Only initialise new variables (the options are equivalent)
!!           3:    Calculate new mesh spacing and redistribute meshpoints
!!           4:    As (3), but also homogenise composition profile
!!     BMS - New total binary mass            [Msun]
!!      TM - New primary mass                 [Msun]
!!      P1 - New rotational period for star   [days]
!!     ECC - New orbital eccentricity
!!      OA - New orbital angular momentum     [g cm^2/s]
!!   JSTAR - Which star in the binary to remesh (1 or 2)
!!      JF - Flag indicating which variables were present in the input file
!!           and which need to be recalculated (bitfield):
!!           Bit 1: (1) Unused
!!           Bit 2: (2) if set, take potential and moment of inertia from model
!!           Bit 3: (4) Indicates whether DH(:,:) is present in the input file
!!           Bit 4: (8) Indicates whether nucleosynthesis data is present
!!
!! ------------------------------------------------------------------------------
#include "assert.h"

subroutine remesh ( kh2, jch, bms, tm, p1, ecc, oa, jstar, jf )
   use real_kind
   use mesh
   use mesh_enc
   use constants
   use settings
   use atomic_data
   use test_variables
   use eostate_types
   use structure_functions
   use structure_variables
   use accretion_abundances
   use nucleosynthesis
   use interpolate
   use indices
   implicit none
   integer, intent(in) :: kh2, jch, jstar, jf
   real(double), intent(in) :: bms, tm, p1, ecc, oa
   real(double) :: r

   integer :: i,ik,ikk
   real(double) :: ex_max,che,vma,qe,hpc,vd,q1,q2,qk
   type(eostate) :: eos

   !Common blocks:
   real(double) :: var(nvar), dvar(nvar), fn1(nfunc)
   real(double) :: vars(nvar), varc(nvar)
   real(double) :: qa(NM)
   type(interpolate_t) :: interpol_h(NVSTAR + NVBIN)
   type(interpolate_t) :: interpol_dh(NVSTAR + NVBIN)
   type(interpolate_t) :: interpol_hnuc(50)

   real(double) :: xh, xhe, xc, xn, xo, xne, xmg, xsi, xfe
   real(double) :: qq            ! Determines mesh-point metric: mesh-point interval
   real(double) :: qm            ! Determines mesh-point metric: derivative of mesh spacing function wrt mass
   real(double) :: phim          ! Derivative of gravitational potential with respect to m**(2/3)
   real(double) :: gmr           ! Effective gravity at the surface(?)
   real(double) :: m3            ! m^(1/3), m is the mass coordinate
   real(double) :: mc1           ! Core mass for star 1, backup
   real(double) :: nmf

   ! Sanity checks
   assert(kh2 <= max_nm)
   assert(kh <= max_nm)
   assert(allocated(h))
   assert(allocated(sx))
   assert(oa >= 0.0d0)
   assert(ecc >= 0.0d0)
   assert(ecc <= 1.0d0)
   assert(p1 > 0.0d0)
   assert(bms > tm)

   ! Record initial age
   age0 = age

   ! Set initial composition.
   ! The composition variables are NOT the actual mass fractions if we
   ! use non-integer atomic masses, so we have to compute what they are
   ! The composition variables used in the code are baryon number fractions
   ! We calculate this even if we don't want to do a ZAMS run because we need to
   ! know the baryon number densities of Fe, Si and Mg.
   che = 1.0d0 - ch - czs
   cn = 1.0d0 - cc - co - cne - cmg - csi - cfe
   xh = ch*cbn(1)/can(1)
   xhe = che*cbn(2)/can(2)
   xc = cc*czs*cbn(3)/can(3)
   xn = cn*czs*cbn(4)/can(4)
   xo = co*czs*cbn(5)/can(5)
   xne = cne*czs*cbn(6)/can(6)
   xmg = cmg*czs
   xsi = csi*max(czs, 1.0d-4)
   xfe = cfe*max(czs, 1.0d-4)
   vma = xh + xhe + xc + xn + xo + xne + xmg + xsi + xfe
   xfe = xfe / vma
   xsi = xsi / vma
   xmg = xmg / vma

   ! Mg24 is never stored in the input model!
   xmg = max(1.0 - (xh+xhe+xc+xn+xo+xne)/vma-(xsi+xfe), 0.0d0)
   h(VAR_MG24, 1:kh) = xmg
   if (use_mg24_eqn) then
      do ik=1, kh
         xmg = h(VAR_H1,ik) + h(VAR_HE4, ik) + h(VAR_C12, ik) + h(VAR_O16, ik) + h(VAR_NE20, ik) + h(VAR_N14, ik) + xfe + xsi
         h(VAR_MG24,ik) = max(0.0d0, 1.0 - xmg)
      end do
   end if
   if ( jch >= 4 ) then
      h(VAR_H1,  1:kh) = xh/vma
      h(VAR_O16, 1:kh) = xo/vma
      h(VAR_HE4, 1:kh) = xhe/vma
      h(VAR_C12, 1:kh) = xc/vma
      h(VAR_NE20,1:kh) = xne/vma
      h(VAR_N14, 1:kh) = xn/vma
   end if
   h(VAR_SI28, 1:kh) = xsi
   h(VAR_FE56, 1:kh) = xfe

   ! Now we must also convert the abundances of the accreted material. If not
   ! set from init.dat, set from initial abundances.
   if (x1ac < 0.0) x1ac = ch*cbn(1)/can(1)
   if (x4ac < 0.0) x4ac = che*cbn(2)/can(2)
   if (x12ac < 0.0) x12ac = cc*czs*cbn(3)/can(3)
   if (x14ac < 0.0) x14ac = cn*czs*cbn(4)/can(4)
   if (x16ac < 0.0) x16ac = co*czs*cbn(5)/can(5)
   if (x20ac < 0.0) x20ac = cne*czs*cbn(6)/can(6)
   if (x24ac < 0.0) x24ac = cmg*czs*cbn(7)/can(7)
   if (x28ac < 0.0) x28ac = csi*czs*cbn(8)/can(8)
   if (x56ac < 0.0) x56ac = cfe*czs*cbn(9)/can(9)
   ! make sure XH is 1-everything else and abundancies sum to 1
   x1ac = max(0.0d0, 1.0d0 -(x4ac+x12ac+x14ac+x16ac+x20ac+x24ac+csi*czs+cfe*czs))

   xh = x1ac*cbn(1)/can(1)
   xhe = x4ac*cbn(2)/can(2)
   xc = x12ac*cbn(3)/can(3)
   xn = x14ac*cbn(4)/can(4)
   xo = x16ac*cbn(5)/can(5)
   xne = x20ac*cbn(6)/can(6)
   xmg = x24ac*cbn(7)/can(7)
   xsi = x28ac*cbn(8)/can(8)
   xfe = x56ac*cbn(9)/can(9)

   vma = xh + xhe + xc + xn + xo + xne + xmg + xsi + xfe

   x1ac  = xh / vma
   x4ac  = xhe / vma
   x12ac = xc / vma
   x14ac = xn / vma
   x16ac = xo / vma
   x20ac = xne / vma
   x24ac = xmg / vma
   x28ac = xsi / vma
   x56ac = xfe / vma

   ! Initialise accretion abundances for both stars
   xac(1, 1:2) = x1ac
   xac(2, 1:2) = x4ac
   xac(3, 1:2) = x12ac
   xac(4, 1:2) = x14ac
   xac(5, 1:2) = x16ac
   xac(6, 1:2) = x20ac
   xac(7, 1:2) = x24ac
   xac(8, 1:2) = x28ac
   xac(9, 1:2) = x56ac

   ! Backup core mass for star 1
   mc1 = mc(1)

   ! Get central properties of the star
   qe = 0.0d0              ! Modified mesh spacing function
   mc(jstar) = tm          ! Initialise core mass (it needs to have a non-zero value)
   var(:) = h(:, kh)
   dvar(:) = 0.0d0
   call funcs1 ( kh, -2, var(:), dvar(:), fn1(:), eos, px=sx(:, 2))
   hpc = sqrt(eos%p/(cg*eos%rho*eos%rho))
   mc(jstar) = 3.5d-33*eos%rho*hpc**3

   ! Scale the mass of the star
   vd = tm/h(VAR_MASS, 1)
   h(VAR_MASS, 1:kh) = vd*h(VAR_MASS, 1:kh)

   h(VAR_QK, 1:kh) = 1.0d0                            ! Gradient of mesh spacing
   if ( iand(jf, 2) /= 2 ) h(VAR_INERT, 1:kh) = 1.0d0 ! Moment of Inertia (later)
   if ( iand(jf, 2) /= 2 ) h(VAR_PHI, 1:kh)   = 1.0d0 ! Potential
   !H(13, 1:KH) = P1                                  ! New rotation period
   h(VAR_HORB, 1:kh) = oa                             ! New orbital angular momentum
   h(VAR_ECC, 1:kh) = ecc                             ! New eccentricity
   h(VAR_BMASS, 1:kh) = bms                           ! New total binary mass

   !     Rotation rate/rotational frequency
   h(VAR_OMEGA, 1:kh) = 2.0*cpi/(p1 * csday)
   dh(VAR_OMEGA, 1:kh) = -2.0*cpi/(p1**2 * csday) * dh(VAR_OMEGA, 1:kh)

   !     AGB MSF terms
   if (ct(11) == 0.0d0) ct(11) = 0.1d0*eos%p
   if (ct(13) == 0.0d0) ct(13) = 3.0d19
   if (ct(15) == 0.0d0) ct(15) = 0.3d19

   ! Set core mass as core mass for star 1.
   ! This is a bit of a hack that is needed because funcs1 will always think that the current star is star 1
   mc(1) = mc(jstar)

   ex_max = eos%ex
   do ik = 1, kh
      ikk = kh + 2 - ik
      var(:) = h(:, ik)
      call funcs1 ( ik, -2, var(:), dvar(:), fn1(:), eos, px=sx(:,ikk)) ! Calculate stuff
      qq = sx(85, ikk)
      qm = sx(86, ikk)
      phim = sx(87, ikk)
      m3 = sx(89, ikk)
      qa(ik) = qq                            ! Store mesh spacing function
      r   = sqrt(abs(exp(2.0d0*var(7)) - ct(8)))
      ! Preliminary integration for M.I. and potential
      if ( .not. ( ik == 1 .or. iand(jf, 2)==2 ) ) then
         h(VAR_PHI,   ik) = h(VAR_PHI,   ik - 1) + phim/abs(qm)
      end if
      ex_max = max(eos%ex, 0.0d0)
      ! Integration for L-dependent mesh spacing.
      !qe = qe + ct(2)*eos%ex*ht(4, ik)*1.0d-8
      !qa(ik) = qa(ik) + qe                   ! update meshspacing
   end do

   ! Store gravitational potential
   gmr = sx(88, kh+1)

   ! Restore core mass of star 1 if this was really star 2 */
   if (jstar == 2) mc(1) = mc1

   ! Scale factor in number of meshpoints
   nmf = real(kh2 / kh)

   ! Find values of mesh spacing function at the external points
   ! Needed to calculate the new mesh, where the meshspacing gradient is
   ! constant.
   qk = (qa(kh) - qa(1)) / (kh - 1.0d0)
   if ( jch >= 3 ) then
      ! Normalise mesh spacing function
      q1 = qa(1)
      qa(1) = 1.0d0
      do ik = 2, kh
         qa(ik) = (qa(ik) - q1) + 1.0d0
      end do
      q2 = qa(kh)

      ! Create interpolation splines for all variables
      do i = 1, NVSTAR+NVBIN
         call make_interpolation_table(kh, qa(1:kh), h(i, 1:kh), interpol_h(i))
         call make_interpolation_table(kh, qa(1:kh), dh(i, 1:kh), interpol_dh(i))
      end do
      if (nucleosynthesis_enabled) then
         do i = 1, 50
            call make_interpolation_table(kh, qa(1:kh), hnuc(Jstar, i, 1:kh), interpol_hnuc(i))
         end do
      end if
      ! Safe the centre and surface properties (these should not be affected by remeshing)
      vars(:) = h(:, 1)
      varc(:) = h(:, kh)

      ! Calculate new mesh spacing function
      qa(1) = 1.0d0
      qa(kh2) = q2
      qk = qk * (kh - 1.0d0) / (kh2 - 1.0d0)
      kh = kh2
      do ik = 2, kh-1
         qa(ik) = qa(ik-1) + qk
      end do

      ! Calculate stellar properties for the new mesh
      do ik = 1, kh
         do i = 1, NVSTAR+NVBIN
            h(i, ik) = evaluate_interpolation_table(qa(ik), interpol_h(i))
            dh(i, ik) = evaluate_interpolation_table(qa(ik), interpol_dh(i))
         end do
         if (nucleosynthesis_enabled) then
            do i = 1, 50
               hnuc(Jstar, i, ik) = evaluate_interpolation_table(qa(ik), interpol_hnuc(i))
            end do
         end if
      end do
      ! Restore centre and surface properties
      h(:, 1) = vars(:)
      h(:, kh) = varc(:)
   end if

   ! Some new variables that may not have been read in from stored model
   h(VAR_QK, 1:kh) = qk                                                    ! Gradient of mesh spacing
   if ( iand(jf, 2)/=2 ) then
      h(VAR_PHIS,  1:kh) = -gmr                                            ! Potential at the stellar surface
      forall (ik = 1:kh) h(VAR_PHI,   ik) = -gmr - h(VAR_PHI, ik)*abs(qk)*nmf  ! Gravitational potential

      ! Integrate moment of inertia, the straightforward way
      h(VAR_INERT, kh) = 0.0d0
      do ik = kh-1, 1, -1
         var(:) = h(:, ik)
         call funcs1 ( ik, -2, var(:), dvar(:), fn1(:), eos, px=sx(:,ikk))
         h(VAR_INERT, ik) = h(VAR_INERT, ik + 1) - fn1(fn_vik)
      end do
   end if

   h(VAR_TAM, 1:kh) = h(VAR_INERT, 1:kh)*h(VAR_OMEGA, 1)
   h(VAR_PMASS, 1:kh) = h(VAR_MASS, 1)

end subroutine remesh


subroutine updbcc(lunbcc    ,lundia    ,first     ,itbcc     ,ito       , &
                & istsc     ,timnow    ,itfinish  ,timscl    , &
                & nto       ,kmax      ,lstsc     ,procbc    ,tprofc    , &
                & zstep     ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: updbcc.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/timedep/updbcc.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Reads the time dependent constituent BC from file
!              (if flbcc = TRUE / LSTSC > 0)
! Method used: - Time dependent value is read and   stored in
!                array PROCBC (K,N,L).
!              - The first time (FIRST = TRUE) data are read for
!                K=1--4. In the following times data are read for
!                K=5--8.
!              - Subsequently time increment values are calcula-
!                ted and restored in PROCBC (K,N,L) with K=5--8
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    real(fp) , pointer :: scalef
    real(fp) , pointer :: tstop
    real(fp) , pointer :: dt
    real(fp) , pointer :: tunit
!
! Global variables
!
    integer                             , intent(in)  :: istsc    !!  Index number of constituent
    integer                             , intent(in)  :: ito      !!  Index number of open boundary loc.
    integer                             , intent(in)  :: itfinish !  Description and declaration in inttim.igs
    integer                             , intent(in)  :: kmax     !  Description and declaration in esm_alloc_int.f90
    integer                             , intent(in)  :: lstsc    !  Description and declaration in dimens.igs
    integer                             , intent(in)  :: lunbcc   !  Description and declaration in luntmp.igs
    integer                                           :: lundia   !  Description and declaration in inout.igs
    integer                             , intent(in)  :: nto      !  Description and declaration in esm_alloc_int.f90
    integer, dimension(5, nto, lstsc)                 :: itbcc    !  Description and declaration in esm_alloc_int.f90
    logical                                           :: first    !!  Flag = TRUE in case a time-dependent
                                                                  !!  file is read for the 1-st time
    real(fp)                            , intent(in)  :: timnow   !!  Current timestep (multiples of dt)
    real(fp)                            , intent(in)  :: timscl   !!  Multiple factor to create minutes
                                                                  !!  from read times
    real(fp), dimension(2, nto, lstsc)                :: zstep    !  Description and declaration in esm_alloc_real.f90
    real(fp), dimension(4, nto, kmax, lstsc)          :: procbc   !  Description and declaration in esm_alloc_real.f90
    character(10), dimension(nto, lstsc), intent(in)  :: tprofc   !  Description and declaration in esm_alloc_char.f90
!
! Local variables
!
    integer       :: iocond ! Flag for reading errors = 0 No error < 0 End-Of-File reached > 0 Reading error
    integer       :: ittime ! Help variable containing timestep number RTBCC * SCALEF / SDT
    integer       :: k      ! Loop counter over KMAX
    integer       :: nread  ! Number of boundary values to read depending on TPROFC
    logical       :: last
    real(fp)      :: rinc   ! Increment values at each timestep for the open boundary conditions
    real(fp)      :: rtbcc  ! Time read from the open boundary file (multiples of sdt)
    real(fp)      :: rttime ! Help variable containing time RTBCC * SCALEF
    real(fp)      :: sdt    ! dt*tunit/60
    real(fp)      :: tlread ! Last time read from file (in minutes)
    character(16) :: fmtbcc
    character(20) :: errmsg ! String containing error message
!
!! executable statements -------------------------------------------------------
!
    scalef  => gdp%gdupdbcc%scalef
    tstop   => gdp%gdexttim%tstop
    dt      => gdp%gdexttim%dt
    tunit   => gdp%gdexttim%tunit
    !
    !
    ! function definition
    !     DISABLED FOR DD
    !
    !      dtn (it,t ,dt)= abs (it * dt - t) .gt. (0.1 * dt)
    !
    ! Initialization local parameters
    !
    sdt  = dt*(tunit/60.0)
    last = .false.
    if (first) scalef = timscl
    !
    ! Define reading format
    ! Time is read with format F12.4 rest with G14.6
    !
    fmtbcc = '(f16.4,...g14.6)'
    if (tprofc(ito, istsc)(:7)=='uniform') then
       nread = 2
    elseif (tprofc(ito, istsc)(:6)=='linear') then
       nread = 4
    elseif (tprofc(ito, istsc)(:4)=='step') then
       nread = 5
    else
       nread = 2*kmax
    endif
    write (fmtbcc(8:10), '(i3.3)') nread
    !
    ! Read amplitudes at end A and B for the consecutive times
    ! as long as time read < time now
    ! Note: The process input will always be interpolated between two
    !       consecutive times. For the profile and depth (in M) the
    !       latest read values will be used !!
    !
    !==>
   10 continue
    itbcc(5, ito, istsc) = itbcc(5, ito, istsc) + 1
    !
    ! End of file and not yet end of computation
    !
    if (itbcc(5, ito, istsc)>itbcc(4, ito, istsc)) then
       last = .true.
       itbcc(5, ito, istsc) = itbcc(4, ito, istsc)
       errmsg = 'open bound = '
       write (errmsg(14:16), '(i3)') ito
       call prterr(lundia    ,'V098'    ,errmsg(:16)          )
    !
    endif
    !
    ! When End-Of-File or error occurs for reading TMP_bcc file:
    ! stop program. In the future the program should be able
    ! to go on and using latest read value as end value
    !
    if (first) then
       tlread = real(itbcc(1, ito, istsc),fp)*sdt/scalef
    else
       tlread = real(itbcc(2, ito, istsc),fp)*sdt/scalef
    endif
    !
    ! Read boundary values depending on value of TPROFC
    !
    if (tprofc(ito, istsc)(:7)=='uniform') then
       read (lunbcc, fmtbcc, rec = itbcc(5, ito, istsc), iostat = iocond) &
          & rtbcc, procbc (3, ito, 1, istsc) , procbc (4, ito, 1, istsc)
    elseif (tprofc(ito, istsc)(:6)=='linear') then
       read (lunbcc, fmtbcc, rec = itbcc(5, ito, istsc), iostat = iocond) &
          & rtbcc, procbc (3, ito, 1, istsc) , procbc (3, ito, kmax, istsc) , procbc  &
          & (4, ito, 1, istsc) , procbc (4, ito, kmax, istsc)
    elseif (tprofc(ito, istsc)(:4)=='step') then
       read (lunbcc, fmtbcc, rec = itbcc(5, ito, istsc), iostat = iocond) &
          & rtbcc, procbc (3, ito, 1, istsc) , procbc (3, ito, kmax, istsc) , procbc  &
          & (4, ito, 1, istsc) , procbc (4, ito, kmax, istsc) , zstep (2, ito, istsc)
    else
       read (lunbcc, fmtbcc, rec = itbcc(5, ito, istsc), iostat = iocond) &
          & rtbcc, ( procbc (3, ito, k, istsc) , k = 1, kmax), ( procbc (4, ito,  &
          & k, istsc) , k = 1, kmax)
    endif
    if (iocond/=0) call eoferr('bcc', lundia, iocond, tlread, gdp)
    !
    ! Test read time RTBCC as multiple of SDT (/ SCALEF)
    !
    rttime = real(rtbcc*scalef,fp)
    ittime = nint(rttime/sdt)
    if (abs(ittime*sdt - rttime)>(0.1*sdt)) then
       write (errmsg, '(a,f10.4)') 'Timbcc = ', rtbcc
       call prterr(lundia    ,'S044'    ,errmsg    )
    endif
    !
    ! Define Time as multiple of SDT, where RTBCC is in SCALEF minutes
    !
    rtbcc = real(nint(rtbcc*scalef/sdt),fp)
    !
    ! Redefine time if LAST = .true.
    ! TIMNOW is per definition < ITFINISH
    !
    if (last) rtbcc = real(itfinish,fp)
    !
    ! Test if ITBCT (1,ITO) or ITBCT (2,ITO) part
    ! should be executed
    !
    if (rtbcc>timnow) first = .false.
    !
    if (first) then
       !
       ! Define time step for ITBCC (1,ITO,ISTSC)
       !
       itbcc(1, ito, istsc) = nint(rtbcc)
       !
       ! Copy open boundary values read to "partner" array
       !
       zstep(1, ito, istsc) = zstep(2, ito, istsc)
       do k = 1, kmax
          procbc(1, ito, k, istsc) = procbc(3, ito, k, istsc)
          procbc(2, ito, k, istsc) = procbc(4, ito, k, istsc)
       enddo
       !
       ! Read new time step
       !
       goto 10
    !<==
    else
       !
       ! Define time step for ITBCC (2,ITO,ISTSC)
       !
       itbcc(2, ito, istsc) = nint(rtbcc)
       !
       ! Calculate increment with linear interpolation
       !
       rinc = (itbcc(2, ito, istsc) - itbcc(1, ito, istsc))*2.0
       do k = 1, kmax
          procbc(3, ito, k, istsc) = (procbc(3, ito, k, istsc) - procbc(1, ito, &
                                   & k, istsc))/rinc
          procbc(4, ito, k, istsc) = (procbc(4, ito, k, istsc) - procbc(2, ito, &
                                   & k, istsc))/rinc
       enddo
    endif
end subroutine updbcc