C     LAST UPDATE 05/07/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      PROGRAM FD2BSL
      IMPLICIT NONE
C
C Purpose: Convert CCP13 intensity output files to BSL format with one
C          raster per layerline.
C
C Calls   4: RDCOMF , RECCEL , DCAL , CURV1
C Called by:
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
       INTEGER NLLPX
       PARAMETER(NLLPX=4096)
C
C Local arrays:
C
       REAL VALS(10),RINT(NLLPX),SIG(NLLPX),
     &      RL(2,NLLPX),CELL(6),X(512),Y(512),Y2(512),
     &      RCELL(6),D(NLLPX),BUF(1024*1024),WRK(512)
       INTEGER ITEM(20),HKM(3,NLLPX)
       CHARACTER*40 WORD(10)
C
C Local variables:
C
       REAL RESMIN,RESLIM,DMAX,DR,SIGO,XR,RMIN,RMAX,RINC,RLIM1,RLIM2,TEN
       INTEGER NW,NV,IRC,IREF,I,J,M,L,LMIN,LMAX,KLO,KHI
       INTEGER IFRAME,NPIX,NRAST,KPIC,KUNIT,IMEM
       LOGICAL NEXT,BRAG,CONT,FEX,SIGMA
       CHARACTER*80 HEAD1,HEAD2
       CHARACTER*40 OFNAM,INFIL
C
C External functions:
C
       REAL DCAL,CURV2
       EXTERNAL DCAL,CURV2
C
       DATA IFRAME /1/, KPIC /1/, KUNIT /12/, IMEM /1/ , TEN /1.0/
C-----------------------------------------------------------------------
C
C========Open log file
C
      OPEN(UNIT=4,FILE='FD2BSL.LOG',STATUS='UNKNOWN')
      WRITE(6,1000)
      WRITE(4,1000)
C
C========Set up defaults
C
      NEXT = .TRUE.
      RESLIM = 0.0
      RESMIN = 0.0
      DMAX = 0.0
      SIGO = 1.5
      SIGMA = .FALSE.
      LMIN = 0
      LMAX = 0
      NPIX = 128
      NRAST = 0
      RMIN = 1.0
      RMAX = -1.0
      RLIM1 = 0.0
      RLIM2 = 0.0
C
C=======Read keyworded input
C
 10   WRITE(6,'(A8,$)')'FD2BSL> '
      CALL RDCOMF(5,WORD,NW,VALS,NV,ITEM,10,10,40,IRC)
      IF(IRC.EQ.2)GOTO 10
      IF(IRC.EQ.1)GOTO 9999
      CALL WRTLOG(4,WORD,NW,VALS,NV,ITEM,10,10,IRC)
      DO 20 I=1,NW
         CALL UPPER(WORD(I),40)
 20   CONTINUE
      IF(ITEM(1).EQ.0)GOTO 10
      IF(ITEM(1).NE.2)THEN
         WRITE(6,1010)
         WRITE(4,1010)
         GOTO 10
      ENDIF
C
      IF(WORD(1)(1:3).EQ.'RUN')THEN
         NEXT = .FALSE.
      ELSEIF(WORD(1)(1:4).EQ.'FILE')THEN
C
C========Read input filename
C
         WRITE(6,1030)
         WRITE(4,1030)
         READ(5,'(A)',END=9999)INFIL
         WRITE(4,'(A)')INFIL
         INQUIRE(FILE=INFIL,EXIST=FEX)
         IF(.NOT.FEX)THEN
            WRITE(6,1036)INFIL
            WRITE(4,1036)INFIL
            GOTO 10
         ENDIF
      ELSEIF(WORD(1)(1:4).EQ.'PIXE')THEN
         IF(ITEM(2).NE.1)THEN
            WRITE(6,1020)
            WRITE(4,1020)
         ELSE
            NPIX = NINT(VALS(1))
         ENDIF
         IF(WORD(2)(1:4).EQ.'RAST')THEN
            IF(ITEM(4).NE.1)THEN
               WRITE(6,1020)
               WRITE(4,1020)
            ELSE
               NRAST = NINT(VALS(2))
            ENDIF
         ENDIF
      ELSEIF(WORD(1)(1:4).EQ.'RAST')THEN
         IF(ITEM(2).NE.1)THEN
            WRITE(6,1020)
            WRITE(4,1020)
         ELSE
            NRAST = NINT(VALS(1))
         ENDIF
         IF(WORD(2)(1:4).EQ.'PIXE')THEN
            IF(ITEM(4).NE.1)THEN
               WRITE(6,1020)
               WRITE(4,1020)
            ELSE
               NPIX = NINT(VALS(2))
            ENDIF
         ENDIF
      ELSEIF(WORD(1)(1:4).EQ.'RESO')THEN
         IF(ITEM(2).NE.1)THEN
            WRITE(6,1020)
            WRITE(4,1020)
         ELSE
            RESMIN = VALS(1)
            RESLIM = VALS(2)
         ENDIF
      ELSEIF(WORD(1)(1:4).EQ.'SIGM')THEN
         IF(ITEM(2).NE.1)THEN
            WRITE(6,1020)
            WRITE(4,1020)
         ELSE
            SIGO = VALS(1)
         ENDIF
      ELSEIF(WORD(1)(1:3).EQ.'ESD')THEN
         SIGMA = .TRUE.
      ELSEIF(WORD(1)(1:4).EQ.'LIMI')THEN
         IF(ITEM(2).NE.1)THEN
            WRITE(6,1020)
            WRITE(4,1020)
         ELSE
            IF(NV.GE.1)RLIM1 = VALS(1)
            IF(NV.GE.2)RLIM2 = VALS(2)
         ENDIF
      ELSE
         WRITE(6,1025)
         WRITE(4,1025)
      ENDIF
C
      IF(NEXT)GOTO 10
C
C========Open input file to determine Bragg/continuous etc
C
      IREF = 0
      OPEN(UNIT=10,FILE=INFIL,STATUS='OLD',IOSTAT=IRC)
      IF(IRC.NE.0)THEN
         WRITE(6,1045)
         WRITE(4,1045)
         GOTO 9999
      ENDIF
 30   CALL RDCOM(10,0,WORD,NW,VALS,NV,ITEM,0,IRC)
      IF(IRC.EQ.2)THEN
         WRITE(6,1050)
         WRITE(4,1050)
      ELSEIF(IRC.EQ.1)THEN
         GOTO 45
      ENDIF
      IF(ITEM(1).EQ.2)THEN
         IF(WORD(1)(1:4).EQ.'BRAG')THEN
            BRAG = .TRUE.
            CONT = .FALSE.
         ELSEIF(WORD(1)(1:4).EQ.'CONT')THEN
            CONT = .TRUE.
            BRAG = .FALSE.
         ELSEIF(WORD(1)(1:4).EQ.'CELL')THEN
            DO 40 J=1,NV
               CELL(J) = VALS(J)
               IF(J.GT.3)CELL(J) = CELL(J)*ATAN(1.0)/45.0
 40         CONTINUE
         ELSEIF(WORD(1)(1:4).EQ.'DELT')THEN
            DR = VALS(1)
         ENDIF
      ELSEIF(ITEM(1).EQ.1)THEN
         IF(IREF.EQ.0.AND.BRAG)CALL RECCEL(CELL,RCELL)
         IREF = IREF + 1
         IF(IREF.GT.NLLPX)THEN
            WRITE(6,1055)NLLPX
            WRITE(4,1055)NLLPX
            GOTO 45
         ENDIF
         HKM(1,IREF) = NINT(VALS(1))
         HKM(2,IREF) = NINT(VALS(2))
         RL(2,IREF) = VALS(3)
         RL(1,IREF) = VALS(4)
         HKM(3,IREF) = NINT(VALS(5))
         RINT(IREF) = VALS(6)
         SIG(IREF) = VALS(7)
         IF(BRAG)THEN
            D(IREF) = DCAL(RCELL,HKM(1,IREF),HKM(2,IREF),
     &                NINT(RL(2,IREF)))
         ELSEIF(CONT)THEN
            D(IREF) = SQRT((RL(2,IREF)/CELL(1))**2
     &                      +RL(1,IREF)**2)
         ENDIF
         IF(D(IREF).GT.DMAX)DMAX = D(IREF)
         IF(NINT(RL(2,IREF)).LT.LMIN)LMIN = NINT(RL(2,IREF))
         IF(NINT(RL(2,IREF)).GT.LMAX)LMAX = NINT(RL(2,IREF))
         IF(RL(1,IREF).LT.RMIN)RMIN = RL(1,IREF)
         IF(RL(1,IREF).GT.RMAX)RMAX = RL(1,IREF)
      ENDIF
      GOTO 30
 45   WRITE(6,1060)IREF
      WRITE(4,1060)IREF
      CLOSE(10)
      WRITE(6,1070)DMAX
      WRITE(4,1070)DMAX
      IF(RESLIM.EQ.0.0)RESLIM = DMAX
      IF(RMAX.GT.RESLIM)RMAX = RESLIM
      IF(NRAST.GT.0.AND.LMAX-LMIN+1.GT.NRAST)LMAX = LMIN + NRAST - 1
      IF(RLIM2.EQ.0.0)RLIM2 = RMAX
      RINC = (RLIM2-RLIM1)/FLOAT(NPIX-1)
      DO 70 L=LMIN,LMAX
         J = 0
         DO 50 I=1,IREF
            IF(NINT(RL(2,I)).EQ.L)THEN
               IF(SIG(I).GT.0.0.AND.RINT(I).GT.0.0)THEN
                  IF(RINT(I)/SIG(I).GT.SIGO.AND.
     &               D(I).LT.RESLIM.AND.D(I).GT.RESMIN)THEN
                     J = J + 1
                     X(J) = RL(1,I)
                     IF(SIGMA)THEN
                        Y(J) = SQRT(SIG(I)**2/HKM(3,I))
                     ELSE
                        Y(J) = RINT(I)/FLOAT(HKM(3,I))
                     ENDIF
                  ENDIF
               ENDIF
            ENDIF
 50      CONTINUE
         CALL CURV1(J,X,Y,0.0,0.0,3,Y2,WRK,TEN,IRC)
c         CALL SPLINE(X,Y,J,1.0E30,1.0E30,Y2)
         KLO = 1
         KHI = J
         DO 60 I=1,NPIX
            XR = FLOAT(I-1)*RINC + RLIM1
            M = (L-LMIN)*NPIX + I
            IF(XR.LT.X(1).OR.XR.GT.X(J))THEN
               BUF(M) = 0.0
            ELSE
               BUF(M) = CURV2(XR,J,X,Y,Y2,TEN)
c               CALL SPLINT(X,Y,Y2,J,XR,BUF(M),KLO,KHI)
c               IF(BUF(M).LT.0.0)THEN
c                  BUF(M) = ((XR-X(KLO))*Y(KLO)+(X(KHI)-XR)*Y(KHI))/
c     &                     (X(KHI)-X(KLO))
c               ENDIF
            ENDIF
 60      CONTINUE
 70   CONTINUE
      IF(NRAST.EQ.0)NRAST = LMAX - LMIN + 1
      CALL OUTFIL(5,6,OFNAM,HEAD1,HEAD2,IRC)
      IF(IRC.NE.0)GOTO 9999
      CALL OPNNEW(KUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,HEAD2,IRC)
      IF(IRC.NE.0)GOTO 9999
      CALL WFRAME(KUNIT,KPIC,NPIX,NRAST,BUF,IRC)
      IF(IRC.NE.0)GOTO 9999
      STOP 'Normal stop'
 9999 STOP 'USER STOP'
C
 1000 FORMAT(1X,'FD2BSL: Fibre diffraction to BSL format'/
     &       1X,'Last update 05/07/96'/)
 1010 FORMAT(1X,'***Keyword expected')
 1020 FORMAT(1X,'***Value expected')
 1025 FORMAT(1X,'***Unrecognised keyword')
 1030 FORMAT(1X,'Enter input filename')
 1036 FORMAT(1X,'***Input file does not exist:   ',A40)
 1045 FORMAT(1X,'***Error opening input file:   ',A40)
 1050 FORMAT(1X,'FDSCALE: Error reading input file')
 1055 FORMAT(1X,'Number of reflections exceeds ',I4)
 1060 FORMAT(1X,'Number of reflections read from file:',I5)
 1070 FORMAT(1X,'Maximum d*  ',F8.6)
 1140 FORMAT(1X,'Number of reflections written  ',I8)
      END


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Copyright 2012 California Institute of Technology. ALL RIGHTS RESERVED.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
! United States Government Sponsorship acknowledged. This software is subject to
! U.S. export control laws and regulations and has been classified as 'EAR99 NLR'
! (No [Export] License Required except when exporting to an embargoed country,
! end user, or in support of a prohibited end use). By downloading this software,
! the user agrees to comply with all applicable U.S. export laws and regulations.
! The user has the responsibility to obtain export licenses, or other export
! authority as may be required before exporting this software to any 'EAR99'
! embargoed foreign country or citizen of those countries.
!
! Author: Giangi Sacco
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

        subroutine setReferenceOrbit(array1d,dim1)
            use correctState
            implicit none
            integer dim1,i
            double precision, dimension(dim1):: array1d
            do i = 1, dim1
                s_mocomp(i) = array1d(i)
            enddo
        end

        subroutine setMocompBaseline(array2dT,dim1,dim2)
            use correctState
            implicit none
            integer dim1,dim2,i,j
            double precision, dimension(dim2,dim1):: array2dT
            do i = 1, dim2
                do j = 1, dim1
                    mocbase(i,j) = array2dT(i,j)
                enddo
            enddo
        end

        subroutine setISMocomp(var)
            use correctState
            implicit none
            integer var
            is_mocomp = var
        end

        subroutine setEllipsoidMajorSemiAxis(var)
            use correctState
            implicit none
            double precision var
            major = var
        end

        subroutine setEllipsoidEccentricitySquared(var)
            use correctState
            implicit none
            double precision var
            eccentricitySquared = var
        end

        subroutine setLength(var)
            use correctState
            implicit none
            integer var
            length = var
        end

        subroutine setWidth(var)
            use correctState
            implicit none
            integer var
            width = var
        end

        subroutine setRangePixelSpacing(var)
            use correctState
            implicit none
            double precision var
            rspace = var
        end

        subroutine setLookSide(var)
            use correctState
            implicit none
            integer var
            ilrl = var
        end

        subroutine setRangeFirstSample(var)
            use correctState
            implicit none
            double precision var
            r0 = var
        end

        subroutine setSpacecraftHeight(var)
            use correctState
            implicit none
            double precision var
            height = var
        end

        subroutine setPlanetLocalRadius(var)
            use correctState
            implicit none
            double precision var
            rcurv = var
        end

        subroutine setBodyFixedVelocity(var)
            use correctState
            implicit none
            real*4 var
            vel = var
        end

        subroutine setNumberRangeLooks(var)
            use correctState
            implicit none
            integer var
            Nrnglooks = var
        end

        subroutine setNumberAzimuthLooks(var)
            use correctState
            implicit none
            integer var
            Nazlooks = var
        end

        subroutine setPegLatitude(var)
            use correctState
            implicit none
            double precision var
            peglat = var
        end

        subroutine setPegLongitude(var)
            use correctState
            implicit none
            double precision var
            peglon = var
        end

        subroutine setPegHeading(var)
            use correctState
            implicit none
            double precision var
            peghdg = var
        end

        subroutine setPRF(var)
            use correctState
            implicit none
            double precision var
            prf = var
        end

        subroutine setRadarWavelength(var)
            use correctState
            implicit none
            double precision var
            wvl = var
        end

        subroutine setMidpoint(array2dT,dim1,dim2)
            use correctState
            implicit none
            integer dim1,dim2,i,j
            double precision, dimension(dim2,dim1):: array2dT
            do i = 1, dim2
                do j = 1, dim1
                    midpoint(i,j) = array2dT(i,j)
                enddo
            enddo
        end

        subroutine setSch1(array2dT,dim1,dim2)
            use correctState
            implicit none
            integer dim1,dim2,i,j
            double precision, dimension(dim2,dim1):: array2dT
            do i = 1, dim2
                do j = 1, dim1
                    s1sch(i,j) = array2dT(i,j)
                enddo
            enddo
        end

        subroutine setSch2(array2dT,dim1,dim2)
            use correctState
            implicit none
            integer dim1,dim2,i,j
            double precision, dimension(dim2,dim1):: array2dT
            do i = 1, dim2
                do j = 1, dim1
                    s2sch(i,j) = array2dT(i,j)
                enddo
            enddo
        end

        subroutine setSc(array2dT,dim1,dim2)
            use correctState
            implicit none
            integer dim1,dim2,i,j
            double precision, dimension(dim2,dim1):: array2dT
            do i = 1, dim2
                do j = 1, dim1
                    smsch(i,j) = array2dT(i,j)
                enddo
            enddo
        end

        subroutine setDopCoeff(var)
            use correctState
            implicit none
            integer*8 var
            dopAcc = var
        end subroutine setDopCoeff


**==gaunt.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION GAUNT(T,E,N,J,L,Dene)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL a , ah , b , bespec , bh , c , cc , cn , CONce , Dene , DNE ,
     &     E , em , ex , EXINT1 , gal , gal2 , GAUNT , gb , gbe
      REAL gbe1 , gbe2 , gbe3 , gbe4 , gbe5 , gc , gca , gf , ghe , gk ,
     &     gmg , gmgii , gmgp , gmshell , gn , gna , gna4 , GNCRCH ,
     &     GNDrec , gne
      REAL gnt , gox , HENeut , HEPlus , PCOol , PM , POT , POU ,
     &     POWer , RE , REDuc , RHY , st , T , t4 , tl , TU , x , y
      INTEGER i , ii , J , L , ll , m , N
C*** End of declarations inserted by SPAG

C     MAY '82 VERSION RELYING HEAVILY ON MANN AND ROBB CALCULATIONS,
C     BHATIA FOR DELTA N = 0 AND BHATIA AND MASON DELTA N = 1

      DIMENSION ah(5) , bh(5) , ghe(24) , gbe(8,5)
      DIMENSION gbe1(4) , gbe2(4) , gbe3(11) , gbe4(11) , gbe5(11) ,
     &          bespec(4,3)
      DIMENSION gb(8,6) , gc(8,9) , gn(8,4) , gox(8,8) , gf(8,9) ,
     &          gne(5,12)
      DIMENSION gna(8,2) , gna4(3,3) , gmgii(12)
      DIMENSION gmg(10) , gmgp(8,2)
      DIMENSION gal(10) , gal2(10) , a(10) , b(10) , c(10)
      DIMENSION gmshell(6,4) , gk(10) , gca(10)

      COMMON /INTERC/ REDuc(4)
      COMMON /RESULT/ CONce(30) , GNDrec(30) , POWer(220) , RHY ,
     &                HENeut , HEPlus , DNE , PCOol , POU , POT , RE ,
     &                TU , PM(4)

      DATA ah/0. , .08 , .08 , .08 , 0./
      DATA bh/.22 , .16 , .19 , .20 , 0./
      DATA ghe/.03785 , .0002038 , .04214 , -.001901 , -.03263 ,
     &     .004462 , .28 , 0. , .02327 , -.0007424 , -.06369 , .001865 ,
     &     .07711 , .000058 , 0. , 0. , -.03168 , .0008439 , .182 ,
     &     -.007289 , -.05873 , .009605 , 0. , 0./
      DATA gbe/.7114 , .00558 , -.9277 , -.00153 , .2711 , .00523 ,
     &     0.0 , 0.0 , 0.0 , 0.0 , -.044 , .00735 , .482 , -.01855 ,
     &     0.0 , 0.0 , .44 , 0.0 , -.010 , 5*0.0 , .077 , .00666 ,
     &     6*0. , -.2943 , -.00084 , .2574 , .01167 , .04852 , -.00777 ,
     &     .2671 , .00555/
      DATA gbe1/ - .0264 , 0.03 , 0.0 , 0.20/
      DATA gbe2/.0881 , 0.10 , .117 , 0.10/
      DATA gbe3/0.0 , .064 , .069 , .048 , .035 , .0303 , .025 , .02 ,
     &     .02 , .032 , .032/
      DATA gbe4/0.0 , .342 , .39 , .192 , .103 , .0836 , .063 , .043 ,
     &     .043 , 0.0 , 0.0/
      DATA gbe5/0.0 , 3*0.0 , 55000. , 64000. , 86000. , 97000. ,
     &     108000. , 156000. , 168000./
      DATA bespec/.00069 , .122 , .0059 , .0063 , .0016 , .13 , .0073 ,
     &     .0058 , .0017 , .127 , .0087 , .0040/
      DATA gb/.2392 , .00543 , .3723 , .0335 , .0321 , -.0253 , .4591 ,
     &     -.00232 , .2317 , .00654 , -.1479 , .03186 , .3038 ,
     &     -.02130 , .3904 , -.00302 , .0811 , .01318 , -.2523 ,
     &     .04591 , .2122 , -.02192 , .2304 , .00639 , -.112 , .0063 ,
     &     .050 , .011 , .0808 , -.005 , .239 , .0023 , .126 , 0.0 ,
     &     .287 , 0.0 , 0.0 , 0.0 , .28 , 0.0 , .128 , -.025 , -.46 ,
     &     .133 , .138 , -.023 , -.70 , .128/
      DATA gc/.3539 , .00039 , .2314 , .02314 , .0358 , -.01534 ,
     &     .5449 , -.00858 , .2005 , .00395 , -.3012 , .04332 ,
     &     -.09599 , .01606 , .3727 , -.001517 , .3229 , -.002883 ,
     &     .0212 , .02481 , .0783 , -.01326 , .4671 , -.008106 , -.112 ,
     &     .0063 , .050 , .011 , .0808 , -.005 , .239 , .0023 , .128 ,
     &     -.025 , -.46 , .133 , .138 , -.023 , -.70 , .128 , -.269 ,
     &     -.00117 , .0318 , .0233 , -.0102 , -.0075 , .235 , .0172 ,
     &     .22 , .0056 , 6*0. , .198 , .0069 , 6*0. , 8*0./
      DATA gn/ - .01876 , .0011 , .0083 , .00182 , .0135 , -.00083 ,
     &     .040 , .00040 , .51 , -.1 , -1.84 , .53 , .55 , -.091 ,
     &     -2.80 , .51 , .128 , -.025 , -.46 , .133 , .138 , -.023 ,
     &     -.70 , .128 , -.07504 , .0042 , .033 , .00726 , .054 ,
     &     -.0033 , .159 , .0015/
C
      DATA gox/.69 , 0.0 , 4*0.0 , .46 , 0.0 , -.112 , .0063 , .050 ,
     &     .011 , .0808 , -.005 , .2391 , .0023 , -.112 , .0063 , .050 ,
     &     .011 , .0808 , -.005 , .2391 , .0023 , .128 , -.025 , -.46 ,
     &     .133 , .138 , -.023 , -.70 , .128 , .51 , -.1 , -1.84 , .53 ,
     &     .55 , -.091 , -2.80 , .51 , .22 , .0056 , 6*0.0 , 8*0. ,
     &     .1261 , 0.0 , .2869 , 0.0 , 0.0 , 0.0 , .28 , 0.0/
      DATA gf/.2246 , .0075 , .3055 , .0062 , -.0575 , -.0017 , .4248 ,
     &     -.0049 , -.063 , 0. , .407 , 0. , -.0238 , 0. , .478 , 0. ,
     &     -.0157 , 0. , .188 , 0. , .0195 , 0. , .283 , 0. , -.001 ,
     &     0. , .134 , 0. , .123 , 0. , .158 , 0. , .51 , -.1 , -1.84 ,
     &     .53 , .55 , -.091 , -2.8 , .51 , .039 , .0154 , 6*0. , 8*0. ,
     &     .22 , .056 , 6*0. , 8*0./
      DATA gne/ - .72117 , 1.2406 , 11.746 , 8.2169 , -7.7772 , 1.0227 ,
     &     .70828 , 4.5400 , 4.1450 , -3.8657 , -1.04290 , .84411 ,
     &     6.7031 , 3.1927 , -3.1693 , -.039582 , .26837 , .25803 ,
     &     .086929 , -.086641 , -.017323 , .29514 , .29301 , .13223 ,
     &     -.13071 , -.071593 , .15504 , .12598 , -.000449 , .000523 ,
     &     .040202 , .25113 , .14858 , .030780 , -.030745 , .45761 ,
     &     .38477 , .52142 , .92153 , -.91649 , -.17862 , .32249 ,
     &     .28172 , .040677 , -.040639 , -.062670 , .14921 , 1.5354 ,
     &     1.0586 , -1.0219 , -.057871 , .030701 , .36471 , .14784 ,
     &     -.14293 , .093106 , -.001108 , -.067652 , -.021663 , .021657/
C
      DATA gna/.1586 , .007375 , .1866 , .04156 , .02403 , -.02416 ,
     &     .3100 , -.00098 , -.3245 , 0.0 , .5548 , 0.0 , -.1562 , 0.0 ,
     &     .266 , 0./
      DATA gna4/1.153 , -.0333 , 0.0 , .001 , .0053 , .058 , .67 ,
     &     -.0133 , 0.0/
      DATA gmgii/.24 , 37.3 , 68.3 , 96. , 96. , 2.39 , 5.99 , 5.99 ,
     &     0. , 0. , 0. , .142/
      DATA gmg/.9 , .2 , .25 , .23 , .23 , .2 , .2 , .2 , .14 , .0094/
      DATA gmgp/ - .1333 , .0155 , -.6758 , .0577 , .5057 , -.0323 ,
     &     .314 , 0.0 , -.294 , 0.0 , .5043 , 0.0 , -.1619 , 0.0 ,
     &     .2606 , 0.0/
      DATA gal/0.0139 , .01 , .06 , 0. , 0.2 , 3*0. , 1.64 , .11/
      DATA gal2/0.0 , .28 , .28 , 0. , 0. , 3*0. , .00 , .28/
      DATA a/.022 , .625 , .660 , .240 , .061 , .256 , .0368 , .271 ,
     &     .833 , .696/
      DATA b/.0035 , .360 , .432 , .019 , .364 , .354 , .343 , .794 ,
     &     .404 , .387/
      DATA c/.1261 , .1261 , .1261 , .477 , .162 , .0108 , .138 ,
     &     .0719 , .1261 , .1261/
      DATA gmshell/.453 , .91 , .13 , .93 , .2 , .2 , .7 , .98 , .13 ,
     &     .93 , 0. , 0. , .59 , .95 , .13 , .93 , 0. , 0. , .51 , .95 ,
     &     .20 , .29 , 0. , 0./
      DATA gk/.35 , .35 , 1.1 , .092 , .91 , .97 , 1.1 , 3*0./
      DATA gca/.35 , .21 , 43. , .14 , .12 , .43 , 37. , .20 , .11 , 4./

C  SHOULD PUT IN SENSIBLE F'S FOR POTASSIUM ISOSEQUENCE

      t4 = T/10000.
      st = SQRT(T)
      GAUNT = 0.2
      y = E*11590./T
      cc = EXINT1(y,2)
      IF ( J.EQ.1 .AND. N.GT.2 ) THEN
         GAUNT = .01
         IF ( y.LE.10. ) GAUNT = AMIN1(EXP(-.7*ALOG(y)-2.3),.28*cc)
      ELSE
C
         ii = N - J + 1
         IF ( ii.GE.18 ) THEN
            IF ( ii.LE.18 ) THEN
               RETURN
            ELSEIF ( ii.GT.19 ) THEN
               IF ( L.LE.3 ) GAUNT = AMAX1(.2,-.606*ALOG10(y)-.052)
               RETURN
            ELSE
               GAUNT = gk(L)
               IF ( N.EQ.20 ) GAUNT = gca(L)
               RETURN
            ENDIF
         ELSEIF ( ii.EQ.2 ) THEN
C  HELIUM-LIKE IONS:  PRADHAN+CASCADES FOR N=2, MEWE N=3,4
C  NEUTRAL HE FROM Berrington et al J Phys B 18,4135; Aggarwal Ap J 278,874
C  L = 9 HAS GAUNT = 0.0,  SATELLITE LINES : L = 6 DONE BY BRANCH FROM L=3
            IF ( N.EQ.2 ) THEN
               IF ( L.EQ.1 ) GAUNT = AMIN1(.00656*t4**(.89),.30*cc)
               IF ( L.EQ.4 .OR. L.EQ.5 ) GAUNT = .30*cc
               IF ( L.EQ.2 ) GAUNT = AMIN1(.0283*t4**(-.10),.359*t4**(-
     &                               .569))
               IF ( L.EQ.3 ) GAUNT = AMIN1(.0105*t4**(.30),.095*t4**(-
     &                               .479))
               IF ( L.EQ.6 ) GAUNT = 0.0
               IF ( L.EQ.7 ) GAUNT = 4.08E-7*T**.941
               IF ( L.EQ.8 ) GAUNT = 2.46E-8*T**1.22
               IF ( L.EQ.9 ) GAUNT = 0.0
            ELSEIF ( L.GT.3 ) THEN
               IF ( L.EQ.4 ) GAUNT = (1.+7./N)
     &                               *(.053+.022*(y*y*y*cc-y*y+y)
     &                               +.276*cc)
               IF ( L.EQ.5 ) GAUNT = (1+1.5/N)
     &                               *(.053+.022*(y*y*y*cc-y*y+y)
     &                               +.276*cc)
               IF ( L.EQ.6 ) GAUNT = 0.
               IF ( L.EQ.7 ) GAUNT = .04*(y-y*y*cc)
               IF ( L.EQ.8 ) GAUNT = .02
               IF ( L.EQ.9 ) GAUNT = 0.
               RETURN
            ELSE
               GAUNT = GNCRCH(ghe,L,y,cc,N)
               RETURN
            ENDIF
         ELSEIF ( ii.EQ.3 ) THEN
C  LITHIUM-LIKE IONS: MEWE MODIFIED TO FIT CLOSE-COUPLING CALCULATIONS OF ROBB, HENRY
            x = 1./(N-3.)
            IF ( L.EQ.1 ) GAUNT = (0.68+.02*N)
     &                            *((.7+.35*x)+((1.-.8*x)*y+(.5-.5*x)
     &                            *y*y+.28)*cc-(.5-.5*x)*y)
            IF ( L.EQ.2 ) GAUNT = .053 + .16*cc
            IF ( L.EQ.3 .OR. L.EQ.4 ) GAUNT = -(.16+.32*x)
     &           + ((.8-.56*x)*y+.2*y*y+.28)*cc - .2*y
            IF ( L.EQ.5 ) GAUNT = (.19+.25*x) + .079*cc
            IF ( L.EQ.6 ) GAUNT = .31 - .1*y*cc
            IF ( L.EQ.7 ) GAUNT = .096 + .32*x
            IF ( L.EQ.8 ) GAUNT = .13
         ELSEIF ( ii.EQ.4 ) THEN
C  BERYLLIUM-LIKE IONS:  QUB FOR N=2 UP THROUGH NE; MANN, ROBB & SAMPSON PLUS RESONANCES FOR OTHERS
C  MANN AND MALINOVSKY FOR N = 3 AND QUB O V N=3 FROM WIDING
C  N = 4 FROM JOHNSTON & KUNZE, MASON & STOREY (FE XXII) AND LI-LIKE
            i = N - 5
            IF ( N.GE.10 ) i = N/2 - 1
            IF ( N.GE.26 ) i = N/2 - 3
            IF ( L.EQ.1 ) THEN
               tl = ALOG10(T)
               GAUNT = .54 + .0125*N + .135*cc
               IF ( N.LE.10 ) GAUNT = gbe1(i) + gbe2(i)*tl
            ELSEIF ( L.NE.2 ) THEN
               IF ( L.LE.7 ) GAUNT = GNCRCH(gbe,L-2,y,cc,N)
               IF ( L.EQ.8 ) GAUNT = .1261 + .2869*y*cc + .276*cc
               IF ( N.LE.8 ) THEN
                  em = -4.67 + 1.86*N
                  ex = EXP(-em*11590./T)
                  m = N - 5
                  IF ( L.EQ.10 ) GAUNT = bespec(1,m)*(1.-PM(1))
     &                 *ex + bespec(2,m)*PM(1)
                  IF ( L.EQ.11 ) GAUNT = bespec(3,m)*(1.-PM(1))
     &                 *ex + bespec(4,m)*PM(1)
               ENDIF
            ELSE
               gnt = gbe3(i)/(1.+gbe4(i)/y) + gbe5(i)/T
               IF ( N.EQ.6 ) gnt = .046/(1.+T*T/6.25E10)
               GAUNT = gnt*REDuc(1)
            ENDIF
         ELSEIF ( ii.EQ.5 ) THEN
C  BORON ISOSEQUENCE: N=2 INTERPOLATED FROM O IV AND FE XXII OF ROBB; GOOD TO 10% WRT FLOWER & NUSSBAUMER
C  NA-S, DERE ET AL AR, MANN C II;  OVEREST BY 36% NEAR THRESHOLD WRT ROBB CC FOR C II
C  N = 3 INTERPOLATED C II AND FE XXII FROM MANN; 2S-3L SCALED FROM BE-, F- & NE-LIKE IONS, AGREES W MASON & STOREY
C  TO 8% FOR 2S-3P.  N = 4 FROM MASON & STOREY
C  L = 9 INTERCOMBINATION LINE
            IF ( L.LE.6 ) GAUNT = GNCRCH(gb,L,y,cc,N)
            IF ( L.EQ.9 ) GAUNT = REDuc(2)
            IF ( L.EQ.12 ) GAUNT = 0.
         ELSEIF ( ii.EQ.6 ) THEN
C  CARBON ISOSEQUENCE: N=2 INTERP FROM MANN AND ROBB;  AGREES TO 5-10% WITH BHATIA AR, MG
C  N=3,4 GENERAL B-F; AGREES 3-10% WITH MANN 2P-3D; L=6 INTERCOMB
            IF ( L.LE.5 ) GAUNT = GNCRCH(gc,L,y,cc,N)
            IF ( L.EQ.7 ) GAUNT = .198 + .0069*N
            IF ( L.EQ.8 ) GAUNT = .22 + .0056*N
            IF ( L.EQ.9 ) GAUNT = .1261 + (.2869*y+.28)*cc
            IF ( L.EQ.6 ) GAUNT = REDuc(3)
            IF ( L.EQ.6 .AND. N.EQ.6 ) GAUNT = SQRT(.0001*T)*REDuc(3)
            IF ( L.EQ.12 ) GAUNT = 0.
         ELSEIF ( ii.EQ.7 ) THEN
C  NITROGEN SEQUENCE:   N=2 FROM MANN FE XX AND MASON & BHATIA MG,SI,S,AR,CA
C  N=3 AND 4 GENERAL B-F
            IF ( L.EQ.1 ) GAUNT = (1.086-1.71/J)
     &                            *(.3642+.9358*y*cc-.3758*(y-y*y*cc)
     &                            +.3586*cc)
            IF ( L.GE.2 .AND. L.LE.5 ) GAUNT = GNCRCH(gn,L-1,y,cc,N)
            IF ( L.EQ.12 ) GAUNT = 0.
            IF ( L.EQ.8 ) GAUNT = .22 + .0056*N
            IF ( L.EQ.9 ) GAUNT = .1261 + .2869*y*cc + .276*cc
         ELSEIF ( ii.EQ.8 ) THEN
C  OXYGEN ISOSEQUENCE:  N=2 FROM MANN, ROBB FE XIX AND FROM BHATIA,F&D SI, S, AR
C  OTHERS GENERIC B-F
            IF ( L.LE.8 ) GAUNT = GNCRCH(gox,L,y,cc,N)
            IF ( L.EQ.10 ) GAUNT = .16 + .0015*N
            IF ( L.EQ.15 ) GAUNT = 0.
         ELSEIF ( ii.EQ.9 ) THEN
C  FLUORINE SEQUENCE:   N=2 FROM MANN AL V AND ROBB FE XVIII;   OTHERS GENERIC B-F ISO; N=3 FROM MANN
            IF ( L.LE.8 ) GAUNT = GNCRCH(gf,L,y,cc,N)
            IF ( L.EQ.9 ) GAUNT = .1261 + (.2869*y+.28)*cc
         ELSEIF ( ii.EQ.10 ) THEN
C     NEON SEQUENCE: SMITH ET AL INCLUDING CASCADES AND RESONANCES
C     ASSUME THEY ARE ALL LIKE FE XVII
            IF ( L.LE.12 ) GAUNT = gne(1,L)
     &                             + (gne(2,L)+gne(3,L)*y+gne(4,L)*y*y)
     &                             *EXINT1(y,2) + gne(5,L)*y
         ELSEIF ( ii.EQ.11 ) THEN
C     SODIUM SEQUENCE:  MANN, FLOWER & NUSSBAUMER, AND BLAHA
            IF ( N.EQ.12 ) THEN
               GAUNT = gmgii(L)
               IF ( L.EQ.1 ) GAUNT = .112 + (.0269*y-.0998*y*y+.318)
     &                               *cc + .0998*y
               IF ( L.EQ.2 ) GAUNT = 141 + (59.3*y-671*y*y+.858)
     &                               *cc + 671*y
               RETURN
            ELSEIF ( L.LE.2 ) THEN
               GAUNT = GNCRCH(gna,L,y,cc,N-10)
               IF ( N.EQ.14 .AND. L.EQ.2 ) GAUNT = -.0172 +
     &              (.832*y+.029*y*y+.3513)*cc - .029*y
               RETURN
            ELSEIF ( L.GT.5 ) THEN
               IF ( L.EQ.6 ) GAUNT = -.16 + .8*y*cc - .2*(y-y*y*cc)
     &                               + .276*cc
               IF ( L.EQ.7 ) GAUNT = .44 - 0.1*y*cc
               IF ( L.EQ.8 ) GAUNT = .15 - .05*y*cc
               IF ( L.EQ.9 .OR. L.EQ.10 ) GAUNT = 0.03
               IF ( L.EQ.11 ) GAUNT = 0.07
               IF ( L.EQ.12 ) GAUNT = 0.15
               RETURN
            ELSE
               ll = L - 2
               GAUNT = gna4(1,ll) + gna4(2,ll)*N + gna4(3,ll)*cc
               RETURN
            ENDIF
         ELSEIF ( ii.EQ.12 ) THEN
C     MAGNESIUM SEQUENCE:   INTERPOLATE SI TO FE FOR 3P, 4P EXCITATIONS;
C     USE MANN FE GAUNT FACTORS FOR 3D, 4S, 4F, AND INTERCOMB.  ASSUME
C     G FOR 4D = G FOR 4F;  L=10 IS INTERCOMBINATION LINE
            GAUNT = gmg(L)
            IF ( L.LE.2 ) GAUNT = GNCRCH(gmgp,L,y,cc,N)
            IF ( L.EQ.10 ) GAUNT = REDuc(4)
            IF ( L.EQ.10 .AND. N.EQ.14 ) GAUNT = REDuc(4)*(20000./T)
     &           **(.406)
            RETURN
         ELSEIF ( ii.EQ.13 ) THEN
C     ALUMINUM ISO-SEQUENCE:   SI II FROM ROBERTS, S IV 3P FROM MANN, 3D FROM BHATIA USED FOR AR & CA
C     FE XIV FROM BLAHA USED FOR NI AND FOR ALL N=4
C     RESONANCES INCLUDED FOR METASTABLE USING BHATIA COLLISION STRENGTHS
C     SI II 1814 LINES FROM BROWN, FERRAZ AND JORDAN
C     FE XIV RESONANCES COMPUTED AS IN SMITH ET AL FROM BLAHA OMEGAS
            IF ( L.LT.4 .OR. L.GT.8 ) THEN
               IF ( N.LE.14 ) THEN
                  GAUNT = gal(L) + gal2(L)*cc
                  IF ( L.EQ.1 ) GAUNT = gal(1)*1.9E7*st/(Dene+st*1.9E7)
                  RETURN
               ELSEIF ( N.LE.20 ) THEN
                  cn = st*2.7*10.**(7.+J/2.)
                  IF ( L.EQ.1 ) GAUNT = ((.128+(.3449*y+.3544*y*y)*cc-
     &                                  .3544*y)*1.8/(1.+.25/y))
     &                                  *.069*cn/(Dene+cn)
                  IF ( L.EQ.2 ) GAUNT = .0405 +
     &                                  (.2052*y+.0328*y*y+.2311)
     &                                  *cc - .0328*y
                  IF ( L.EQ.3 ) GAUNT = .142 + .147*cc
                  IF ( L.EQ.9 ) GAUNT = .1330 +
     &                                  (.3833*y+.0934*y*y+.1611)
     &                                  *cc - .0934*y
                  IF ( L.EQ.10 ) GAUNT = .1684 +
     &                 (.2432*y+.0484*y*y+.2638)*cc - .0484*y
                  RETURN
               ENDIF
            ENDIF
            GAUNT = a(L) + b(L)*(1.-1./(1.+c(L)/y))
            IF ( L.EQ.1 ) GAUNT = (.0121+.0036/(1.+.1261/y))
     &                            *6.0E17/(Dene+6.0E17)
            RETURN
         ELSEIF ( ii.EQ.14 .OR. ii.EQ.15 .OR. ii.EQ.16 .OR. ii.EQ.17 )
     &            THEN
C
C  SILICON THROUGH CHLORINE SEQUENCES
            GAUNT = gmshell(L,ii-13)
            IF ( L.EQ.3 .AND. ii.NE.17 ) GAUNT = gmshell(L,ii-13)
     &           - .114/(1.+.138/y)
            RETURN
         ELSE
C
C  HYDROGENIC IONS: MEWE; HAYES AND SEATON: 3S,3D FROM THOMAS; OTHERS MEWE
            GAUNT = ah(L) + bh(L)*y*cc + .276*cc
            IF ( L.EQ.5 ) GAUNT = .212 - .203*(y-y*y*cc) + .0256*cc
            IF ( N.GT.2 ) RETURN
            IF ( L.EQ.5 ) GAUNT = .1198*y*cc - .1194*(y-y*y*cc)
     &                            + .0328*cc
         ENDIF
      ENDIF
      RETURN
      END


  module modal_aero_rename
  use shr_kind_mod, only : r8 => shr_kind_r8
  use modal_aero_data, only: maxd_aspectype
  use module_cam_support, only: &
        pcnstxx => gas_pcnst_modal_aero, &
        endrun
  implicit none
  private
  save
  public modal_aero_rename_sub, modal_aero_rename_init
  integer, parameter, public :: maxpair_renamexf = 1
  integer, parameter, public :: maxspec_renamexf = maxd_aspectype
  integer, public :: npair_renamexf = -123456789
  integer, public :: modefrm_renamexf(maxpair_renamexf)
  integer, public :: modetoo_renamexf(maxpair_renamexf)
  integer, public :: nspecfrm_renamexf(maxpair_renamexf)
  integer, public :: lspecfrmc_renamexf(maxspec_renamexf,maxpair_renamexf)
  integer, public :: lspecfrma_renamexf(maxspec_renamexf,maxpair_renamexf)
  integer, public :: lspectooc_renamexf(maxspec_renamexf,maxpair_renamexf)
  integer, public :: lspectooa_renamexf(maxspec_renamexf,maxpair_renamexf)
  contains
 subroutine modal_aero_rename_sub( &
                        fromwhere, lchnk, &
                        ncol, nstep, &
                        loffset, deltat, &
                        latndx, lonndx, &
                        pdel, &
                        dotendrn, q, &
                        dqdt, dqdt_other, &
                        dotendqqcwrn, qqcw, &
                        dqqcwdt, dqqcwdt_other, &
                        is_dorename_atik, dorename_atik, &
                        jsrflx_rename, nsrflx, &
                        qsrflx, qqcwsrflx )
   use shr_kind_mod, only : r4 => shr_kind_r4
   use modal_aero_data
   use physconst, only: gravit, mwdry
   use module_cam_support, only: &
        pcnst => pcnst_runtime, &
        pcols, pver
   use constituents, only: cnst_name
   use physconst, only: pi
   implicit none
   character(len=*), intent(in) :: fromwhere
   integer, intent(in) :: lchnk
   integer, intent(in) :: ncol
   integer, intent(in) :: nstep
   integer, intent(in) :: loffset
   real(r8), intent(in) :: deltat
   integer, intent(in) :: latndx(pcols), lonndx(pcols)
   real(r8), intent(in) :: pdel(pcols,pver)
   real(r8), intent(in) :: q(ncol,pver,pcnstxx)
   real(r8), intent(in) :: qqcw(ncol,pver,pcnstxx)
   real(r8), intent(inout) :: dqdt(ncol,pver,pcnstxx)
   real(r8), intent(inout) :: dqqcwdt(ncol,pver,pcnstxx)
   real(r8), intent(in) :: dqdt_other(ncol,pver,pcnstxx)
   real(r8), intent(in) :: dqqcwdt_other(ncol,pver,pcnstxx)
   logical, intent(inout) :: dotendrn(pcnstxx)
   logical, intent(inout) :: dotendqqcwrn(pcnstxx)
   logical, intent(in) :: is_dorename_atik
   logical, intent(in) :: dorename_atik(ncol,pver)
   integer, intent(in) :: jsrflx_rename
   integer, intent(in) :: nsrflx
   real(r8), intent(inout) :: qsrflx(pcols,pcnstxx,nsrflx)
   real(r8), intent(inout) :: qqcwsrflx(pcols,pcnstxx,nsrflx)
   integer, parameter :: ldiag1=-1
   integer :: i, icol_diag, ipair, iq, j, k, l, l1, l2, la, lc, lunout
   integer :: lsfrma, lsfrmc, lstooa, lstooc
   integer :: mfrm, mtoo, n, n1, n2, ntot_msa_a
   integer :: idomode(ntot_amode)
   integer, save :: lun = -1
   real (r8) :: deldryvol_a(ncol,pver,ntot_amode)
   real (r8) :: deldryvol_c(ncol,pver,ntot_amode)
   real (r8) :: deltatinv
   real (r8) :: dp_belowcut(maxpair_renamexf)
   real (r8) :: dp_cut(maxpair_renamexf)
   real (r8) :: dgn_aftr, dgn_xfer
   real (r8) :: dgn_t_new, dgn_t_old
   real (r8) :: dryvol_t_del, dryvol_t_new
   real (r8) :: dryvol_t_old, dryvol_t_oldbnd
   real (r8) :: dryvol_a(ncol,pver,ntot_amode)
   real (r8) :: dryvol_c(ncol,pver,ntot_amode)
   real (r8) :: dryvol_smallest(ntot_amode)
   real (r8) :: dum
   real (r8) :: dum3alnsg2(maxpair_renamexf)
   real (r8) :: dum_m2v, dum_m2vdt
   real (r8) :: factoraa(ntot_amode)
   real (r8) :: factoryy(ntot_amode)
   real (r8) :: frelax
   real (r8) :: lndp_cut(maxpair_renamexf)
   real (r8) :: lndgn_new, lndgn_old
   real (r8) :: lndgv_new, lndgv_old
   real (r8) :: num_t_old, num_t_oldbnd
   real (r8) :: onethird
   real (r8) :: pdel_fac
   real (r8) :: tailfr_volnew, tailfr_volold
   real (r8) :: tailfr_numnew, tailfr_numold
   real (r8) :: v2nhirlx(ntot_amode), v2nlorlx(ntot_amode)
   real (r8) :: xfercoef, xfertend
   real (r8) :: xferfrac_vol, xferfrac_num, xferfrac_max
   real (r4) :: yn_tail, yv_tail
   real (r4) :: erfc
 lunout = 6
  lun = 6
 if (npair_renamexf .le. 0) return
 deltatinv = 1.0/(deltat*(1.0d0 + 1.0d-15))
 onethird = 1.0/3.0
 frelax = 27.0
 xferfrac_max = 1.0_r8 - 10.0_r8*epsilon(1.0_r8)
 do n = 1, ntot_amode
     idomode(n) = 0
 end do
 do ipair = 1, npair_renamexf
     if (ipair .gt. 1) goto 8100
     idomode(modefrm_renamexf(ipair)) = 1
     mfrm = modefrm_renamexf(ipair)
     mtoo = modetoo_renamexf(ipair)
     factoraa(mfrm) = (pi/6.)*exp(4.5*(alnsg_amode(mfrm)**2))
     factoraa(mtoo) = (pi/6.)*exp(4.5*(alnsg_amode(mtoo)**2))
     factoryy(mfrm) = sqrt( 0.5 )/alnsg_amode(mfrm)
     dryvol_smallest(mfrm) = 1.0e-25
     v2nlorlx(mfrm) = voltonumblo_amode(mfrm)*frelax
     v2nhirlx(mfrm) = voltonumbhi_amode(mfrm)/frelax
     dum3alnsg2(ipair) = 3.0 * (alnsg_amode(mfrm)**2)
     dp_cut(ipair) = sqrt( &
  dgnum_amode(mfrm)*exp(1.5*(alnsg_amode(mfrm)**2)) * &
  dgnum_amode(mtoo)*exp(1.5*(alnsg_amode(mtoo)**2)) )
     lndp_cut(ipair) = log( dp_cut(ipair) )
     dp_belowcut(ipair) = 0.99*dp_cut(ipair)
 end do
 do n = 1, ntot_amode
     if (idomode(n) .gt. 0) then
  dryvol_a(1:ncol,:,n) = 0.0_r8
  dryvol_c(1:ncol,:,n) = 0.0_r8
  deldryvol_a(1:ncol,:,n) = 0.0_r8
  deldryvol_c(1:ncol,:,n) = 0.0_r8
  do l1 = 1, nspec_amode(n)
      l2 = lspectype_amode(l1,n)
      dum_m2v = specmw_amode(l2) / specdens_amode(l2)
      dum_m2vdt = dum_m2v*deltat
      la = lmassptr_amode(l1,n)-loffset
      if (la > 0) then
      dryvol_a(1:ncol,:,n) = dryvol_a(1:ncol,:,n) &
   + dum_m2v*max( 0.0_r8, &
                          q(1:ncol,:,la)-deltat*dqdt_other(1:ncol,:,la) )
      deldryvol_a(1:ncol,:,n) = deldryvol_a(1:ncol,:,n) &
   + (dqdt_other(1:ncol,:,la) + dqdt(1:ncol,:,la))*dum_m2vdt
      end if
      lc = lmassptrcw_amode(l1,n)-loffset
      if (lc > 0) then
      dryvol_c(1:ncol,:,n) = dryvol_c(1:ncol,:,n) &
   + dum_m2v*max( 0.0_r8, &
                          qqcw(1:ncol,:,lc)-deltat*dqqcwdt_other(1:ncol,:,lc) )
      deldryvol_c(1:ncol,:,n) = deldryvol_c(1:ncol,:,n) &
   + (dqqcwdt_other(1:ncol,:,lc) + &
            dqqcwdt(1:ncol,:,lc))*dum_m2vdt
      end if
  end do
     end if
 end do
mainloop1_k: do k = 1, pver
mainloop1_i: do i = 1, ncol
 if (is_dorename_atik) then
     if (.not. dorename_atik(i,k)) cycle mainloop1_i
 end if
 pdel_fac = pdel(i,k)/gravit
mainloop1_ipair: do ipair = 1, npair_renamexf
 mfrm = modefrm_renamexf(ipair)
 mtoo = modetoo_renamexf(ipair)
 dryvol_t_old = dryvol_a(i,k,mfrm) + dryvol_c(i,k,mfrm)
 dryvol_t_del = deldryvol_a(i,k,mfrm) + deldryvol_c(i,k,mfrm)
 dryvol_t_new = dryvol_t_old + dryvol_t_del
 dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
 if (dryvol_t_new .le. dryvol_smallest(mfrm)) cycle mainloop1_ipair
 if (dryvol_t_del .le. 1.0e-6*dryvol_t_oldbnd) cycle mainloop1_ipair
 num_t_old = q(i,k,numptr_amode(mfrm)-loffset)
 num_t_old = num_t_old + qqcw(i,k,numptrcw_amode(mfrm)-loffset)
 num_t_old = max( 0.0_r8, num_t_old )
 dryvol_t_oldbnd = max( dryvol_t_old, dryvol_smallest(mfrm) )
 num_t_oldbnd = min( dryvol_t_oldbnd*v2nlorlx(mfrm), num_t_old )
 num_t_oldbnd = max( dryvol_t_oldbnd*v2nhirlx(mfrm), num_t_oldbnd )
 dgn_t_new = (dryvol_t_new/(num_t_oldbnd*factoraa(mfrm)))**onethird
 if (dgn_t_new .le. dgnum_amode(mfrm)) cycle mainloop1_ipair
 lndgn_new = log( dgn_t_new )
 lndgv_new = lndgn_new + dum3alnsg2(ipair)
 yn_tail = (lndp_cut(ipair) - lndgn_new)*factoryy(mfrm)
 yv_tail = (lndp_cut(ipair) - lndgv_new)*factoryy(mfrm)
 tailfr_numnew = 0.5*erfc( yn_tail )
 tailfr_volnew = 0.5*erfc( yv_tail )
 dgn_t_old = &
  (dryvol_t_oldbnd/(num_t_oldbnd*factoraa(mfrm)))**onethird
 if (dgn_t_new .ge. dp_cut(ipair)) then
     dgn_t_old = min( dgn_t_old, dp_belowcut(ipair) )
 end if
 lndgn_old = log( dgn_t_old )
 lndgv_old = lndgn_old + dum3alnsg2(ipair)
 yn_tail = (lndp_cut(ipair) - lndgn_old)*factoryy(mfrm)
 yv_tail = (lndp_cut(ipair) - lndgv_old)*factoryy(mfrm)
 tailfr_numold = 0.5*erfc( yn_tail )
 tailfr_volold = 0.5*erfc( yv_tail )
 dum = tailfr_volnew*dryvol_t_new - tailfr_volold*dryvol_t_old
 if (dum .le. 0.0_r8) cycle mainloop1_ipair
 xferfrac_vol = min( dum, dryvol_t_new )/dryvol_t_new
 xferfrac_vol = min( xferfrac_vol, xferfrac_max )
 xferfrac_num = tailfr_numnew - tailfr_numold
 xferfrac_num = max( 0.0_r8, min( xferfrac_num, xferfrac_vol ) )
  if (ldiag1 > 0) then
  icol_diag = -1
  if ((lonndx(i) == 37) .and. (latndx(i) == 23)) icol_diag = i
  if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
  write(lun,97010) fromwhere, nstep, latndx(i), lonndx(i), k, ipair
  write(lun,97020) 'drv old/oldbnd/new/del     ', &
   dryvol_t_old, dryvol_t_oldbnd, dryvol_t_new, dryvol_t_del
  write(lun,97020) 'num old/oldbnd, dgnold/new ', &
   num_t_old, num_t_oldbnd, dgn_t_old, dgn_t_new
  write(lun,97020) 'tailfr v_old/new, n_old/new', &
   tailfr_volold, tailfr_volnew, tailfr_numold, tailfr_numnew
  dum = max(1.0d-10,xferfrac_vol) / max(1.0d-10,xferfrac_num)
  dgn_xfer = dgn_t_new * dum**onethird
  dum = max(1.0d-10,(1.0d0-xferfrac_vol)) / &
               max(1.0d-10,(1.0d0-xferfrac_num))
  dgn_aftr = dgn_t_new * dum**onethird
  write(lun,97020) 'xferfrac_v/n; dgn_xfer/aftr', &
   xferfrac_vol, xferfrac_num, dgn_xfer, dgn_aftr
 97010 format( / 'RENAME ', a, '  nx,lat,lon,k,ip', i8, 4i4 )
 97020 format( a, 6(1pe15.7) )
  end if
  end if
 j = jsrflx_rename
 do iq = 1, nspecfrm_renamexf(ipair)
     xfercoef = xferfrac_vol*deltatinv
     if (iq .eq. 1) xfercoef = xferfrac_num*deltatinv
     lsfrma = lspecfrma_renamexf(iq,ipair)-loffset
     lsfrmc = lspecfrmc_renamexf(iq,ipair)-loffset
     lstooa = lspectooa_renamexf(iq,ipair)-loffset
     lstooc = lspectooc_renamexf(iq,ipair)-loffset
     if (lsfrma .gt. 0) then
  xfertend = xfercoef*max( 0.0_r8, &
       (q(i,k,lsfrma)+dqdt(i,k,lsfrma)*deltat) )
                if (ldiag1 > 0) then
                if ((i == icol_diag) .and. (mod(k-1,5) == 0)) then
                  if (lstooa .gt. 0) then
                    write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
                        cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
                        deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend), &
                        deltat*dqdt(i,k,lstooa), deltat*(dqdt(i,k,lstooa) + xfertend)
                  else
                    write(*,'(a,i4,2(2x,a),1p,10e14.6)') 'RENAME qdels', iq, &
                        cnst_name(lsfrma+loffset), cnst_name(lstooa+loffset), &
                        deltat*dqdt(i,k,lsfrma), deltat*(dqdt(i,k,lsfrma) - xfertend)
                  end if
                end if
                end if
  dqdt(i,k,lsfrma) = dqdt(i,k,lsfrma) - xfertend
  qsrflx(i,lsfrma,j) = qsrflx(i,lsfrma,j) - xfertend*pdel_fac
  if (lstooa .gt. 0) then
      dqdt(i,k,lstooa) = dqdt(i,k,lstooa) + xfertend
      qsrflx(i,lstooa,j) = qsrflx(i,lstooa,j) + xfertend*pdel_fac
  end if
     end if
     if (lsfrmc .gt. 0) then
  xfertend = xfercoef*max( 0.0_r8, &
       (qqcw(i,k,lsfrmc)+dqqcwdt(i,k,lsfrmc)*deltat) )
  dqqcwdt(i,k,lsfrmc) = dqqcwdt(i,k,lsfrmc) - xfertend
  qqcwsrflx(i,lsfrmc,j) = qqcwsrflx(i,lsfrmc,j) - xfertend*pdel_fac
  if (lstooc .gt. 0) then
      dqqcwdt(i,k,lstooc) = dqqcwdt(i,k,lstooc) + xfertend
      qqcwsrflx(i,lstooc,j) = qqcwsrflx(i,lstooc,j) + xfertend*pdel_fac
  end if
     end if
 end do
 end do mainloop1_ipair
 end do mainloop1_i
 end do mainloop1_k
 dotendrn(:) = .false.
 dotendqqcwrn(:) = .false.
 do ipair = 1, npair_renamexf
 do iq = 1, nspecfrm_renamexf(ipair)
     lsfrma = lspecfrma_renamexf(iq,ipair) - loffset
     lsfrmc = lspecfrmc_renamexf(iq,ipair) - loffset
     lstooa = lspectooa_renamexf(iq,ipair) - loffset
     lstooc = lspectooc_renamexf(iq,ipair) - loffset
     if (lsfrma .gt. 0) then
  dotendrn(lsfrma) = .true.
  if (lstooa .gt. 0) dotendrn(lstooa) = .true.
     end if
     if (lsfrmc .gt. 0) then
  dotendqqcwrn(lsfrmc) = .true.
  if (lstooc .gt. 0) dotendqqcwrn(lstooc) = .true.
     end if
 end do
 end do
 return
8100 write(lunout,9050) ipair
 call endrun( 'modal_aero_rename_sub error' )
9050 format( / '*** subr. modal_aero_rename_sub ***' / &
           4x, 'aerosol renaming not implemented for ipair =', i5 )
 end subroutine modal_aero_rename_sub
 subroutine modal_aero_rename_init
 use modal_aero_data
        use module_cam_support, only: &
  pcnst => pcnst_runtime, &
  masterproc
        use constituents, only: cnst_name
 implicit none
 integer ipair, iq, iqfrm, iqfrm_aa, iqtoo, iqtoo_aa, &
         lsfrma, lsfrmc, lstooa, lstooc, lunout, &
         mfrm, mtoo, n1, n2, nsamefrm, nsametoo, nspec
 lunout = 6
 n1 = modeptr_accum
 n2 = modeptr_aitken
 if ((n1 .gt. 0) .and. (n2 .gt. 0)) then
     npair_renamexf = 1
     modefrm_renamexf(1) = n2
     modetoo_renamexf(1) = n1
 else
     npair_renamexf = 0
     return
 end if
 do 1900 ipair = 1, npair_renamexf
 mfrm = modefrm_renamexf(ipair)
 mtoo = modetoo_renamexf(ipair)
 nspec = 0
 do 1490 iqfrm = -1, nspec_amode(mfrm)
     iqtoo = iqfrm
     if (iqfrm .eq. -1) then
  lsfrma = numptr_amode(mfrm)
  lstooa = numptr_amode(mtoo)
  lsfrmc = numptrcw_amode(mfrm)
  lstooc = numptrcw_amode(mtoo)
     else if (iqfrm .eq. 0) then
                goto 1490
     else
  lsfrma = lmassptr_amode(iqfrm,mfrm)
  lsfrmc = lmassptrcw_amode(iqfrm,mfrm)
  lstooa = 0
  lstooc = 0
     end if
     if ((lsfrma .lt. 1) .or. (lsfrma .gt. pcnst)) then
  write(lunout,9100) mfrm, iqfrm, lsfrma
  call endrun( 'modal_aero_rename_init error' )
     end if
     if (iqfrm .le. 0) goto 1430
     if ((lsfrmc .lt. 1) .or. (lsfrmc .gt. pcnst)) then
  write(lunout,9102) mfrm, iqfrm, lsfrmc
  call endrun( 'modal_aero_rename_init error' )
     end if
     iqfrm_aa = 1
     iqtoo_aa = 1
     if (iqfrm .gt. nspec_amode(mfrm)) then
  iqfrm_aa = nspec_amode(mfrm) + 1
  iqtoo_aa = nspec_amode(mtoo) + 1
     end if
     nsamefrm = 0
     do iq = iqfrm_aa, iqfrm
  if ( lspectype_amode(iq ,mfrm) .eq. &
             lspectype_amode(iqfrm,mfrm) ) then
      nsamefrm = nsamefrm + 1
  end if
     end do
     nsametoo = 0
     do iqtoo = iqtoo_aa, nspec_amode(mtoo)
  if ( lspectype_amode(iqtoo,mtoo) .eq. &
             lspectype_amode(iqfrm,mfrm) ) then
      nsametoo = nsametoo + 1
      if (nsametoo .eq. nsamefrm) then
   lstooc = lmassptrcw_amode(iqtoo,mtoo)
   lstooa = lmassptr_amode(iqtoo,mtoo)
   goto 1430
      end if
  end if
     end do
1430 nspec = nspec + 1
     if ((lstooc .lt. 1) .or. (lstooc .gt. pcnst)) lstooc = 0
     if ((lstooa .lt. 1) .or. (lstooa .gt. pcnst)) lstooa = 0
     if (lstooa .eq. 0) then
  write(lunout,9104) mfrm, iqfrm, lsfrma, iqtoo, lstooa
  call endrun( 'modal_aero_rename_init error' )
     end if
     if ((lstooc .eq. 0) .and. (iqfrm .ne. 0)) then
  write(lunout,9104) mfrm, iqfrm, lsfrmc, iqtoo, lstooc
  call endrun( 'modal_aero_rename_init error' )
     end if
     lspecfrma_renamexf(nspec,ipair) = lsfrma
     lspectooa_renamexf(nspec,ipair) = lstooa
     lspecfrmc_renamexf(nspec,ipair) = lsfrmc
     lspectooc_renamexf(nspec,ipair) = lstooc
1490 continue
 nspecfrm_renamexf(ipair) = nspec
1900 continue
9100 format( / '*** subr. modal_aero_rename_init' / &
       'lspecfrma out of range' / &
       'modefrm, ispecfrm, lspecfrma =', 3i6 / )
9102 format( / '*** subr. modal_aero_rename_init' / &
       'lspecfrmc out of range' / &
       'modefrm, ispecfrm, lspecfrmc =', 3i6 / )
9104 format( / '*** subr. modal_aero_rename_init' / &
       'lspectooa out of range' / &
       'modefrm, ispecfrm, lspecfrma, ispectoo, lspectooa =', 5i6 / )
9106 format( / '*** subr. modal_aero_rename_init' / &
       'lspectooc out of range' / &
       'modefrm, ispecfrm, lspecfrmc, ispectoo, lspectooc =', 5i6 / )
 if ( masterproc ) then
 write(lunout,9310)
 do 2900 ipair = 1, npair_renamexf
 mfrm = modefrm_renamexf(ipair)
 mtoo = modetoo_renamexf(ipair)
 write(lunout,9320) ipair, mfrm, mtoo
 do iq = 1, nspecfrm_renamexf(ipair)
     lsfrma = lspecfrma_renamexf(iq,ipair)
     lstooa = lspectooa_renamexf(iq,ipair)
     lsfrmc = lspecfrmc_renamexf(iq,ipair)
     lstooc = lspectooc_renamexf(iq,ipair)
     if (lstooa .gt. 0) then
  write(lunout,9330) lsfrma, cnst_name(lsfrma), &
       lstooa, cnst_name(lstooa)
     else
  write(lunout,9340) lsfrma, cnst_name(lsfrma)
     end if
     if (lstooc .gt. 0) then
  write(lunout,9330) lsfrmc, cnst_name_cw(lsfrmc), &
       lstooc, cnst_name_cw(lstooc)
     else if (lsfrmc .gt. 0) then
  write(lunout,9340) lsfrmc, cnst_name_cw(lsfrmc)
     else
  write(lunout,9350)
     end if
 end do
2900 continue
 write(lunout,*)
 end if
9310 format( / 'subr. modal_aero_rename_init' )
9320 format( 'pair', i3, 5x, 'mode', i3, ' ---> mode', i3 )
9330 format( 5x, 'spec', i3, '=', a, ' ---> spec', i3, '=', a )
9340 format( 5x, 'spec', i3, '=', a, ' ---> LOSS' )
9350 format( 5x, 'no corresponding activated species' )
 return
 end subroutine modal_aero_rename_init
   end module modal_aero_rename


!-------------------------------------------------------------------------------
!>
!! 3D Operator module
!!
!! @par Description
!!         This module contains the subroutines for differential oeprators using vertical metrics.
!!
!! @author  H.Tomita
!!
!! @par History
!! @li      2004-02-17 (H.Tomita)    Imported from igdc-4.33
!! @li      2011-09-27 (T.Seiki)     merge optimization by RIST and M.Terai
!!
!<
module mod_oprt3d
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use mod_precision
  use mod_misc
!ESC!  use mod_stdio
!ESC!  use mod_prof
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: OPRT3D_divdamp

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine OPRT3D_divdamp( &
       ddivdx,    ddivdx_pl,    &
       ddivdy,    ddivdy_pl,    &
       ddivdz,    ddivdz_pl,    &
       rhogvx,    rhogvx_pl,    &
       rhogvy,    rhogvy_pl,    &
       rhogvz,    rhogvz_pl,    &
       rhogw,     rhogw_pl,     &
       coef_intp, coef_intp_pl, &
       coef_diff, coef_diff_pl, &
       RGSQRTH,   RGSQRTH_pl,   &
       RGAM,      RGAM_pl,      &
       RGAMH,     RGAMH_pl,     &
       C2WfactGz, C2WfactGz_pl  )
!ESC!    use mod_adm, only: &
!ESC!       TI  => ADM_TI,  &
!ESC!       TJ  => ADM_TJ,  &
!ESC!       ADM_nxyz,       &
!ESC!       ADM_have_pl,    &
!ESC!       ADM_have_sgp,   &
!ESC!       ADM_vlink,      &
!ESC!       ADM_lall,       &
!ESC!       ADM_lall_pl,    &
!ESC!       ADM_kall,       &
!ESC!       ADM_jall,       &
!ESC!       ADM_iall,       &
!ESC!       ADM_gall_pl,    &
!ESC!       ADM_jmin,       &
!ESC!       ADM_jmax,       &
!ESC!       ADM_imin,       &
!ESC!       ADM_imax,       &
!ESC!       ADM_gslf_pl,    &
!ESC!       ADM_gmin_pl,    &
!ESC!       ADM_gmax_pl,    &
!ESC!       ADM_kmin,       &
!ESC!       ADM_kmax
!ESC!    use mod_grd, only: &
!ESC!       XDIR => GRD_XDIR, &
!ESC!       YDIR => GRD_YDIR, &
!ESC!       ZDIR => GRD_ZDIR, &
!ESC!       GRD_rdgz
    implicit none

    real(RP), intent(out) :: ddivdx      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   ) ! tendency
    real(RP), intent(out) :: ddivdx_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(out) :: ddivdy      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   )
    real(RP), intent(out) :: ddivdy_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(out) :: ddivdz      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   )
    real(RP), intent(out) :: ddivdz_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: rhogvx      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   ) ! rho*vx { gam2 x G^1/2 }
    real(RP), intent(in)  :: rhogvx_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: rhogvy      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   ) ! rho*vy { gam2 x G^1/2 }
    real(RP), intent(in)  :: rhogvy_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: rhogvz      (ADM_iall,ADM_jall,ADM_kall,ADM_lall   ) ! rho*vz { gam2 x G^1/2 }
    real(RP), intent(in)  :: rhogvz_pl   (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: rhogw       (ADM_iall,ADM_jall,ADM_kall,ADM_lall   ) ! rho*w  { gam2 x G^1/2 }
    real(RP), intent(in)  :: rhogw_pl    (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
!    real(RP), intent(in)  :: coef_intp   (ADM_nxyz,ADM_gall   ,1:3,TI:TJ,ADM_lall   )
!    real(RP), intent(in)  :: coef_intp_pl(ADM_nxyz,ADM_gall_pl,1:3,      ADM_lall_pl)
!    real(RP), intent(in)  :: coef_diff   (ADM_nxyz,ADM_gall,1:6        ,ADM_lall   )
!    real(RP), intent(in)  :: coef_diff_pl(ADM_nxyz,         1:ADM_vlink,ADM_lall_pl)
    real(RP), intent(in)  :: coef_intp   (ADM_iall,ADM_jall,1:3        ,ADM_nxyz,TI:TJ,ADM_lall   )
    real(RP), intent(in)  :: coef_intp_pl(ADM_gall_pl      ,1:3        ,ADM_nxyz,      ADM_lall_pl)
    real(RP), intent(in)  :: coef_diff   (ADM_iall,ADM_jall,1:6        ,ADM_nxyz,      ADM_lall   )
    real(RP), intent(in)  :: coef_diff_pl(                  1:ADM_vlink,ADM_nxyz,      ADM_lall_pl)
    real(RP), intent(in)  :: RGSQRTH     (ADM_iall,ADM_jall,ADM_kall,ADM_lall   )
    real(RP), intent(in)  :: RGSQRTH_pl  (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: RGAM        (ADM_iall,ADM_jall,ADM_kall,ADM_lall   )
    real(RP), intent(in)  :: RGAM_pl     (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: RGAMH       (ADM_iall,ADM_jall,ADM_kall,ADM_lall   )
    real(RP), intent(in)  :: RGAMH_pl    (ADM_gall_pl      ,ADM_kall,ADM_lall_pl)
    real(RP), intent(in)  :: C2WfactGz   (ADM_iall,ADM_jall,ADM_kall,6,ADM_lall   )
    real(RP), intent(in)  :: C2WfactGz_pl(ADM_gall_pl      ,ADM_kall,6,ADM_lall_pl)

    real(RP) :: sclt   (ADM_iall,ADM_jall,TI:TJ) ! scalar on the hexagon vertex
    real(RP) :: sclt_pl(ADM_gall_pl      )
    real(RP) :: sclt_rhogw
    real(RP) :: sclt_rhogw_pl

    real(RP) :: rhogvx_vm   (ADM_iall,ADM_jall)          ! rho*vx / vertical metrics
    real(RP) :: rhogvx_vm_pl(ADM_gall_pl      )
    real(RP) :: rhogvy_vm   (ADM_iall,ADM_jall)          ! rho*vy / vertical metrics
    real(RP) :: rhogvy_vm_pl(ADM_gall_pl      )
    real(RP) :: rhogvz_vm   (ADM_iall,ADM_jall)          ! rho*vz / vertical metrics
    real(RP) :: rhogvz_vm_pl(ADM_gall_pl      )
    real(RP) :: rhogw_vm    (ADM_iall,ADM_jall,ADM_kall) ! rho*w  / vertical metrics
    real(RP) :: rhogw_vm_pl (ADM_gall_pl      ,ADM_kall)

    integer  :: imin, imax, jmin, jmax, kall, kmin, kmax, lall
    integer  :: ij, ijp1, ijm1

    integer  :: i, j, k, l, n, v
    !---------------------------------------------------------------------------

    call DEBUG_rapstart('OPRT3D_divdamp')

    imin = ADM_imin
    imax = ADM_imax
    jmin = ADM_jmin
    jmax = ADM_jmax
    kall = ADM_kall
    kmin = ADM_kmin
    kmax = ADM_kmax
    lall = ADM_lall

    !$omp parallel default(none),private(i,j,k,l,sclt_rhogw), &
    !$omp shared(imin,imax,jmin,jmax,kall,kmin,kmax,lall,ADM_have_sgp,GRD_rdgz, &
    !$omp ddivdx,ddivdy,ddivdz,rhogvx,rhogvy,rhogvz,rhogw,sclt,coef_intp,coef_diff, &
    !$omp rhogvx_vm,rhogvy_vm,rhogvz_vm,rhogw_vm,C2WfactGz,RGAMH,RGSQRTH,RGAM)
    do l = 1, lall

       !$omp do schedule(static)
       do k = kmin+1, kmax
       do j = jmin-1, jmax+1
       do i = imin-1, imax+1
          rhogw_vm(i,j,k) = ( C2WfactGz(i,j,k,1,l) * rhogvx(i,j,k  ,l) &
                            + C2WfactGz(i,j,k,2,l) * rhogvx(i,j,k-1,l) &
                            + C2WfactGz(i,j,k,3,l) * rhogvy(i,j,k  ,l) &
                            + C2WfactGz(i,j,k,4,l) * rhogvy(i,j,k-1,l) &
                            + C2WfactGz(i,j,k,5,l) * rhogvz(i,j,k  ,l) &
                            + C2WfactGz(i,j,k,6,l) * rhogvz(i,j,k-1,l) &
                            ) * RGAMH(i,j,k,l)                         & ! horizontal contribution
                          + rhogw(i,j,k,l) * RGSQRTH(i,j,k,l)            ! vertical   contribution
       enddo
       enddo
       enddo
       !$omp end do

       !$omp do schedule(static)
       do j = jmin-1, jmax+1
       do i = imin-1, imax+1
          rhogw_vm(i,j,kmin  ) = 0.0_RP
          rhogw_vm(i,j,kmax+1) = 0.0_RP
       enddo
       enddo
       !$omp end do

       do k = kmin, kmax

          !$omp do schedule(static)
          do j = jmin-1, jmax+1
          do i = imin-1, imax+1
             rhogvx_vm(i,j) = rhogvx(i,j,k,l) * RGAM(i,j,k,l)
             rhogvy_vm(i,j) = rhogvy(i,j,k,l) * RGAM(i,j,k,l)
             rhogvz_vm(i,j) = rhogvz(i,j,k,l) * RGAM(i,j,k,l)
          enddo
          enddo
          !$omp end do

          !$omp do schedule(static)
          do j = jmin-1, jmax
          do i = imin-1, imax
             sclt_rhogw = ( ( rhogw_vm(i,j,k+1) + rhogw_vm(i+1,j,k+1) + rhogw_vm(i+1,j+1,k+1) ) &
                          - ( rhogw_vm(i,j,k  ) + rhogw_vm(i+1,j,k  ) + rhogw_vm(i+1,j+1,k  ) ) &
                          ) / 3.0_RP * GRD_rdgz(k)

             sclt(i,j,TI) = coef_intp(i,j,1,XDIR,TI,l) * rhogvx_vm(i  ,j  ) &
                          + coef_intp(i,j,2,XDIR,TI,l) * rhogvx_vm(i+1,j  ) &
                          + coef_intp(i,j,3,XDIR,TI,l) * rhogvx_vm(i+1,j+1) &
                          + coef_intp(i,j,1,YDIR,TI,l) * rhogvy_vm(i  ,j  ) &
                          + coef_intp(i,j,2,YDIR,TI,l) * rhogvy_vm(i+1,j  ) &
                          + coef_intp(i,j,3,YDIR,TI,l) * rhogvy_vm(i+1,j+1) &
                          + coef_intp(i,j,1,ZDIR,TI,l) * rhogvz_vm(i  ,j  ) &
                          + coef_intp(i,j,2,ZDIR,TI,l) * rhogvz_vm(i+1,j  ) &
                          + coef_intp(i,j,3,ZDIR,TI,l) * rhogvz_vm(i+1,j+1) &
                          + sclt_rhogw
          enddo
          enddo
          !$omp end do nowait

          !$omp do schedule(static)
          do j = jmin-1, jmax
          do i = imin-1, imax
             sclt_rhogw = ( ( rhogw_vm(i,j,k+1) + rhogw_vm(i+1,j+1,k+1) + rhogw_vm(i,j+1,k+1) ) &
                          - ( rhogw_vm(i,j,k  ) + rhogw_vm(i+1,j+1,k  ) + rhogw_vm(i,j+1,k  ) ) &
                          ) / 3.0_RP * GRD_rdgz(k)

             sclt(i,j,TJ) = coef_intp(i,j,1,XDIR,TJ,l) * rhogvx_vm(i  ,j  ) &
                          + coef_intp(i,j,2,XDIR,TJ,l) * rhogvx_vm(i+1,j+1) &
                          + coef_intp(i,j,3,XDIR,TJ,l) * rhogvx_vm(i  ,j+1) &
                          + coef_intp(i,j,1,YDIR,TJ,l) * rhogvy_vm(i  ,j  ) &
                          + coef_intp(i,j,2,YDIR,TJ,l) * rhogvy_vm(i+1,j+1) &
                          + coef_intp(i,j,3,YDIR,TJ,l) * rhogvy_vm(i  ,j+1) &
                          + coef_intp(i,j,1,ZDIR,TJ,l) * rhogvz_vm(i  ,j  ) &
                          + coef_intp(i,j,2,ZDIR,TJ,l) * rhogvz_vm(i+1,j+1) &
                          + coef_intp(i,j,3,ZDIR,TJ,l) * rhogvz_vm(i  ,j+1) &
                          + sclt_rhogw
          enddo
          enddo
          !$omp end do

          if ( ADM_have_sgp(l) ) then ! pentagon
             sclt(imin-1,jmin-1,TI) = sclt(imin,jmin-1,TJ)
          endif

          !$omp do schedule(static)
          do j = jmin, jmax
          do i = imin, imax
             ddivdx(i,j,k,l) = coef_diff(i,j,1,XDIR,l) * ( sclt(i  ,j  ,TI) + sclt(i  ,j  ,TJ) ) &
                             + coef_diff(i,j,2,XDIR,l) * ( sclt(i  ,j  ,TJ) + sclt(i-1,j  ,TI) ) &
                             + coef_diff(i,j,3,XDIR,l) * ( sclt(i-1,j  ,TI) + sclt(i-1,j-1,TJ) ) &
                             + coef_diff(i,j,4,XDIR,l) * ( sclt(i-1,j-1,TJ) + sclt(i-1,j-1,TI) ) &
                             + coef_diff(i,j,5,XDIR,l) * ( sclt(i-1,j-1,TI) + sclt(i  ,j-1,TJ) ) &
                             + coef_diff(i,j,6,XDIR,l) * ( sclt(i  ,j-1,TJ) + sclt(i  ,j  ,TI) )
          enddo
          enddo
          !$omp end do nowait

          !$omp do schedule(static)
          do j = jmin, jmax
          do i = imin, imax
             ddivdy(i,j,k,l) = coef_diff(i,j,1,YDIR,l) * ( sclt(i  ,j  ,TI) + sclt(i  ,j  ,TJ) ) &
                             + coef_diff(i,j,2,YDIR,l) * ( sclt(i  ,j  ,TJ) + sclt(i-1,j  ,TI) ) &
                             + coef_diff(i,j,3,YDIR,l) * ( sclt(i-1,j  ,TI) + sclt(i-1,j-1,TJ) ) &
                             + coef_diff(i,j,4,YDIR,l) * ( sclt(i-1,j-1,TJ) + sclt(i-1,j-1,TI) ) &
                             + coef_diff(i,j,5,YDIR,l) * ( sclt(i-1,j-1,TI) + sclt(i  ,j-1,TJ) ) &
                             + coef_diff(i,j,6,YDIR,l) * ( sclt(i  ,j-1,TJ) + sclt(i  ,j  ,TI) )
          enddo
          enddo
          !$omp end do nowait

          !$omp do schedule(static)
          do j = jmin, jmax
          do i = imin, imax
             ddivdz(i,j,k,l) = coef_diff(i,j,1,ZDIR,l) * ( sclt(i  ,j  ,TI) + sclt(i  ,j  ,TJ) ) &
                             + coef_diff(i,j,2,ZDIR,l) * ( sclt(i  ,j  ,TJ) + sclt(i-1,j  ,TI) ) &
                             + coef_diff(i,j,3,ZDIR,l) * ( sclt(i-1,j  ,TI) + sclt(i-1,j-1,TJ) ) &
                             + coef_diff(i,j,4,ZDIR,l) * ( sclt(i-1,j-1,TJ) + sclt(i-1,j-1,TI) ) &
                             + coef_diff(i,j,5,ZDIR,l) * ( sclt(i-1,j-1,TI) + sclt(i  ,j-1,TJ) ) &
                             + coef_diff(i,j,6,ZDIR,l) * ( sclt(i  ,j-1,TJ) + sclt(i  ,j  ,TI) )
          enddo
          enddo
          !$omp end do nowait

          !$omp workshare
          ddivdx(:,jmin-1,k,l) = 0.0_RP
          ddivdy(:,jmin-1,k,l) = 0.0_RP
          ddivdz(:,jmin-1,k,l) = 0.0_RP
          ddivdx(:,jmax+1,k,l) = 0.0_RP
          ddivdy(:,jmax+1,k,l) = 0.0_RP
          ddivdz(:,jmax+1,k,l) = 0.0_RP
          ddivdx(imin-1,:,k,l) = 0.0_RP
          ddivdy(imin-1,:,k,l) = 0.0_RP
          ddivdz(imin-1,:,k,l) = 0.0_RP
          ddivdx(imax+1,:,k,l) = 0.0_RP
          ddivdy(imax+1,:,k,l) = 0.0_RP
          ddivdz(imax+1,:,k,l) = 0.0_RP
          !$omp end workshare
       enddo

       !$omp workshare
       ddivdx(:,:,kmin-1,l) = 0.0_RP
       ddivdx(:,:,kmax+1,l) = 0.0_RP
       ddivdy(:,:,kmin-1,l) = 0.0_RP
       ddivdy(:,:,kmax+1,l) = 0.0_RP
       ddivdz(:,:,kmin-1,l) = 0.0_RP
       ddivdz(:,:,kmax+1,l) = 0.0_RP
       !$omp end workshare
    enddo ! l loop
    !$omp end parallel

    if ( ADM_have_pl ) then
       do l = 1, ADM_lall_pl
          do k = ADM_kmin+1, ADM_kmax
          do ij = 1, ADM_gall_pl
             rhogw_vm_pl(ij,k) = ( C2WfactGz_pl(ij,k,1,l) * rhogvx_pl(ij,k  ,l) &
                                 + C2WfactGz_pl(ij,k,2,l) * rhogvx_pl(ij,k-1,l) &
                                 + C2WfactGz_pl(ij,k,3,l) * rhogvy_pl(ij,k  ,l) &
                                 + C2WfactGz_pl(ij,k,4,l) * rhogvy_pl(ij,k-1,l) &
                                 + C2WfactGz_pl(ij,k,5,l) * rhogvz_pl(ij,k  ,l) &
                                 + C2WfactGz_pl(ij,k,6,l) * rhogvz_pl(ij,k-1,l) &
                                 ) * RGAMH_pl(ij,k,l)                           & ! horizontal contribution
                               + rhogw_pl(ij,k,l) * RGSQRTH_pl(ij,k,l)            ! vertical   contribution
          enddo
          enddo
          do ij = 1, ADM_gall_pl
             rhogw_vm_pl(ij,ADM_kmin  ) = 0.0_RP
             rhogw_vm_pl(ij,ADM_kmax+1) = 0.0_RP
          enddo

          n = ADM_gslf_pl

          do k = ADM_kmin, ADM_kmax
             do v = 1, ADM_gall_pl
                rhogvx_vm_pl(v) = rhogvx_pl(v,k,l) * RGAM_pl(v,k,l)
                rhogvy_vm_pl(v) = rhogvy_pl(v,k,l) * RGAM_pl(v,k,l)
                rhogvz_vm_pl(v) = rhogvz_pl(v,k,l) * RGAM_pl(v,k,l)
             enddo

             do v = ADM_gmin_pl, ADM_gmax_pl
                ij   = v
                ijp1 = v + 1
                if( ijp1 == ADM_gmax_pl+1 ) ijp1 = ADM_gmin_pl

                sclt_rhogw_pl = ( ( rhogw_vm_pl(n,k+1) + rhogw_vm_pl(ij,k+1) + rhogw_vm_pl(ijp1,k+1) ) &
                                - ( rhogw_vm_pl(n,k  ) + rhogw_vm_pl(ij,k  ) + rhogw_vm_pl(ijp1,k  ) ) &
                                ) / 3.0_RP * GRD_rdgz(k)

                sclt_pl(ij) = coef_intp_pl(v,1,XDIR,l) * rhogvx_vm_pl(n   ) &
                            + coef_intp_pl(v,2,XDIR,l) * rhogvx_vm_pl(ij  ) &
                            + coef_intp_pl(v,3,XDIR,l) * rhogvx_vm_pl(ijp1) &
                            + coef_intp_pl(v,1,YDIR,l) * rhogvy_vm_pl(n   ) &
                            + coef_intp_pl(v,2,YDIR,l) * rhogvy_vm_pl(ij  ) &
                            + coef_intp_pl(v,3,YDIR,l) * rhogvy_vm_pl(ijp1) &
                            + coef_intp_pl(v,1,ZDIR,l) * rhogvz_vm_pl(n   ) &
                            + coef_intp_pl(v,2,ZDIR,l) * rhogvz_vm_pl(ij  ) &
                            + coef_intp_pl(v,3,ZDIR,l) * rhogvz_vm_pl(ijp1) &
                            + sclt_rhogw_pl
             enddo

             ddivdx_pl(:,k,l) = 0.0_RP
             ddivdy_pl(:,k,l) = 0.0_RP
             ddivdz_pl(:,k,l) = 0.0_RP

             do v = ADM_gmin_pl, ADM_gmax_pl
                ij   = v
                ijm1 = v - 1
                if( ijm1 == ADM_gmin_pl-1 ) ijm1 = ADM_gmax_pl ! cyclic condition

                ddivdx_pl(n,k,l) = ddivdx_pl(n,k,l) + coef_diff_pl(v-1,XDIR,l) * ( sclt_pl(ijm1) + sclt_pl(ij) )
                ddivdy_pl(n,k,l) = ddivdy_pl(n,k,l) + coef_diff_pl(v-1,YDIR,l) * ( sclt_pl(ijm1) + sclt_pl(ij) )
                ddivdz_pl(n,k,l) = ddivdz_pl(n,k,l) + coef_diff_pl(v-1,ZDIR,l) * ( sclt_pl(ijm1) + sclt_pl(ij) )
             enddo
          enddo

          do ij = 1, ADM_gall_pl
             ddivdx_pl(ij,ADM_kmin-1,l) = 0.0_RP
             ddivdx_pl(ij,ADM_kmax+1,l) = 0.0_RP
             ddivdy_pl(ij,ADM_kmin-1,l) = 0.0_RP
             ddivdy_pl(ij,ADM_kmax+1,l) = 0.0_RP
             ddivdz_pl(ij,ADM_kmin-1,l) = 0.0_RP
             ddivdz_pl(ij,ADM_kmax+1,l) = 0.0_RP
          enddo
       enddo
    else
       ddivdx_pl(:,:,:) = 0.0_RP
       ddivdy_pl(:,:,:) = 0.0_RP
       ddivdz_pl(:,:,:) = 0.0_RP
    endif

    call DEBUG_rapend('OPRT3D_divdamp')

    return
  end subroutine OPRT3D_divdamp

end module mod_oprt3d
!-------------------------------------------------------------------------------


      subroutine SPULreadhdr(istat)
c=======================================================================
c   Routine to read the header records on the spulses/WSRT polarimerty
c   data stored on ascii files.  The header records comprise four lines
c   at the top of each data file.  Data are read on lfn 41.
c
c   JMR --9 Febr 1995
c   JMR --27 Mar 2001 adapted from P110readhdr
c   JMR --1 Jan 2005 attempt to fix MJD conversion
c=======================================================================
      integer date,startime,arecnum,nscan,aposcrd,admptim,istat,
     .admplen,admpsrd,ainttim,aextst,apoladd,anumsbc,alensbc,
     .apbins,admptot,anrecscn,aendscan,apbinsmax,controlword
      parameter (apbinsmax=2048)
      common/header/ period,samint,scantime,date,startime,arecnum,nscan,
     .aendscan,abandwd,aposcrd,apos1st,apos2st,aazst,za,azaend,aclkrat,
     .admptim,admplen,admpsrd,ainttim,aextst,obfreq,apoladd,anumsbc,
     .alensbc,apbins,adm,arm,abintot,admptot,abtwscn,scaleI,sigmaI,
     .abbm3lo,abbm4lo,asynfreq,anrecscn,rm,erm,aver,source,controlword,
     .nwins,nwbins(5),wndows,sver,nseq,obsvtry
      real abandwd,apos1st,apos2st,aazst,za,azaend,aclkrat,
     .obfreq,adm,arm,abintot,abtwscn,scaleI,sigmaI,abbm3lo,
     .abbm4lo,asynfreq,rm,erm
      real*8 period,samint,scantime,jdate
      character*3 aver,sver
      character source*9,obsvtry*11
      character*12 datum
      character wndows*5
      integer obsdat
c
      istat=0
      ibug=1
      read(41,*,err=12)npulses,apbins,delphi,ntypes
      ibug=2
      read(41,'(a)',err=12) datum
      source=datum(1:9)
      if(datum(1:1).eq." ") source=datum(2:10)
      ibug=3
      read(41,'(a)',err=12) datum
      obsvtry=datum(1:11)
      if(datum(1:1).eq." ") obsvtry=datum(2:12)
      ibug=4
      read(41,*,err=12)nscan,nskip,freq,bwd,period,scantime
c
c     if(ntypes.ne.4) then
c       write(*,*) "Total power observations only?!?"
        aposcrd=ntypes
c       stop
c     end if
c
c Define quantitites
      obfreq=freq
      obsdat=scantime
      jdate=obsdat+2400000.5-2440000.
c     write(*,*) scantime,jdate
      call juldate(1,im,id,iy,jdate)
c     write(*,*) "SPULreadhdr: ",id,im,iy
      if(iy.lt.2000) then
        iy=iy-1900
      else
        iy=iy-2000
      end if
      if(iy.eq.100) iy=0
      call dayyear(im,id,iy,idn)
      date=idn*100+iy
c     write(*,*) iy,idn,obsdat
      stime=scantime-obsdat
      startime=stime*86400.
c     write(*,*) startime
      samint=(delphi*period/360.)*apbins/period
      abandwd=bwd
      admptim=period*delphi*1.E6/360.
      adm=dm
      arm=rm
      wndows="P    "
      nwins=1
      nwbins(1)=apbins
      scaleI=1000.
c     write(*,*) source,obfreq,samint,apbins,abandwd,admptim,adm,arm
      anumsbc=4
      alensbc=1
      return
   12 istat=ibug
      return
      end


!
!       Code for MC move addaptations when you need to
!       adapt both move size and number of beads.
!
!           Quinn MacPherson
!

Subroutine mc_adapt(wlc_p,MCTYPE)
! values from wlcsim_data
use params, only: wlc_SUCCESS, wlc_ATTEMPTS, wlc_WindoW, wlc_PHIT, wlc_MCAMP
! Run this after say 1000 move in order to improve performance
    !use mt19937, only : grnd
    use params
    implicit none
    TYPE(wlcsim_params), intent(in) :: wlc_p
    integer, intent(in) :: MCTYPE   ! Type of move

    if(wlc_ATTEMPTS(MCTYPE) < 10) then
        return
    endif

!   Change the position if appropriate
    wlc_PHIT(MCTYPE) = real(wlc_SUCCESS(MCTYPE),dp) &
                        /real(wlc_ATTEMPTS(MCTYPE),dp)

    wlc_SUCCESS(MCTYPE) = 0
    wlc_ATTEMPTS(MCTYPE) = 0

    if ((MCTYPE.eq.8).or.(MCTYPE.eq.9).or.(MCTYPE.eq.10).or.(MCTYPE.eq.11)) then
        return
    endif

    ! If move type has no amplitude then only ajust window
    if (MCTYPE.eq.7) then
        if (wlc_PHIT(MCTYPE) > wlc_p%PDESIRE(MCTYPE)) then
           wlc_WindoW(MCTYPE) = wlc_WindoW(MCTYPE)*1.05_dp
        else
           wlc_WindoW(MCTYPE) = wlc_WindoW(MCTYPE)*0.95_dp
        endif
        !window limits
        if (wlc_WindoW(MCTYPE) < wlc_p%MINWINDOW(MCTYPE)) then
           wlc_WindoW(MCTYPE) = wlc_p%MINWINDOW(MCTYPE)
        elseif (wlc_WindoW(MCTYPE) > wlc_p%MAXWINDOW(MCTYPE)) then
           wlc_WindoW(MCTYPE) = wlc_p%MAXWINDOW(MCTYPE)
        endif
        return
    endif

    ! If move has no window it doesn't need to be ajusted
    if ((MCTYPE.eq.4) .or. &
        (MCTYPE.eq.5) .or. &
        (MCTYPE.eq.6) .or. &
        (MCTYPE.eq.12)) then
        ! Adjust Amplidtude
        if (wlc_PHIT(MCTYPE) > wlc_p%PDESIRE(MCTYPE)) then
           wlc_MCAMP(MCTYPE) = wlc_MCAMP(MCTYPE)*1.05_dp
        else
           wlc_MCAMP(MCTYPE) = wlc_MCAMP(MCTYPE)*0.95_dp
        endif
        ! amplitude limits
        if (wlc_MCAMP(MCTYPE) > wlc_p%MAXAMP(MCTYPE)) then
           wlc_MCAMP(MCTYPE) = wlc_p%MAXAMP(MCTYPE)
        elseif (wlc_MCAMP(MCTYPE) < wlc_p%MINAMP(MCTYPE)) then
           wlc_MCAMP(MCTYPE) = wlc_p%MINAMP(MCTYPE)
        endif
        return
    endif

    ! Adjust Amplidtude
    if (wlc_PHIT(MCTYPE) > wlc_p%PDESIRE(MCTYPE)) then
       wlc_MCAMP(MCTYPE) = wlc_MCAMP(MCTYPE)*1.05_dp
       wlc_WindoW(MCTYPE) = wlc_WindoW(MCTYPE)*1.05_dp
    else
       wlc_MCAMP(MCTYPE) = wlc_MCAMP(MCTYPE)*0.95_dp
       wlc_WindoW(MCTYPE) = wlc_WindoW(MCTYPE)*0.95_dp
    endif

    ! Drift to target window
    wlc_WindoW(MCTYPE) = wlc_WindoW(MCTYPE)*0.98_dp + &
                      0.02_dp*wlc_p%WINTARGET(MCTYPE)

    ! amplitude limits
    if (wlc_MCAMP(MCTYPE) > wlc_p%MAXAMP(MCTYPE)) then
       wlc_MCAMP(MCTYPE) = wlc_p%MAXAMP(MCTYPE)
    elseif (wlc_MCAMP(MCTYPE) < wlc_p%MINAMP(MCTYPE)) then
       wlc_MCAMP(MCTYPE) = wlc_p%MINAMP(MCTYPE)
    endif

    !window limits
    if (wlc_WindoW(MCTYPE) < wlc_p%MINWINDOW(MCTYPE)) then
       wlc_WindoW(MCTYPE) = wlc_p%MINWINDOW(MCTYPE)
    elseif (wlc_WindoW(MCTYPE) > wlc_p%MAXWINDOW(MCTYPE)) then
       wlc_WindoW(MCTYPE) = wlc_p%MAXWINDOW(MCTYPE)
    endif

end subroutine


      real*8 function coefdr(cdrs,ndrs,ndrsmx,ndrsr,nse,ns,nstmax)
c
c     This subroutine finds the coefficient of the nse-th species
c     in the reaction for the destruction of the ns-th species.
c
c     This subroutine is called by:
c
c       EQLIB/elim.f
c       EQLIB/ncmpex.f
c       EQLIB/switch.f
c       EQLIB/swtchb.f
c       EQLIB/swtchk.f
c       EQ3NR/arrset.f
c       EQ3NR/arrsim.f
c       EQ3NR/dawfix.f
c       EQ3NR/balcon.f
c       EQ3NR/betas.f
c       EQ3NR/eq3nr.f
c       EQ3NR/matrix.f
c       EQ3NR/scripx.f
c       EQ6/balcmz.f
c       EQ6/jgibbs.f
c       EQ6/matrxz.f
c       EQ6/mincsp.f
c       EQ6/scanlm.f
c       EQ6/tstrdx.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       cdrs   = array of reaction coefficients
c       ndrs   = array of indices of the species corresponding to the
c                  coefficients in the cdrs array
c       ndrsr  = array giving the range in the cdrs and ndrs arrays
c                  containing the reaction for a given species
c
c     Principal output:
c
c       coefdr = the reaction coefficient of the nse-th species in
c                  the reaction for the ns-th species
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ndrsmx,nstmax
c
      integer ndrs(ndrsmx),ndrsr(2,nstmax)
      integer nse,ns
c
      real*8 cdrs(ndrsmx)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer n,n1,n2
c
c-----------------------------------------------------------------------
c
      coefdr = 0.
c
      n1 = ndrsr(1,ns)
      n2 = ndrsr(2,ns)
      do n = n1,n2
        if (nse .eq. ndrs(n)) then
          coefdr = cdrs(n)
          go to 999
        endif
      enddo
c
  999 continue
      end


module fock_cg_module

  implicit none

  private
  public :: Fock_CG_Double
  public :: Fock_CG_DoubleComplex

contains

  subroutine Fock_CG_Double( trho, tVh )
    use hartree_mol_module, only: calc_hartree_mol
    implicit none
    real(8),intent(in) :: trho(:)
    real(8),intent(inout) :: tVh(:)
    real(8) :: Edummy
    integer :: n1,n2
    n1 = 1
    n2 = size(trho)
    call calc_hartree_mol( n1, n2, 1, trho, tVh, Edummy, tol=1.d-8 )
    return
  end subroutine Fock_CG_Double

  subroutine Fock_CG_DoubleComplex( trho, tVh )
    implicit none
    complex(8),intent(in) :: trho(:)
    complex(8),intent(inout) :: tVh(:)
    call stop_program( 'Fock_CG_DoubleComplex is not implemented...' )
    return
  end subroutine Fock_CG_DoubleComplex

end module fock_cg_module


#include "../defines.inc"
subroutine mcsim(wlc_p)
!Perform Metropolis Hastings Monte Carlo moves on the system of polymers.
!Loops over move types (crank shaft, slide,...) and calls each energy
!function.  Accepts move by the Metropolis condition on the change in
!energy.  If accepted update system.

   use params, only: wlc_PHit, wlc_CrossP, wlc_ABP &
                     , wlc_DPHI_l2, wlc_AB, wlc_NCross &
                     , wlc_ind_exchange, wlc_inDPHI, wlc_rand_stat, wlc_Cross &
                     , wlc_Vol, wlc_PHI_l2, wlc_NPHI, wlc_DPHIB, wlc_ATTEMPTS &
                     , wlc_UP, wlc_CrossSize, wlc_NCrossP, wlc_R, wlc_SUCCESS &
                     , wlc_RP, wlc_METH, wlc_DPHIA, wlc_PHIB, printEnergies &
                     , wlcsim_params, wlc_PHIA, int_min, NAN, wlc_nBend, wlc_nPointsMoved &
                     , pack_as_para, nMoveTypes, wlc_pointsMoved, wlc_bendPoints &
                     , wlcsim_params_recenter, wlc_Lk0, wlc_Lk, wlc_Tw, wlc_Wr &
                     , wlc_VP, wlc_U, wlc_V, wlc_R_GJK, wlc_nucleosomeWrap, &
                     wlc_basepairs, wlc_basepairs_prop
   use energies
   use umbrella, only: umbrella_energy

   !use mt19937, only : grnd, sgrnd, rnorm, mt, mti
   use mersenne_twister
   use binning, only: addBead, removeBead
   use update_rU, only: update_r
   use polydispersity, only: length_of_chain, chain_ID, leftmost_from
   use linkingNumber, only: get_del_tw_wr_lk

   implicit none
   interface
      pure function list_confinement()
         logical list_confinement
      end function
   end interface

   !integer, intent(in) :: NSTEP             ! Number of MC steps

!   Variables for the simulation

   integer ISTEP             ! Current MC step index
   real(dp) PROB     ! Calculated test prob
   real(dp) TEST     ! Random test variable
   integer IB1               ! Test bead position 1
   integer IT1               ! Index of test bead 1
   integer IB2               ! Test bead position 2
   integer IT2               ! Index of test bead 2
   integer IT3, IT4          ! second polymer for polymer swap
   integer dib               ! number of beads moved in a move
   logical forward           ! direction of reptation move

   integer I, J, I_left

   integer MCTYPE                    ! Type of MC move

   real(dp) EB, EPAR, EPERP, ESELFP
   real(dp) GAM, ETA
   real(dp) XIR, XIU
   real(dp) LHC      ! Length of HC int
   real(dp) VHC      ! HC strength
!    real(dp) phiTot  ! for testing

   real(dp) ENERGY
! Things for random number generator
   real(dp) urnd(1) ! single random number
!   Load the input parameters
   Type(wlcsim_params), intent(inout) :: wlc_p      ! system varibles
   integer DELTA             !Alexander polynomial evaluated at t = -1; used for knot checking
   real(dp) para(10)
   integer m_index  ! m is the m from spherical harmonics (z component)
   integer sweepIndex
   logical collide
   logical success
   logical wlc_AlexanderP
   integer collisions

   real(dp) delTw      ! change in twist
   real(dp) delWr      ! change in writhe
   real(dp) delLk      ! change in linking number
   real(dp) TwP        ! twist of the proposed configuration
   real(dp) WrP        ! writhe of the proposed configuration
   real(dp) LkP        ! linking number of the proposed configuration
   logical netSterics  ! whether or not there are current collisions

! -------------------------------------
!
!   Begin Monte Carlo simulation
!
! -------------------------------------
   ISTEP = 1

   do while (ISTEP <= WLC_P__STEPSPEREXCHANGE)
      do MCTYPE = 1, nMoveTypes
         if (wlc_p%MOVEON(MCTYPE) == 0) cycle
         do sweepIndex = 1, wlc_p%MOVESPERSTEP(MCTYPE)
            call set_all_dEnergy_to_zero()
            wlc_nPointsMoved = 0
            wlc_nBend = 0

            ! ------------------------------------------
            !
            !  Each energy function adds to applicable energyOf(*_)%dx.
            !  Many functions assume enertyOf(*_)%dx starts at zero.
            !
            !-------------------------------------------

            ! Turn down poor moves
            if ((wlc_PHit(MCTYPE) .lt. WLC_P__MIN_ACCEPT) .and. &
                (mod(ISTEP, WLC_P__REDUCE_MOVE) .ne. 0) .and. &
                ((MCTYPE .eq. 5) .or. (MCTYPE .eq. 6))) then
               goto 10 ! skip move, return RP to nan
            endif
            call mc_move(IB1, IB2, IT1, IT2, IT3, IT4, &
                         MCTYPE, forward, wlc_rand_stat, dib, success)
            if (.not. success) then
               wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
               goto 10 ! skip move, return RP to nan
            endif

!   Calculate the change in confinement energy
            if ((MCTYPE /= 4) .and. wlc_nPointsMoved > 0 .and. (MCTYPE /= 7)) then
               if (.not. list_confinement()) then
                  wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
                  success = .False.
                  goto 10 ! skip move, return RP to nan
               endif
            endif

            if (WLC_P__CYLINDRICAL_CHAIN_EXCLUSION) then
               call mc_cylinder(collide, IB1, IB2, IT1, IT2, MCTYPE, forward)
               if (collide) then
                  wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
                  goto 10 ! skip move, return RP to nan
               endif
            endif

            ! set wlc_basepairs to prop if not slide move
            if (MCTYPE /= 13 .AND. WLC_P__MOVEON_NUCLEOSOMESLIDE == 1) then
               wlc_basepairs_prop = wlc_basepairs
            endif

            ! sterics check here !
            if (WLC_P__GJK_STERICS) then
               if (energyOf(sterics_)%E == 0) then
                  netSterics = .false.
               else
                  netSterics = .true.
               endif
               call mc_sterics(collisions, netSterics, MCTYPE)
               ! ascribe collision penalty
               if (netSterics) then
                  energyOf(sterics_)%dx = collisions
               else
                  if (collisions > 0) then
                     wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
                     goto 10 ! skip move, return RP to nan
                  endif
               endif
            endif

            ! internucleosome check here !
            if (WLC_P__INTERNUCLEOSOME_ON) then
               call mc_internucleosome()
            endif

            call check_RP_for_NAN(success, MCTYPE)
            if (.not. success) then
               wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
               goto 10 ! skip move, return RP to nan
            endif

            wlc_AlexanderP = .FALSE.

            if (WLC_P__RING .and. WLC_P__TWIST) then
               if (wlc_AlexanderP) then !unsure if correct
                  wlc_CrossP = wlc_Cross
                  wlc_NCrossP = wlc_NCross
                  if (MCTYPE == 1) then !was MCTYPE == 1
                     CALL alexanderp_crank(wlc_p, wlc_RP, DELTA, wlc_CrossP, wlc_CrossSize, wlc_NCrossP, IT1, IT2, DIB)
                  elseif (MCTYPE == 2) then
                     if (DIB /= length_of_chain(chain_ID(IT1))) then
                        CALL alexanderp_slide(wlc_p, wlc_RP, DELTA, wlc_CrossP, wlc_CrossSize, wlc_NCrossP, IT1, IT2, DIB)
                     ENDif
                  else
                     CALL ALEXANDERP(wlc_RP, WLC_P__NB, DELTA, wlc_CrossP, wlc_CrossSize, wlc_NCrossP)
                  ENDif
               ENDif
               if (DELTA /= 1) then
                  wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
                  goto 10 ! skip move, return RP to nan
               ENDif
            ENDif
!   Calculate the change in compression and bending energy
            if (wlc_nBend > 0) then
               call mc_eelas(wlc_p)
               if (WLC_P__RING .AND. WLC_P__TWIST) then
                  print *, "Change this to new global twist energy!!!"
                  stop
                  call mc_global_twist(IT1, IT2, MCTYPE)
               endif
            endif

            if (MCTYPE .eq. 8) then
               print *, "Flop move not working!  Chain energy isn't symmetric"
               stop 1
            endif
!   Calculate the change in the binding energy
            if (WLC_P__CHANGINGCHEMICALIDENTITY .and. MCTYPE == 7 .or. MCTYPE == 11) then
               !print*, 'mcsim says EM:',EM,'EU',EU
               call mc_bind(IT1, IT2, wlc_AB, wlc_ABP, wlc_METH)
            endif
            if (WLC_P__INTERP_BEAD_LENNARD_JONES) then
               !TODO: unpack parameters in MC_elas
               para = pack_as_para(wlc_p)
               EB = PARA(1)
               EPAR = PARA(2)
               EPERP = PARA(3)
               GAM = PARA(4)
               ETA = PARA(5)
               XIR = PARA(6)
               XIU = PARA(7)
               LHC = PARA(9)
               VHC = PARA(10)

               !call mc_self(DESELF,wlc_R,wlc_U,wlc_RP,wlc_UP,WLC_P__NT,WLC_P__NB,WLC_P__NP,IP,IB1,IB2,IT1,IT2,LHC,VHC,LBOX,GAM)
               if (MCTYPE == 1) then
                  CALL de_self_crank(energyOf(self_)%dx, wlc_R, wlc_RP, WLC_P__NT, WLC_P__NB, WLC_P__NP, &
                                     para, WLC_P__RING, IB1, IB2)

               elseif (MCTYPE == 2) then
                  CALL energy_self_slide(energyOf(self_)%x, wlc_R, WLC_P__NT, WLC_P__NB, WLC_P__NP, &
                                         para, WLC_P__RING, IB1, IB2)
                  CALL energy_self_slide(ESELFP, wlc_R, WLC_P__NT, WLC_P__NB, WLC_P__NP, &
                                         para, WLC_P__RING, IB1, IB2)

                  energyOf(self_)%dx = ESELFP - energyOf(self_)%x
               elseif (MCTYPE == 3) then
                  CALL de_self_crank(energyOf(self_)%dx, wlc_R, wlc_RP, WLC_P__NT, WLC_P__NB, WLC_P__NP, &
                                     para, WLC_P__RING, IB1, IB2)
               endif
            endif

!   Calculate the change in the self-interaction energy (actually all
!   interation energy, not just self?)
            if (wlc_p%field_int_on_currently .and. WLC_P__FIELD_INT_ON) then
               if (MCTYPE == 7) then !
                  call mc_int_chem(wlc_p, IT1, IT2)
               elseif (MCTYPE == 10) then ! reptation move
                  call mc_int_rep(wlc_p, IT1, IT2, forward)
               elseif (MCTYPE == 11) then ! super reptation move
                  call mc_int_super_rep(wlc_p, IT1, IT2, forward)
               else ! motion of chain
                  call mc_int_update(wlc_p)
               endif
            endif

            if (WLC_P__APPLY_EXTERNAL_FIELD .and. energyOf(external_)%isOn &
                .and. wlc_nPointsMoved > 0 .and. MCTYPE .ne. 4 .and. (MCTYPE /= 7)) then
               call mc_external_field()
            endif

            if (WLC_P__APPLY_2body_potential .and. wlc_nPointsMoved > 0) then
               call mc_2bead_potential(MCTYPE)
            endif

            if (WLC_P__EXPLICIT_BINDING .and. wlc_nPointsMoved > 0 .and. MCTYPE .ne. 4 .and. (MCTYPE /= 7)) then
               call mc_explicit_binding()
            endif

            if (WLC_P__UMBRELLA .and. energyOf(umbrella_)%isOn &
                .and. wlc_nPointsMoved > 0 .and. MCTYPE .ne. 4 .and. (MCTYPE /= 7)) then
               call umbrella_energy()
            endif

            ! When self-crossing is not allowed, linking number must be conserved.
            if (WLC_P__NO_SELF_CROSSING) then
               call get_del_tw_wr_lk(IB1, IB2, MCTYPE, delTw, delWr, delLk)
               TwP = wlc_Tw + delTw
               WrP = wlc_Wr + delWr
               LkP = wlc_Lk + delLk
               if (abs(LkP - wlc_Lk0) > WLC_P__NO_CROSSING_CUTOFF) then
                  wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1
                  goto 10 ! skip move, return RP to nan
               endif
            endif

!   Change the position if appropriate
            call apply_energy_isOn()
            call calc_all_dE_from_dx()
            call sum_all_dEnergies(ENERGY)
            !call mc_save_energy_data(MCTYPE)
            PROB = exp(-ENERGY)
            call random_number(urnd, wlc_rand_stat)
            TEST = urnd(1)
            if (TEST <= PROB) then
               call accept_all_energies()
               if (MCTYPE == 7 .or. MCTYPE == 11) then
                  if (.not. WLC_P__CHANGINGCHEMICALIDENTITY) then
                     call stop_if_err(1, "Tried to change chemical Identity when you can't")
                  endif
                  do I = IT1, IT2
                     wlc_AB(I) = wlc_ABP(I)
                  ENDdo
               endif
               if (MCTYPE == 13 .AND. WLC_P__MOVEON_NUCLEOSOMESLIDE == 1) then
                  wlc_basepairs = wlc_basepairs_prop
               endif
               if (MCTYPE /= 7) then
                  do I = 1, wlc_nPointsMoved
                     J = wlc_pointsMoved(I)
                     call update_r(J)
                  enddo
               endif
               if (energyOf(confine_)%dE .gt. 0.0_dp) then
                  print *, "MCTYPE", MCType
                  call printEnergies()
                  print *, "error in mcsim, out of bounds "
                  stop 1
               endif
               if (wlc_p%field_int_on_currently .and. WLC_P__FIELD_INT_ON) then
                  do I = 1, wlc_NPHI
                     J = wlc_inDPHI(I)
                     if (WLC_P__CHI_L2_ABLE .and. energyOf(maierSaupe_)%isOn) then
                        do m_index = -2, 2
                           wlc_PHI_l2(m_index, J) = wlc_PHI_l2(m_index, J) + wlc_DPHI_l2(m_index, I)
                        enddo
                     endif
                     wlc_PHIA(J) = wlc_PHIA(J) + wlc_DPHIA(I)
                     wlc_PHIB(J) = wlc_PHIB(J) + wlc_DPHIB(I)

                     if ((wlc_PHIA(J) .lt. -0.0001_dp) .or. &
                         (wlc_PHIB(J) .lt. -0.00001_dp .and. (.not. WLC_P__TWO_TAIL))) then
                        print *, "IT1-4", IT1, IT2, IT3, IT4
                        if (WLC_P__FRACTIONAL_BIN) print *, "Vol", wlc_Vol(I)
                        print *, "MCTYPE", MCTYPE
                        print *, "DPHIA ", wlc_DPHIA(I), " DPHIB", wlc_DPHIB(I)
                        print *, "PHIA(J) ", wlc_PHIA(J), " PHIB(J) ", wlc_PHIB(J)
                        print *, "I", I, "J", J
                        print *, "Error in mcsim. Negative phi"
                        stop 1
                     endif
                  enddo
               endif
               if (WLC_P__RING) then
                  wlc_NCross = wlc_NCrossP
                  wlc_Cross = wlc_CrossP
               endif
               if (WLC_P__NO_SELF_CROSSING) then
                  wlc_Lk = LkP
                  wlc_Tw = TwP
                  wlc_Wr = WrP
               endif
               wlc_SUCCESS(MCTYPE) = wlc_SUCCESS(MCTYPE) + 1
            endif
            wlc_ATTEMPTS(MCTYPE) = wlc_ATTEMPTS(MCTYPE) + 1

10          continue

            !  vvvvvvvvvv Beginning of hold check vvvvvvvvvvvvvvvvvv
            if (isnan(ENERGY)) then
               print *, "Energy = NAN"
            endif
            !  It is now assumed that RP=R or nan after this.  Do not remove this loop.
            do J = 1, wlc_nPointsMoved
               I = wlc_pointsMoved(J)
               wlc_RP(1, I) = nan
               wlc_RP(2, I) = nan
               wlc_RP(3, I) = nan
               wlc_UP(1, I) = nan
               wlc_UP(2, I) = nan
               wlc_UP(3, I) = nan
               if (WLC_P__LOCAL_TWIST) then
                  wlc_VP(1, I) = nan
                  wlc_VP(2, I) = nan
                  wlc_VP(3, I) = nan
               endif
               if (WLC_P__VARIABLE_CHEM_STATE) then
                  wlc_ABP(I) = INT_MIN
               endif
            enddo

            if (.not. WLC_P__RING) then
               do J = 1, wlc_nBend
                  I = wlc_bendPoints(J)
                  wlc_RP(:, I:I + 1) = nan
                  wlc_UP(:, I:I + 1) = nan
                  if (WLC_P__LOCAL_TWIST) wlc_VP(:, I:I + 1) = nan
                  if (WLC_P__VARIABLE_CHEM_STATE) then
                     wlc_ABP(I:I + 1) = INT_MIN
                  endif
               enddo
            else
               do J = 1, wlc_nBend
                  I = wlc_bendPoints(J)
                  if (I == length_of_chain(chain_ID(IT1))) then
                     I_left = leftmost_from(IT1)
                     wlc_RP(:, I) = nan
                     wlc_RP(:, I_left) = nan
                     wlc_UP(:, I) = nan
                     wlc_UP(:, I_left) = nan
                  else
                     wlc_RP(:, I:I + 1) = nan
                     wlc_UP(:, I:I + 1) = nan
                  endif
                  if (WLC_P__VARIABLE_CHEM_STATE) then
                     wlc_ABP(I:I + 1) = INT_MIN
                  endif
               enddo
            endif

            if (.False.) then
               do I = 1, WLC_P__NT
                  if (.not. isnan(wlc_RP(1, I))) then
                     print *, "should be NAN at", I
                     stop
                  endif
               enddo
            endif
            !^^^^^^^^^^^End of check ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
!   Adapt the amplitude of step every NADAPT steps
         enddo ! End of sweepIndex loop
         !amplitude and window adaptations
         if (mod(ISTEP + wlc_ind_exchange*WLC_P__STEPSPEREXCHANGE, wlc_p%NADAPT(MCTYPE)) == 0) then  ! Addapt ever NADAPT moves
            call mc_adapt(wlc_p, MCTYPE)

            ! move each chain back if drifted though repeated BC
            if (WLC_P__RECENTER_ON) then
               call wlcsim_params_recenter()  ! You don't need to do this if there is confinement
            endif
         endif
      enddo ! End of movetype loop

      ! Parallel tempereing used to happen here but now has been moved to wlcsim_name
      ! !  -----  Parallel tempering ----
      ! if (mod(ISTEP,WLC_P__NPT).eq.0) then
      !    call replicaExchange(wlc_p)
      ! ENDif

      ! seps in this subroutine
      ISTEP = ISTEP + 1
   enddo ! end of ISTEP loop

   RETURN
END

!-------------------------------------------------------------*