      PROGRAM INSERT
      PARAMETER (NLYRS1=38,NLYRS2=50,NBLCKS=3,NSTND=14)
      PARAMETER (NINTFC=NLYRS2+1,NLM1=NLYRS2-1,NLM2=NLYRS2-2)
C     PARAMETER (NLDBL2=2*NLYRS2,NIDBL=2*NINTFC)
      REAL DETX(NLYRS1),DETNEW(25),DETA(NLYRS2),DETH(NLYRS2)
      REAL EINTFC(NINTFC),AETA(NLYRS2),STNDPR(NSTND)
C     REAL AETDBL(NLDBL2),EINDBL(NIDBL)
      REAL DRAW1(NINTFC)
      INTEGER LSTRT(NBLCKS),LEND(NBLCKS),NEWL(NBLCKS),LDT1(NLYRS2)
      DATA LSTRT/7,10,21/,LEND/9,20,33/,NEWL/2,3,7/
      DATA PTOP/25./,PTROP/250./,NPASS/6/
      DATA STNDPR/20.,30.,50.,70.,100.,150.,200.,250.,300.,400.
     1,           500.,700.,850.,1000./
      DATA DETA/NLYRS2*0./
C----------------------------------------------------------------------
C***
C***  THIS PROGRAM WILL INSERT ADDITIONAL LAYERS INTO A GIVEN
C***  INPUT DISTRIBUTION OF LAYERS.  NBLCKS IS THE NUMBER OF BLOCKS
C***  OF INSERTIONS THAT WILL BE MADE.  LSTRT HOLDS THE LAYER 
C***  INDICES OF THE TOP OF EACH INSERTION BLOCK WHILE LEND HOLDS
C***  THE LAYER INDICES OF THE BOTTOM OF EACH BLOCK BASED UPON THE
C***  INPUT DISTRIBUTION OF LAYERS.  NEWL HOLDS THE NUMBER OF NEW 
C***  LAYERS THAT WILL BE INSERTED INTO EACH BLOCK.
C***
C----------------------------------------------------------------------
C***
C***  READ IN THE ORIGINAL DETA DISTRIBUTION.
C***
      REWIND 12
      DO 25 L=1,NLYRS1
      READ(12,15)DETX(L)
   15 FORMAT(E13.6)
   25 CONTINUE
      DO 30 L=1,NLYRS1
      DETA(L)=DETX(L)
   30 CONTINUE
C----------------------------------------------------------------------
      LADD=0
      DO 200 NB=1,NBLCKS
C***
C***  CLEAVE AWAY FROM EACH ORIGINAL LAYER WITHIN A BLOCK
C***  A FRACTION OF ITS DEPTH EQUAL TO THE RATIO OF THE NUMBER OF
C***  NEW LAYERS OVER THE TOTAL NUMBER OF LAYERS IN THE FINAL
C***  BLOCK.  SUM THESE AMOUNTS.
C***
      NNB=NEWL(NB)
      CLEAVE=REAL(NNB)/REAL(LEND(NB)-LSTRT(NB)+1+NNB)
C     WRITE(6,54321)CLEAVE
54321 FORMAT(' CLEAVE=',E12.5)
C     WRITE(6,54322)NB,NNB,LEND(NB),LSTRT(NB)
54322 FORMAT(' NB=',I2,' NNB=',I2,' LEND=',I2,' LSTRT=',I2)
      L1=LSTRT(NB)
      L2=LEND(NB)
      SUMC=0.
      DO 50 L=L1,L2
      SUMC=SUMC+CLEAVE*DETX(L)
      DETX(L)=(1.-CLEAVE)*DETX(L)
      DETA(L+LADD)=DETX(L)
   50 CONTINUE
C***
C***  CREATE THE NEW LAYERS FROM THIS SUMC.  SO THAT THEY WILL 'FIT'
C***  MORE CLEANLY WITH WHAT REMAINS OF THE ORIGINAL LAYERS
C***  WITHIN THE BLOCK, MAKE FIRST-GUESS NEW LAYERS THAT WILL HAVE
C***  DEPTHS THAT VARY LINEARLY BETWEEN THE THINNEST AND THE
C***  THICKEST OF THE REDUCED ORIGINAL LAYERS.
C***
      THICK=0.
      THIN=1.
      DO 75 L=L1,L2
      IF(DETX(L).GT.THICK)THICK=DETX(L)
      IF(DETX(L).LT.THIN)THIN=DETX(L)
   75 CONTINUE
      DEL=(THICK-THIN)/(1.+NNB)
      DETNEW(1)=THIN+DEL
      SUMD=DETNEW(1)
      DO 100 L=2,NNB
      DETNEW(L)=DETNEW(L-1)+DEL
      SUMD=SUMD+DETNEW(L)
  100 CONTINUE
C***
C***  AT THIS POINT, THE NEWLY FORMED LAYERS (DETNEW) DO NOT
C***  IN GENERAL ADD TO THE CLEAVED SUMC SO THE DIVISION OF 
C***  SUMC WILL BE MADE INTO PIECES PROPORTIONAL TO THE SIZES
C***  OF THESE FIRST GUESS VALUES.
C***
      FRAC=SUMC/SUMD
C     WRITE(6,12345)SUMC,SUMD
12345 FORMAT(' SUMC=',E12.5,' SUMD=',E12.5)
      DO 125 L=1,NNB
      DETNEW(L)=FRAC*DETNEW(L)
  125 CONTINUE
      DO 130 L=L1,L2
C     WRITE(6,128)L,DETX(L)
  128 FORMAT('         L=',I2,' DETX=',E12.5)
  130 CONTINUE
      DO 135 L=1,NNB
C     WRITE(6,133)L,DETNEW(L)
  133 FORMAT('      L=',I2,' DETNEW=',E12.5)
  135 CONTINUE
C***
C***  INSERT THE NEW LAYERS.
C***
      DO 30001 L=1,NLYRS2
C      WRITE(6,30000)L,DETA(L)
30000 FORMAT(' BEFORE L=',I2,' DETA=',E12.5)
30001 CONTINUE
      LL1=LSTRT(NB)+LADD
      LL2=LEND(NB)+LADD-1
      KNT=0
      DO 150 L=1,NNB
C     WRITE(6,29011)L,LL1,LL2
29011 FORMAT(' L=',I2,' LL1=',I2,' LL2=',I2)
      DO 145 LL=LL1,LL2
C     WRITE(6,29012)LL,DETA(LL),DETA(LL+1),DETNEW(L)
29012 FORMAT(' LL=',I2,' DETA(0)=',E12.5,' DETA(+)=',E12.5,
     1       ' DETNEW=',E12.5)
      IF(ABS(DETNEW(L)-DETA(LL)).LT.ABS(DETA(LL)-DETA(LL+1)))THEN
        KNT=KNT+1
        LX=NLYRS1+LADD+KNT
        LLP2=LL+2
        DO 140 L0=LX,LLP2,-1
        DETA(L0)=DETA(L0-1)
  140   CONTINUE
        DETA(LL+1)=DETNEW(L)
        LL2=LL2+1
        GO TO 150
      ENDIF
  145 CONTINUE
      WRITE(6,27221)
27221 FORMAT(' DID NOT INSERT LAYER')
  150 CONTINUE
      DO 30011 L=1,NLYRS2
C     WRITE(6,30010)L,DETA(L)
30010 FORMAT(' AFTER L=',I2,' DETA=',E12.5)
30011 CONTINUE
      LADD=LADD+NNB
  200 CONTINUE
C***
C***  NOW SMOOTH ALL OF THE LAYERS.
C***
      DO 225 L=1,NLYRS2
      DETH(L)=DETA(L)
  225 CONTINUE
C     DETA(1)=DETH(1)
C     DETA(NLYRS2)=DETH(NLYRS2)
      DO 300 N=1,NPASS
      DETA(1)=0.75*DETH(1)+0.25*DETH(2)
      DETA(NLYRS2)=0.75*DETH(NLYRS2)+0.25*DETH(NLM1)
C     DETA(2)=0.75*DETH(2)+0.25*DETH(3)
C     DETA(NLM1)=0.25*DETH(NLM1-1)+0.75*DETH(NLM1)
C     SUM=DETA(1)+DETA(2)+DETA(NLM1)+DETA(NLYRS2)
      SUM=DETA(1)+DETA(NLYRS2)
      DO 250 L=2,NLM1
      DETA(L)=0.25*DETH(L-1)+0.50*DETH(L)+0.25*DETH(L+1)
      SUM=SUM+DETA(L)
  250 CONTINUE

CROZANTE   esses valores fixos foram colocados para ficar com
C          mesmos valores do modelo 38 camadas
      DETA(50)=.0024285895
C      DETA(50)=0.0021285896
      DETA(49)=.0045229
C      DETA(48)=0.509770E-02
C      DETA(47)=0.753971E-02
C      DETA(46)=0.8810E-02
C      DETA(1) =.028346959353367
CROZANTE

      DO 260 L=1,NLYRS2
      DETH(L)=DETA(L)
  260 CONTINUE
C     WRITE(6,275)SUM
  275 FORMAT(' SUM2=',E12.5)
  300 CONTINUE
C     DETA(NLM1)=DETA(NLM1)+(DETA(NLYRS2)-0.00244094)
C     DETA(NLYRS2)=0.00244094
C
      DETAMH=0.
      PRES=PTOP
      PD=1013.25-PTOP
      NSTND2=NSTND-2
      NN=1
      DO 350 N=1,NLYRS2
      DETAH=0.5*DETA(N)
      PRES=PRES+(DETAMH+DETAH)*PD
      DETAMH=DETAH
      DIF1=ABS(PRES-STNDPR(NN))
      NN1=MIN(NN+1,NSTND)
      DIF2=ABS(PRES-STNDPR(NN1))
      IF(DIF1.LT.DIF2)THEN
        LDT1(N)=MAX(NN-1,1)
      ELSE
        LDT1(N)=MIN(NN,NSTND2)
        IF(NN.LT.NSTND)NN=NN+1
      ENDIF
  350 CONTINUE
      DO 400 L=1,NINTFC
      IF(L.EQ.1)THEN
        EINTFC(L)=0.
C       DRAW1(L)=19.
        GO TO 400
      ELSE
        EINTFC(L)=EINTFC(L-1)+DETA(L-1)
C       DRAW1(L)=DRAW1(L-1)-DETA(L-1)*19.
  390   FORMAT(' LLL=',I2,' DRAW1=',E12.5)
      ENDIF
  400 CONTINUE

      DO 455 L=51,1,-1
       WRITE(6,*) EINTFC(L),','
  355   FORMAT(1f5.4,a1)
  455 CONTINUE
      DO 500 N=1,NINTFC
      NI=N-1
      IF(N.EQ.1)THEN
        WRITE(6,450)NI,EINTFC(N)
  450   FORMAT(' INTFC=',I3,'  ETA=',E13.6)
      ELSE
        AETA(NI)=EINTFC(N-1)+0.5*DETA(N-1)
        WRITE(6,460)NI,EINTFC(N),DETA(N-1),AETA(NI),LDT1(N-1)
  460   FORMAT(' INTFC=',I3,'  ETA=',E13.6,'  DETA=',E13.6,
     1         '  AETA=',E13.6,' LDT1=',I2)
      ENDIF
  500 CONTINUE

      PRS=PTOP
      DO 610 N=1,NLYRS2
      DPRS=PD*DETA(N)
      PRS=PRS+DPRS
      WRITE(6,605)N,DPRS,PRS
      write(67,*)PRS,EINTFC(N),N
  605 FORMAT(' N=',I3,' DELPRS=',E13.6,' PRS=',E12.5)
  610 CONTINUE
C     DO 700 L=1,NINTFC
C     DOTS=6.*(DRAW1(L)-AINT(DRAW1(L)))
C     DRAW1(L)=AINT(DRAW1(L))
C     WRITE(6,695)L,DRAW1(L),DOTS
  695 FORMAT(' L=',I2,' INT=',F3.0,' DOTS=',F4.2)
  700 CONTINUE
C***
C***  FOR SOME REASON, THE FRONT-END CODE READS ONLY EVERY
C***  OTHER WORD FROM THE MIDLAYER AND INTERFACE ARRAYS, SO
C***  BEFORE WRITING THEM OUT, REPEAT EACH WORD.
C***  WRITE MIDLAYER AND INTERFACE ETA VALUES FOR CO2 ROUTINES
C***
C***  THIS LOGIC NOT NEEDED FOR CRAY VERSION OF CO2 ROUTINES
C***
c     DO 750 N=1,NLYRS2
c     NN=2*N-1
c     AETDBL(NN)=AETA(N)
c     AETDBL(NN+1)=AETA(N)
c 750 CONTINUE
c     DO 760 N=1,NINTFC
c     NN=2*N-1
c     EINDBL(NN)=EINTFC(N)
c 760 CONTINUE

      WRITE(23)(AETA(N),N=NLYRS2,1,-1)
      WRITE(23)(EINTFC(N),N=NINTFC,1,-1)
      WRITE(24)DETA,LDT1
      WRITE(34)DETA,LDT1 
      do i=1,NLYRS2
        write(89,*)DETA(i),i
      end do
      do i=1,51
        write(87,*)(EINTFC(i)*(1013.25-25))+25,EINTFC(i),i
      end do

      STOP
      END
