c******************************************************************************
c
c      Equilbrium solver
c
c******************************************************************************
c
       SUBROUTINE SJEQLB(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW,KINIT)
c
c      Equilibrium solution by element potentials (and initialization).
c------------------------------------------------------------------------------
c      Solves for the element potentials and phase mols that meet the
c      atomic constraints.  Uses the dual problem for
c
c           W = sum{PMOL(M)*[Z(M)-1]} - sum{ELAM(K)*PA(IB(K)}
c
c      The atomic constraints are satisfied when W is a minimum with
c      respect to variations in ELAMs at fixed PMOLs.  For any such
c      state the Z constraints are satisfied when this W = W* = Y is
c      maximized with respect to PMOLs.  This forms the basis for the
c      steepest descent/ascent algorithms used below. Newton-Raphson
c      iterations are used near the extremum states.
c
c      The basic element potential mol fraction generator
c
c             X(J) = exp[-G(J) + sum{ELAM(K)*N(K,J)}]
c
c      is used to calculate the phase mol fractions.
c
c      Works in three modes:
c
c          Mode 1: Steepest descent in ELAM space at fixed PMOLs
c                  followed by steepest ascent in PMOL space
c
c          Mode 2: Newton-Raphson iteration on ELAMs at fixed PMOLs
c                  followed by steepest ascent in PMOL space
c
c          Mode 3: Newton-Raphson iteration on ELAMs and PMOLs
c
c          Problems:
c
c              KERR = 1 solution failed due to singularity
c              KERR = 2 solution failed to converge
c
c      Initialization:
c
c          If KINIT = 1  at call, the initializer is called to set up
c          the problem and estimate the element potentials and phase mols.
c
c          If KINIT = 0 at call, the current values are used to start.
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NAMAX       maximum number of atoms
c @        NSMAX       maximum number of species
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c @        ATOM(I)     CHARACTER*2 name of Ith atom
c @        CHEM(J)     CHARACTER*8 name of Jth species
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c @        KINIT       initialization control (initialize if 1)
c
c      Variables in the integer work array IW:
c #        IB(K) = I   if the Kth independent atom is the Ith system atom
c #        JB(K) = J   if the Kth base is the Jth species
c #        KB(J)       0 if Jth species is not a base
c                      1 if the Jth species is a base
c                      4 if the Jth species is excluded
c #        KERR        error flag
c @        KMON        monitor control
c -        KPC(M)      0 if phase not active, 1 if active
c -        KPCX(M)     KPC for provisional new phase distribution
c #        KTRE        main pass counter
c @        KUMO        output unit for monitor
c #        MPA(L) = M  if Mth phase is the Lth active phase
c #        MPJ(J) = M  if the Jth species is in the Mth phase
c @        N(I,J)      number of Ith atoms in the Jth species
c @        NA          number of atom types in the system
c #        NB          number of independent atoms (basis species)
c @        NP          number of allowed phases
c @        NS          number of species
c @        NSP(M)      number of species in the Mth phase
c
c      Variables in the real work array RW:
c @        ALPH        Lagrange multiplier for H when (T,P,H) specified
c -        A(K,L)      work matrix
c #        CM(K,M)     conditioning matrix
c -        D(K,M)      sum{N(IB(K),J)*X(J)} for Mth phase
c -        DC(K,M)     conditioned D vector for Mth phase
c -        DLAM(K)     change in ELAM(K) when PMOLs held constant
c -        DLAY(K)     change in ELAM(K) associated with PMOLs changes
c -        DPML(M)     change in PMOL(M)
c -        E(K,M)      satisfies sum{QC(K,L)*E(L,M)} = - DC(K,M)
c #        ELAM(K)     element potential for the Kth independent atom
c @        FRND        roundoff factor
c @        G(J)        g(T,P)/RT for the Jth species
c -        HA(K)       sum{PMOL(M)*D(K,M)} - PA(IB(K)) (zero for solution)
c -        HC(K)       conditioned H vector
c @        PA(I)       population of Ith atom
c #        PC(K)       conditioned  populations SUM{CM(K,L)*PA(IB(L))}
c #        PMOL(M)     mols of Mth phase
c -        Q(K,L)      sum{PMOL(M)*SUM{(Mth phase) N(IB(K),J)*N(IB(L),J)*X(J)}}
c -        QC(K,L)     conditioned Q matrix
c -        RL(K)       direction cosines for steepest descent in ELAM space
c -        RP(M)       direction cosines for steepest descent in PMOL space
c -        SMOL(J)     Jth species mols  (plus false species in SJISMP)
c                  (FINAL VALUES NOT COMPUTED BY SJEQLB!)
c -        W(K)        work vector
c #        X(J)        mol fraction of the Jth species
c -        Z(M)        sum{X(J)} over species in Mth phase
c
c      Variables used only internally:
c          AEZM        maximum error in Z(M) - 1 for an active phase
c          AEZMD       value of AEZM above which a mode downgrade is made
c          AEZMU       value of AEZM below which a mode upgrade is attempted
c          AEZMF       factor for error tolerance in mode 1
c          BETA2       sum{HA(K)*HA(K)} = Beta-squared (sum over bases)
c          BETA        -sqrt[BETA2] = dW/ds for steepest descent
c          CALL1       logical key; first or subsequent call
c          CLIP        Lambda clipping indicator
c          DLAMAX      maximum change allowed in ELAMs for Newton-Raphson
c          DS          path length in ELAM space
c          DSUP        DS below which upgrade from more 1 is attempted
c          DWDS        dW/ds on steepest descent path
c          DYDS        dW*/ds* on steepest ascent path
c          ERRH        allowed fractional error in any H
c          ERRHT       maximum tolerant  ERRH
c          ERRZ        allowed fractional error in Z
c          FDW         damping factor to suppress W valley oscillations
c          FDY         damping factor to suppress Y valley oscillations
c          FDPMA       maximum PMOL fractional change in W* ascent
c          FDPMC       fraction of PMOL change used for illegal phase demise
c          FDPMI3      maximum PMOL fractional (of PMMAX) increase in mode 3
c          FDPMD3      maximum PMOL fractional (of PMOL) decrease in mode 3
c          FDPMV       fraction of illegal vanishing change accepted
c          FDPYR       fraction for reduction of a large phase seeking absence
c          FDPYV       fraction of largest PMOL below which a phase may vanish
c          FDPY        maximum fraction of max PMOL for phase activation
c          KTRH        number of times the LAM changes have been halved
c          KTRM        number of passes made in the current mode
c          KTRMAX      maximum KTRE allowed
c          KTRY        Y (mols adjustment) descent counter
c          KUP         mode upgrade control
c          MODE        mode number
c          MS          matrix size in phase mols adjustment
c          PMMAX       maximum PMOL
c          REHM        maximum relative error found for any HA(K)
c          REHCM       maximum relative error found for any HC(K)
c          REHMD       value of REHM above which a mode downgrade is made
c          REHMU       value of REHM below which a mode upgrade is attempted
c          WF          sum{PMOL(M)*[Z(M)-1]} - sum{ELAM(K)*PA(IB(K)}
c          WP          WF value on previous pass
c          Y           WF at the minimum in ELAM at fixed PMOL; also called W*
c------------------------------------------------------------------------------
       IMPLICIT    REAL*8  (A-H,O-Z)
       CHARACTER*2 ATOM
       CHARACTER*8 CHEM
       LOGICAL     CLIP
c------------------------------------------------------------------------------
       DIMENSION   ATOM(NAMAX),CHEM(NSMAX),IW(NIW),RW(NRW)
c------------------------------------------------------------------------------
c    pointers
       COMMON /SJEPTR/
     ;   IoKERR,IoKMON,IoKTRE,IoKUMO,IoNA,IoNB,IoNP,IoNS,IoIB,IoIBO,
     ;   IoJB,IoJBAL,IoJBA,IoJBB,IoJBO,IoJBX,IoJS2,IoKB,IoKB2,IoKBA,
     ;   IoKBB,IoKBO,IoKPC,IoKPCX,IoLB2,IoMPA,IoMPJ,IoN,LoN,IoNSP,
     ;   IoFRND,IoHUGE,IoALPH,IoR2,IoR3,IoA,LoA,IoB,LoB,IoBBAL,
     ;   IoCM,LoCM,IoD,LoD,IoDC,LoDC,IoDPML,IoDLAM,IoDLAY,IoE,
     ;   LoE,IoEEQN,IoELAM,IoELMA,IoELMB,IoF,IoG,IoHA,IoHC,IoPA,
     ;   IoPC,IoPMOL,IoQ,LoQ,IoQC,LoQC,IoRC,LoRC,IoRL,IoRP,
     ;   IoSMOA,IoSMOB,IoSMOO,IoSMOL,IoSMUL,IoW,IoX,IoXO,IoY,IoZ
c------------------------------------------------------------------------------
c    iteration limit
       DATA KTRMAX/200/
c------------------------------------------------------------------------------
c    error parameters for mode change
       AEZMD = 0.3
       AEZMU = 0.2
       REHMD = 0.4
       REHMU = 0.3
       DSUP  = 0.3
c    tolerant error parameters
       AEZMF = 1.E-2
       ERRHT = 1.0E-3
c    final convergence error limits
       ERRZ = 1.0E-10
       ERRH = 1.E-8
c    change limits
       DLAMAX = 2.0
       FDPMA = 0.5
       FDPMI3 = 0.3
       FDPMD3 = 0.3
c    W* ascent change limits
       FDPY = 0.3
       FDPYR = 0.8
       FDPYV = 0.02
       FDPMV = 0.8
       FDPMC = 0.9
c    constants
       ONE = 1.0
       ZERO = 0
c------------------------------------------------------------------------------
c    get parameters
       NA = IW(IoNA)
       NP = IW(IoNP)
       NS = IW(IoNS)
       KMON = IW(IoKMON)
       KUMO = IW(IoKUMO)
c
c    monitor
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,1) RW(IoALPH)
1          FORMAT (/' Equilibrium solution monitor:'//
     ;              '   Atom      mols',10x,'alpha=',e15.7)
           WRITE (KUMO,2) (ATOM(I),RW(IoPA+I),I=1,NA)
2          FORMAT (4X,A,1PE14.4)
           WRITE (KUMO,3) (ATOM(I),I=1,NA)
3          FORMAT (/' Species      g/RT  ',20(1X,A2))
           DO 5 J=1,NS
              WRITE (KUMO,4) CHEM(J),RW(IoG+J),(IW(IoN+I+LoN*J),I=1,NA)
4             FORMAT (1X,A8,F10.3,(20I3))
5             CONTINUE
           ENDIF
c
c    initialization
       IF (KINIT.NE.0) THEN
c            set species phase cross-reference
               J2 = 0
               DO 7 M=1,NP
                   J1 = J2 + 1
                   J2 = J2 + IW(IoNSP+M)
                   DO 6 J=J1,J2
                       IW(IoMPJ+J) = M
6                      CONTINUE
7                  CONTINUE
c            estimate phase mols and element potentials
               CALL SJINIT(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW)
               IF (IW(IoKERR).NE.0)  RETURN
c            load NB
               NB = IW(IoNB)
           ELSE
c            estimate element potentials using current mol fractions
               K = 1
               CALL SJIESL(NSMAX,NIW,NRW,CHEM,IW,RW,K,DUMMY,IDUMMY)
               IF (IW(IoKERR).NE.0)  RETURN
           ENDIF
c
c ** initialize counters and controls for the element potential solution
c
c    set counters
       IW(IoKTRE) = 0
       KTRM = 0
       KTRH = 0
       KTRY = 0
c    set to start in mode 3
       MODE = 3
       KUP = 0
c    set initial damping for steepest descent
       FDW = 1
       FDY = 1
c    set active phases
       DO 9 M=1,NP
           IF (RW(IoPMOL+M).NE.ZERO)  THEN
                    IW(IoKPC+M) = 1
                ELSE
                    IW(IoKPC+M) = 0
                ENDIF
9          CONTINUE
c
c **** Loop point for ELAM and PMOL adjustments  *****************
c
c    check for convergence failure
10     IF (IW(IoKTRE).GT.KTRMAX) THEN
           IW(IoKERR) = 2
           RETURN
           ENDIF
c
c    increment counters
       IW(IoKTRE) = IW(IoKTRE) + 1
       KTRM = KTRM + 1
c
c ** compute mol fractions and Z  for each phase and W
c
c    initialize
       AEZM = 0
       MAEZM = 0
       WF = 0
c    phase contributions
       J2 = 0
       DO 19  M=1,NP
           J1 = J2 + 1
           J2 = J2 + IW(IoNSP+M)
           IoZM = IoZ + M
           RW(IoZM) = 0
c        species contributions
           DO 17 J=J1,J2
c            check for inclusion
               IF (IW(IoKB+J).NE.4)  THEN
                   SUM = - RW(IoG+J)
c                element potential contributions
                   DO 15 K=1,NB
                       I = IW(IoIB+K)
                       SUM = SUM + RW(IoELAM+K)*IW(IoN+I+LoN*J)
15                     CONTINUE
                   RW(IoX+J) = SJUEXP(SUM)
                   RW(IoZM) = RW(IoZM) + RW(IoX+J)
                   ENDIF
17             CONTINUE
           WF = WF + RW(IoPMOL+M)*RW(IoZM)
c
c        compute Z error
           AEZ = RW(IoZM) - 1
c        check vs maximum
           IF (IW(IoKPC+M).NE.0)  THEN
c                 the phase is active
                   IF (DABS(AEZ).GT.AEZM)  THEN
                       AEZM = DABS(AEZ)
                       MAEZM = M
                       ENDIF
               ELSE
c                 if Z ge 1 the phase should be active
                   IF (AEZ.GE.ZERO)  AEZM = AEZ
               ENDIF
c
19         CONTINUE
c
c ** calculate  D,DC, HA, HC, and QC and evaluate the relative errors
c
c    initialize
       REHM = 0
       REHCM = 0
c
       DO 29 K =1,NB
c        population term in WF
           IK = IW(IoIB+K)
           WF = WF - RW(IoELAM+K)*RW(IoPA+IK)
c        initialize
           IoHAK = IoHA + K
           IoHCK = IoHC + K
           IoPAIK = IoPA+IK
           IoPCK = IoPC + K
           RW(IoHAK) = - RW(IoPAIK)
           RW(IoHCK) = - RW(IoPCK)
           TERMX = DABS(RW(IoPAIK))
           TERMCX = DABS(RW(IoPCK))
           DO 21 L=1,NB
               RW(IoQC+K+LoQC*L) = 0
21             CONTINUE
c        phase contributions
           J2 = 0
           DSUM = 0
           DO 27 M=1,NP
               J1 = J2 + 1
               J2 = J2 + IW(IoNSP+M)
               IoDKM = IoD + K + LoD*M
               IoDCKM = IoDC + K + LoDC*M
               RW(IoDKM) = 0
               RW(IoDCKM) = 0
               TDM = 0
               TDCM = 0
c            species contributions
               DO 25 J=J1,J2
c                check for inclusion
                   IF (IW(IoKB+J).NE.4)  THEN
c                    contributions to D and H and major terms in H
                       TERM = IW(IoN+IK+LoN*J)*RW(IoX+J)
                       CALL SJUMAX(TERM,TDM)
                       RW(IoDKM) = RW(IoDKM) + TERM
c                    check for active phase
                       IF (IW(IoKPC+M).NE.0)  THEN
                           TERM = TERM*RW(IoPMOL+M)
                           CALL SJUMAX(TERM,TERMX)
                           RW(IoHAK) = RW(IoHAK) + TERM
                           ENDIF
c                    contributions to conditioned D, H, and Q
                       IF ((IW(IoKB+J).NE.1).OR.(IW(IoJB+K).EQ.J)) THEN
                           IF (IW(IoKB+J).EQ.1)  THEN
c                                species J is the Kth base species
                                   TERM = 1
                               ELSE
c                                species J is not a base
                                   TERM = 0
                                   DO 23 L=1,NB
                                       IL = IW(IoIB+L)
                                       TERM = TERM + RW(IoCM+K+LoCM*L)*
     ;                                               IW(IoN+IL+LoN*J)
23                                     CONTINUE
                               ENDIF
                           TERM = TERM*RW(IoX+J)
                           CALL SJUMAX(TERM,TDCM)
                           RW(IoDCKM) = RW(IoDCKM) + TERM
                           IF (IW(IoKPC+M).NE.0)  THEN
                               TERM = TERM*RW(IoPMOL+M)
                               CALL SJUMAX(TERM,TERMCX)
                               RW(IoHCK) = RW(IoHCK) + TERM
                               DO 24 L=1,NB
                                   IL = IW(IoIB+L)
                                   IoQCKL = IoQC + K + LoQC*L
                                   RW(IoQCKL) = RW(IoQCKL) +
     ;                                 TERM*IW(IoN+IL+LoN*J)
24                                 CONTINUE
                               ENDIF
                           ENDIF
                       ENDIF
25                 CONTINUE
               CALL SJURND(RW(IoDKM),TDM)
               CALL SJURND(RW(IoDCKM),TDCM)
27             CONTINUE
c
c        compute relative errors in HA(K) and compare vs maximum
           IF (TERMX.NE.ZERO)  THEN
                   REH = DABS(RW(IoHAK))/TERMX
               ELSE
                   REH = 0
               ENDIF
           CALL SJUMAX(REH,REHM)
c
c        compute relative errors in HC(K) and compare vs maximum
           IF (TERMCX.NE.ZERO)  THEN
                   REHC = DABS(RW(IoHCK))/TERMCX
               ELSE
                   REHC = 0
               ENDIF
           CALL SJUMAX(REHC,REHCM)
c
29         CONTINUE
c
c ** monitor
c
c    instructional monitor
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,60) IW(IoKTRE),WF
60         FORMAT (/' Equilibrium solution pass ',I3,
     ;              ';   dual function W =',1PE20.12)
           WRITE (KUMO,61) (M,RW(IoPMOL+M),RW(IoZ+M),M=1,NP)
61         FORMAT  ('   phase ',I2,' mols =',1PE15.8,
     ;              ';  mol fraction sum Z =',E20.12)
           DO 63 K=1,NB
               I = IW(IoIB+K)
               WRITE (KUMO,62) ATOM(I),RW(IoELAM+K),RW(IoHA+K)
62             FORMAT  ('   element potential for ',A2,' =',1PE20.12,
     ;                  '; population error =',E11.3)
63             CONTINUE
           WRITE (KUMO,64) REHCM
64         FORMAT ('   maximum conditioned population relative error =',
     ;             1PE12.4)
           DO 69 J1=1,NS,6
               J2 = J1 + 5
               IF (J2.GT.NS) J2 = NS
               WRITE (KUMO,65) (CHEM(J),J=J1,J2)
65             FORMAT  (6X,6(4X,A8))
               WRITE (KUMO,67) (RW(IoX+J),J=J1,J2)
67             FORMAT  ('    X:',6E12.5)
69             CONTINUE
           ENDIF
c
c **** initial convergence check (superaccurate convergence)
c
       IF ((AEZM.LT.RW(IoFRND)).AND.(REHCM.LT.RW(IoFRND))) GOTO 800
c
c **** mode selection/revision ********
c
c    set error limit for constraint convergence
c    (allow more error if Zs are not close)
       ERRHX  = ERRH + AEZM*AEZMF
       IF (ERRHX.GT.ERRHT)  ERRHX = ERRHT
c
c    branch on current mode
       GOTO (110,120,130),  MODE

c
c ** mode 1:  Steepest descent of W in ELAM space at fixed PMOL
c             followed by steepest descent of Y in PMOL space
c
110    IF (KTRM.GT.1)  THEN
c        previous pass also in mode 1; check for W increase
           IF (WF.GT.WP)  THEN
c           WF increased:  check mode trial count
               IF (KTRH.GT.10)  THEN
c                not getting anywhere:  give up
                   IW(IoKERR) = 2
                   RETURN
                   ENDIF
c            cut ELAM changes in half and try again
               DO 117 K=1,NB
                   IoDLAK = IoDLAM + K
                   RW(IoDLAK) = 0.5*RW(IoDLAK)
                   RW(IoELAM+K) = RW(IoELAM+K) - RW(IoDLAK)
117                CONTINUE
               KTRH = KTRH + 1
               KUP = 2
               IF (KMON.GT.1)  WRITE (KUMO,118)
118            FORMAT (' W overshoot;',
     ;                 '  halving element potential changes.')
               GOTO 10
               ENDIF
           ENDIF
       KTRH = 0
c
c    check for upgrade to mode 2 or 3
       IF (KTRM.GT.KUP)  THEN
           IF (DS.LT.DSUP)  THEN
               IF (AEZM.LT.AEZMU)  THEN
                       MODE = 3
                   ELSE
                       MODE = 2
                   ENDIF
               KTRM = 1
               KUP = 0
               ENDIF
           ENDIF
       GOTO 200
c
c **  mode 2:  Newton-Raphson iteration for LAM followed by
c               steepest descent of Y in PMOL space
c
120    IF (KTRM.GT.1)  THEN
c        previous pass was in mode 2; W should have decreased
           IF (WF.GT.WP)  THEN
c            W increased: check numerical limit
               IF (REHM.LE.ERRH)  GOTO 126
c            use last good values in mode 1
               DO 121 K=1,NB
                   RW(IoELAM+K) = RW(IoELAM+K) - RW(IoDLAM+K)
121                CONTINUE
c            set for a fresh descent
               MODE = 1
               KTRM = 0
               KUP = 2
               IF (KMON.GT.1) WRITE (KUMO,122)
122            FORMAT (' W increased: going back to last good point.')
               GOTO 10
               ENDIF
           ENDIF
c
c    check for upgrade to mode 3
126    IF (KTRM.GT.KUP)  THEN
           IF (((REHM.LT.REHMU).AND.(AEZM.LT.AEZMU)).OR.
     ;        (REHM.LT.ERRHX))  THEN
c            set to try mode 3
               MODE = 3
               KTRM = 1
               KUP = 0
               GOTO 200
               ENDIF
           ENDIF
c
c    check for change to mode 1
       IF (REHM.GT.REHMD)  THEN
c        not close enough for mode 2; set for mode 1
           MODE = 1
           KTRM = 1
           KUP = 1
           GOTO 200
           ENDIF
c
c    continue in mode 2
       GOTO 200
c
c ** mode 3:   Newton-Raphson in ELAM and PMOL
c
c    check for errors too large for mode 3
130    IF ((AEZM.GT.AEZMD).OR.(REHM.GT.REHMD))  THEN
c        stay with mode 3 if only phase mols need adjustment
           IF (REHM.LT.ERRH)  GOTO 200
c        errors large; go to mode 2
           MODE = 2
           KTRM = 0
           KTRY = 0
           KUP = 2
           GOTO 120
           ENDIF
c
c **** calculations after a good pass
c
c    save WF from this pass
200    WP = WF
c
c    HA convergence test for mode 1 or 2
250    IF (MODE.NE.3)  THEN
c      if HA error is less than adjusted error bound ERRHX, go adjust PMOL
           IF (REHM.LT.ERRHX)  GOTO 600
           ENDIF
c
c    branch on mode
       GOTO (400,500,700),  MODE
c
c **** LAM adjustments in mode 1
c
c    valley check
400    IF (KTRM.GT.1)  THEN
c        compute dW/ds at the new point on the old path
           DWDSN = 0
           DO 407 K=1,NB
               DWDSN = DWDSN + RW(IoRL+K)*RW(IoHA+K)
407            CONTINUE
c        check for a valley
           IF (DWDS*DWDSN.LT.ZERO)  THEN
c            interpolate in the valley
               TERM =  - DABS(DWDSN/(DWDSN - DWDS))
               DO 409 K=1,NB
                   RW(IoELAM+K) = RW(IoELAM+K) + TERM*RW(IoDLAM+K)
409                CONTINUE
c            monitor
               IF (KMON.GT.1)  WRITE (KUMO,410)
410            FORMAT (' W valley interpolation')
c            set to take a fresh descent
               KTRM = 0
               GOTO 10
               ENDIF
           ENDIF
c
c    determine the dW/ds = beta
       BETA2 = 0
       DO 419 K=1,NB
           BETA2 = BETA2 + RW(IoHA+K)*RW(IoHA+K)
419        CONTINUE
c
c    we are at the minimum W point if BETA2 = 0
       IF (BETA2.EQ.ZERO)  GOTO 600
       DWDS = - DSQRT(BETA2)
c
c    determine sum{Q(K,L)*HA(K)*HA(L)}/BETA2
       RBETA = 1/DWDS
       QHSOB2 = 0
c    phase contributions
       J2 = 0
       DO 429 M=1,NP
           J1 = J2 + 1
           J2 = J2 + IW(IoNSP+M)
c        check for active phase
           IF (IW(IoKPC+M).NE.0)  THEN
c            species contributions
               PSUM = 0
               DO 427 J=J1,J2
c               check for inclusion
                   IF (IW(IoKB+J).NE.4)  THEN
                       SUM = 0
                       DO 425 K=1,NB
                           I = IW(IoIB+K)
                           SUM  = SUM + IW(IoN+I+LoN*J)*RW(IoHA+K)
425                        CONTINUE
c                    dividing by Beta here helps prevent overflow
                       SUM = SUM*RBETA
                       PSUM = PSUM + SUM*SUM*RW(IoX+J)
                       ENDIF
427                CONTINUE
               QHSOB2 = QHSOB2 + PSUM*RW(IoPMOL+M)
               ENDIF
429        CONTINUE
c
c    estimate ds to the minimum point
       IF (QHSOB2.LE.ZERO)  THEN
c        something is wrong;  quit
           IW(IoKERR) = 1
           RETURN
           ENDIF
       DS = - FDW*DWDS/QHSOB2
c
c    limit changes
       IF (DS.GT.DLAMAX)  THEN
           DS = DLAMAX
           ENDIF
c
c    set direction cosines, changes, and new values
       FDW = 1
       DO 439 K=1,NB
           RLX = RW(IoHA+K)*RBETA
c        check for oscillation
           IF (KTRM.GT.1) THEN
               IF (RLX*RW(IoRL+K).LT.ZERO)  THEN
c                oscillating; reset damping factor
                   FDWX = DABS(1 - 0.9*DABS(RLX))
                   IF (FDWX.LT.FDW)  FDW = FDWX
                   ENDIF
               ENDIF
           RW(IoRL+K) = RLX
           RW(IoDLAM+K) = RLX*DS
           RW(IoELAM+K) = RW(IoELAM+K) + RW(IoDLAM+K)
439        CONTINUE
c
c    monitor
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,442)
442        FORMAT (' Element potentials adjusted by',
     ;             ' steepest descent in W')
           ENDIF
c
       GOTO 10
c
c **** LAM adjustments in mode 2
c
c    calculate the LAM changes
500    DO  529 K=1,NB
c        load the rhs = - (conditioned H vector) in W
           RW(IoW+K) = - RW(IoHC+K)
c        load the conditioned Q matrix in A
           DO 527 L=1,NB
               RW(IoA+K+LoA*L) = RW(IoQC+K+LoQC*L)
527            CONTINUE
529        CONTINUE
c    singularity check/repair
       CALL SJECKA(NSMAX,NIW,NRW,CHEM,IW,RW,NB)
c    solve to get DLAM
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NB,IW(IoKERR))
c    check for trouble
       IF (IW(IoKERR).NE.0)  THEN
c        singular system; go try mode 1
           IF (KMON.GT.1)  WRITE (KUMO,530)
530        FORMAT (' Singular matrix in Newton-Raphson',
     ;             ' adjustment of element potentials')
           MODE = 1
           KUP = 2
           KTRM = 0
           GOTO 250
           ENDIF
c
c    check for excessive changes
       DO 539 K=1,NB
           IF (DABS(RW(IoW+K)).GT.DLAMAX)  THEN
c            changes too large
               IF (KMON.GT.1)  THEN
                   WRITE (KUMO,532)
532                FORMAT (' Attempted Newton-Raphson for',
     ;               ' element potentials; changes too large.'/
     ;               ' Continuing steepest descent.')
                   ENDIF
c            restart in mode 1
               MODE = 1
               KTRM = 0
               KUP = 1
               GOTO 10
               ENDIF
539        CONTINUE
c
c    make the changes
       DO 549 K=1,NB
           RW(IoDLAM+K) = RW(IoW+K)
           RW(IoELAM+K) = RW(IoELAM+K) + RW(IoDLAM+K)
549        CONTINUE
c
       IF (KMON.GT.1)  WRITE (KUMO,552)
552    FORMAT (' Element potentials adjusted by Newton-Raphson')
c
c      go do another pass
       GOTO 10
c
c      Y denotes W* =  Wmin, the maximum of which we seek in phase mols space
c
c    advance pass counter
600    KTRY = KTRY + 1
c
c    ridge interpolation check
       IF (KTRY.GT.1)  THEN
c        compute dW*/ds* at the new point on the old path
           DYDSN = 0
           DO 601 M=1,NP
               IF (IW(IoKPC+M).NE.0)
     ;            DYDSN = DYDSN + (RW(IoZ+M) - 1)*RW(IoRP+M)
601            CONTINUE
c        check for a ridge
           IF (DYDSN*DYDS.LT.ZERO)  THEN
c            interpolate for the ridge
               TERM = - DABS(DYDSN/(DYDSN - DYDS))
               DO 605 M=1,NP
                   RW(IoPMOL+M) = RW(IoPMOL+M) + TERM*RW(IoDPML+M)
605                CONTINUE
               DO 607 K=1,NB
                   RW(IoELAM+K) = RW(IoELAM+K) + TERM*RW(IoDLAY+K)
607                CONTINUE
c            monitor
               IF (KMON.GT.1)  WRITE (KUMO,608)
608            FORMAT (' W* ridge interpolation')
c            set for a fresh ascent in W*
               KTRY = 0
               KTRM = 0
               GOTO 10
               ENDIF
           ENDIF
c
c    calculate the E vectors for each phase
       DO 617 M=1,NP
           DO 612 K=1,NB
c            load the rhs =  - (conditioned D) in W
               RW(IoW+K) = - RW(IoDC+K+LoDC*M)
c            load the conditioned Q matrix in A
               DO 611 L=1,NB
                   RW(IoA+K+LoA*L) = RW(IoQC+K+LoQC*L)
611                CONTINUE
612            CONTINUE
c        singularity check/repair
           CALL SJECKA(NSMAX,NIW,NRW,CHEM,IW,RW,NB)
c        solve to get E
           CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),NB,IW(IoKERR))
c        check for problems
           IF (IW(IoKERR).NE.0)  THEN
c            set E zero and keep trying
               DO 613 K=1,NB
                   RW(IoW+K) = 0
613                CONTINUE
               ENDIF
c        load the E vector
           DO 615 K=1,NB
               RW(IoE+K+LoE*M) = RW(IoW+K)
615            CONTINUE
617        CONTINUE
c
c    activate all phases and get maximum phase mols
       PMMAX = 0
       DO 619 M=1,NP
           CALL SJUMAX(RW(IoPMOL+M),PMMAX)
           IW(IoKPC+M) = 1
619        CONTINUE

c    compute the cosine coefficients in W
620    SUM = 0
       DO 629 M=1,NP
           IoWM = IoW+M
c        check for active phase
           IF (IW(IoKPC+M).NE.0)  THEN
               RW(IoWM) = (RW(IoZ+M) - 1)
c            check for an empty phase with W < 0
               IF ((RW(IoPMOL+M).EQ.ZERO).AND.(RW(IoWM).LT.ZERO)) THEN
c                set this phase inactive and start over
                   IW(IoKPC+M) = 0
                   GOTO 620
                   ENDIF
               SUM = SUM + RW(IoWM)*RW(IoWM)
               ENDIF
629        CONTINUE
c
c    compute dY/ds on path of steepest ascent
       DYDS =  DSQRT(SUM)
       IF (DYDS.EQ.ZERO)  THEN
c        check for convergence
           IF (REHCM.LT.ERRH) GOTO 800
           IW(IoKERR) = 1
           RETURN
           ENDIF
c
c    compute direction cosines and select damping factor FDYF
       RDYDS = 1/DYDS
       FDYF = 1
       DO 631 M=1,NP
           IF (IW(IoKPC+M).NE.0)  THEN
c                active phase
                   RX = RW(IoW+M)*RDYDS
c                set damping
                   IF (KTRY.GT.1)  THEN
                       IF (RX*RW(IoRP+M).LT.ZERO)  THEN
                           FDYFX = 1 - 0.8*DABS(RX)
                           IF (FDYFX.LT.FDYF)  FDYF = FDYFX
                           ENDIF
                       ENDIF
                   RW(IoRP+M) = RX
               ELSE
c                inactive phase
                   RW(IoRP+M) = 0
               ENDIF
631        CONTINUE
c
c  set damping coefficient FDY
       IF (FDYF.EQ.ONE)  THEN
c            reduce the damping if no longer needed
               IF (FDY.LT.ONE) THEN
                   FDY = 1.4*FDY
                   IF (FDY.GT.ONE)  FDY = 1
                   ENDIF
           ELSE
               IF (KTRY.EQ.1)  THEN
c                    set undamped at the start of an ascent
                       FDY = 1
                   ELSE
c                    increase damping if more is needed
                       FDY = FDY*FDYF
                   ENDIF
           ENDIF
c
c    estimate the distance to the maximum point
       D2YDS2 = 0
       DO 639 L=1,NP
c        check for active phase
           IF (IW(IoKPC+L).NE.0)  THEN
c            phase L active
               SUM = 0
               DO 637 M=1,NP
c                check for active phase
                   IF (IW(IoKPC+M).NE.0)  THEN
c                    Mth phase active:  compute A(L,M)
                       ALM = 0
                       DO 635 K=1,NB
                           ALM = ALM + RW(IoD+K+LoD*L)*RW(IoE+K+LoE*M)
635                        CONTINUE
                       SUM = SUM + ALM*RW(IoRP+M)
                       ENDIF
637                CONTINUE
               D2YDS2 = D2YDS2 + SUM*RW(IoRP+L)
               ENDIF
639        CONTINUE
c
c    check for completion
       IF (D2YDS2.GE.ZERO)  THEN
c            set a reasonable change
               DSP = PMMAX
           ELSE
c            set distance as (damped) estimate to maximum point
               DSP = - FDY*DYDS/D2YDS2
           ENDIF
       DSP0 = DSP
c
c    limit phase mols change
       TERMY = FDPY*PMMAX
       DO 641 M=1,NP
           IF (IW(IoKPC+M).NE.0)  THEN
c            active phase
               IoPMOM = IoPMOL + M
               TERM = RW(IoRP+M)*DSP
               IF ((RW(IoPMOM)+TERM).LE.RW(IoFRND)*RW(IoPMOM))  THEN
c                    phase attempting to vanish
                       IF (RW(IoPMOM).LT.FDPYV*PMMAX)  THEN
c                            size step to make PMOL vanish
                               DSP = - RW(IoPMOM)/RW(IoRP+M)
                           ELSE
c                            size step to reduce PMOL by a factor
                               DSP = - FDPYR*RW(IoPMOM)/RW(IoRP+M)
                           ENDIF
                   ELSE
c                    phase not attempting to vanish
                       IF (RW(IoPMOM).NE.ZERO)  THEN
c                            existing phase
                               TERMX = FDPMA*RW(IoPMOM)
                               IF (DABS(TERM).GT.TERMX)  THEN
                                  DSP = DSP*DABS(TERMX/TERM)
                                  ENDIF
                           ELSE
c                            non-existing phase
                               IF (DABS(TERM).GT.TERMY)  THEN
                                  DSP = DSP*DABS(TERMY/TERM)
                                  ENDIF
                           ENDIF
                   ENDIF
               ENDIF
641        CONTINUE
c
c    check for completion
       IF (DSP.EQ.ZERO)  GOTO 800
c
c    make the phase mol changes and prepare for possible rebasing
       KPMC = 0
       KRED = 0
       DO 649 M=1,NP
           IW(IoKPCX+M) = IW(IoKPC+M)
           IoPMOM = IoPMOL + M
           IoDPMM = IoDPML + M
           IF (IW(IoKPC+M).NE.0)  THEN
c               active phase
c                 set the change
                   RW(IoDPMM) = RW(IoRP+M)*DSP
c                 no termination on phase activation
                   IF (RW(IoPMOM).EQ.ZERO)  THEN
                       KPMC = 1
                       KRED = 1
                       ENDIF
c                 make the change with roundoff control
                   RW(IoPMOM) = RW(IoPMOM) + RW(IoDPMM)
                   IF (RW(IoPMOM).LT.RW(IoFRND)*DABS(RW(IoDPMM)))
     ;              THEN
                       RW(IoPMOM) = 0
                       KPMC = 1
                       KRED = 1
                       IW(IoKPCX+M) = 0
                       ENDIF
c                 relative error assessment
                   IF (IW(IoKPCX+M).NE.ZERO)  THEN
c                       be tolerant with sparse phases
                          TERM = ERRH*(10.*DLOG(PMMAX/RW(IoPMOM)) + 1)
                          IF (DABS(RW(IoDPMM)).GT.TERM*RW(IoPMOM))
     ;                        KPMC = 1
                       ELSE
c                        can not terminate on a phase deactivation
                           KPMC = 1
                       ENDIF
               ELSE
c               inactive phase
                   RW(IoDPMM) = 0
               ENDIF
649        CONTINUE
c
c    check for phase activation/demise
       IF (KRED.NE.0)  THEN
c        check and rebase if ok
           CALL SJERB(NAMAX,NSMAX,NIW,NRW,ATOM,CHEM,IW,RW)
           IF (IW(IoKERR).NE.0)  THEN
c            unacceptable changes; reduce and go
               TERM = 1 - FDPMC
               DO 657 M=1,NP
                   IoPMOM = IoPMOL + M
                   IoDPMM = IoDPML + M
                   RW(IoPMOM) = RW(IoPMOM) - TERM*RW(IoDPMM)
                   RW(IoDPMM) = FDPMC*RW(IoDPMM)
657                CONTINUE
               ENDIF
           ENDIF
c
c    estimate the associated changes in ELAMs
       DLX = 0
       DO 665 K = 1,NB
           IoDLYK = IoDLAY + K
           RW(IoDLYK) = 0
           DO 663 M=1,NP
               IF (IW(IoKPC+M).EQ.0)  GOTO 663
               RW(IoDLYK) = RW(IoDLYK) + RW(IoE+K+LoE*M)*RW(IoDPML+M)
663            CONTINUE
           CALL SJUMAX(RW(IoDLYK),DLX)
665        CONTINUE
c
c    make the ELAM changes if not excessive
       IF (DLX.LT.DLAMAX)  THEN
               DO 667 K=1,NB
                   RW(IoELAM+K) = RW(IoELAM+K) + RW(IoDLAY+K)
667                CONTINUE
           ELSE
               DO 669 K=1,NB
                   RW(IoDLAY+K) = 0
669                CONTINUE
           ENDIF
c
c    reset active phase indicator
       DO 679 M=1,NP
           IW(IoKPC+M) = IW(IoKPCX+M)
679        CONTINUE
c
c    monitor
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,680)
680        FORMAT (' phase mols adjusted by steepest ascent in W*')
           ENDIF
c
c    convergence check
       IF ((REHCM.LT.ERRH).AND.(AEZM.LT.ERRZ))  THEN
           IF ((DLX.LT.ERRH).AND.(KPMC.EQ.0))  GOTO 800
           ENDIF
c
c    start a new W descent
       KTRM = 0
       KUP = 0
       GOTO 10
c
c **** ELAM and PMOL adjustments in mode 3
c
c    if constraints accurately satisfied but phasemols not, go adjust in Mode 2
700    IF (REHCM.LT.RW(IoFRND))  THEN
           MODE = 2
           KUP = 0
           KTRY = 0
           GOTO 600
           ENDIF
c
c    set up the active phase list and get maximum phase mols
       NPA = 0
       PMMAX = 0
       DO 701 M=1,NP
           IF ((RW(IoPMOL+M).GT.ZERO).OR.(RW(IoZ+M).GE.ONE))  THEN
c                set phase active
                   IW(IoKPC+M) = 1
                   NPA = NPA + 1
                   IW(IoMPA+NPA) = M
                   CALL SJUMAX(RW(IoPMOL+M),PMMAX)
               ELSE
c                set phase inactive
                   IW(IoKPC+M) = 0
               ENDIF
701        CONTINUE
c
c    set matrix size for solution for ELAM and PMOL
       MS = NB + NPA
c    load the matrix
       DO 707 K=1,NB
c        load the rhs for rows 1-NB
           RW(IoW+K) = - RW(IoHC+K)
c        load the last NPA columns and rows
           DO 703 M1=1,NPA
               L = NB + M1
               M = IW(IoMPA+M1)
               RW(IoA+K+LoA*L) = RW(IoDC+K+LoDC*M)
               RW(IoA+L+LoA*K) = RW(IoD+K+LoD*M)
703            CONTINUE
c        load the conditioned Q matrix in the first NB columns (and rows)
           DO 705 L=1,NB
               RW(IoA+K+LoA*L) = RW(IoQC+K+LoQC*L)
705            CONTINUE
707        CONTINUE
c    load the last NPA x NPA block and rhs
       DO  709 M1=1,NPA
           L = NB + M1
           M = IW(IoMPA+M1)
           RW(IoW+L) = 1 - RW(IoZ+M)
           DO 708 M2=1,NPA
               K = NB + M2
               RW(IoA+K+LoA*L) = 0
708            CONTINUE
709        CONTINUE
c
c    singularity check/repair
       CALL SJECKA(NSMAX,NIW,NRW,CHEM,IW,RW,MS)
c
c    solve to get changes in ELAMs and PMOL
       CALL SJULES(LoA,RW(IoA+1+LoA),RW(IoW+1),MS,IW(IoKERR))
c    check for problems
       IF (IW(IoKERR).NE.0)  THEN
c        singular matrix; try mode 2
           IF (KMON.GT.1)  WRITE (KUMO,710)
710        FORMAT (' Singular matrix in full Newton-Raphson')
           MODE = 2
           KUP = 2
           KTRM = 0
           GOTO 250
           ENDIF
c
c -- check for excessive change
       DLX = 0
       CLIP = .FALSE.
c    limit the maximum LAM changes
       DO 713 K=1,NB
           IF (DABS(RW(IoW+K)).GT.DLAMAX)  THEN
               RW(IoW+K) = DLAMAX*RW(IoW+K)/DABS(RW(IoW+K))
               CLIP = .TRUE.
               ENDIF
           CALL SJUMAX(RW(IoW+K),DLX)
713        CONTINUE
c
c    check phase changes
       DO 733 M1=1,NPA
           K = NB + M1
           M = IW(IoMPA+M1)
           IoWK = IoW + K
           IF (RW(IoPMOL+M).EQ.ZERO)  THEN
c                phase does not exist; permit no decrease
                   IF (RW(IoWK).LT.ZERO)  GOTO 750
c                allow a reasonable increase
                   TEST = FDPMI3*PMMAX
               ELSE
c                phase exists
                   IF (RW(IoWK).GT.ZERO) THEN
c                        allow a large increase
                           TEST = FDPMI3*PMMAX
                       ELSE
c                        allow a reasonable decrease
                           TEST = FDPMD3*RW(IoPMOL+M)
                       ENDIF
               ENDIF
           IF (DABS(RW(IoWK)).GE.TEST)  GOTO 750
733        CONTINUE
c
c -- make the changes and check for phase convergence
       DPMX = 0
       DO 741 K=1,NB
           RW(IoDLAY+K) = RW(IoW+K)
           RW(IoELAM+K) = RW(IoELAM+K) + RW(IoDLAY+K)
741        CONTINUE
       K = NB
       KPMC = 0
       DO 747 M=1,NP
           IoPMOM = IoPMOL + M
           IoDPMM = IoDPML + M
           IF (IW(IoKPC+M).NE.0)  THEN
c                active phase
                   K = K + 1
                   RW(IoDPMM) = RW(IoW+K)
c                prevent termination on phase activation
                   IF (RW(IoPMOM).EQ.ZERO)  KPMC = 1
c                make the change
                   RW(IoPMOM) = RW(IoPMOM) + RW(IoDPMM)
c                relative error assessment; tolerant with sparse phases
                   IF (RW(IoPMOM).NE.ZERO)  THEN
                          TERM = ERRH*(10.*DLOG(PMMAX/RW(IoPMOM)) + 1)
                          IF (DABS(RW(IoDPMM)).GT.TERM*RW(IoPMOM))
     ;                         KPMC = 1
                       ELSE
c                        hopefully never get here
                           KPMC = 1
                       ENDIF
               ELSE
c                inactive phase
                   RW(IoDPMM) = 0
               ENDIF
747        CONTINUE
c
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,748)
748        FORMAT (' Element potentials and phase mols adjusted by',
     ;         ' Newton-Raphson')
           IF (CLIP) WRITE (KUMO,749)
749        FORMAT (' with limited element potential changes')
           ENDIF
c
c *** convergence check ***
c    must have small errors
       IF ((REHCM.LT.ERRH).AND.(AEZM.LT.ERRZ))  THEN
c        and be making small changes
           IF ((DLX.LT.ERRH).AND.(KPMC.EQ.0))  GOTO 800
           ENDIF
c
c    continue the iteration as if a fresh W* ascent
       KTRY = 0
       GOTO 10
c
c -- changes too large; reset for mode 2 and a fresh W* ascent
750    MODE = 2
       KTRM = 0
       KTRY = 0
       KUP = 2
       IF (KMON.GT.1)  THEN
           WRITE (KUMO,752)
752        FORMAT (' Attempted full Newton-Raphson; changes excessive')
           ENDIF
       GOTO 250
c
c ---- exit calculations
c
c    normal return
800    IW(IoKERR) = 0
       RETURN
       END
c******************************************************************************
c
       SUBROUTINE SJECKA(NSMAX,NIW,NRW,CHEM,IW,RW,MS)
c
c      Checks the first NB rows of matrix A of dimension MS used in SJEQLB
c      to see if it is singular (because of an absent base).  Replaces
c      bad rows with the condition that the base mol fraction not change.
c------------------------------------------------------------------------------
c      Nomenclature:
c
c      Variables in the argument list:
c @        NSMAX       maximum number of species
c @        NIW         dimension of work array IW
c @        NRW         dimension of work array IR
c          IW(I)       integer work array
c          RW(I)       REAL*8 work array
c @        CHEM(J)     CHARACTER*8 name of Jth species
c @        MS          matrix size (row count)
c
c      Variables in the integer work array IW:
c @        IB(K) = I   if the Kth independent atom is the Ith system atom
c @        JB(K) = J   if the Kth base is the Jth species
c @        N(I,J)      number of Ith atoms in Jth molecule
c @        NB          number of bases
c
c      Variables in the real work array RW:
c @#       A(K,L)      work matrix
c @#       W(K)        work vector
c
c      Variables used only internally:
c          KCHK        check control
c------------------------------------------------------------------------------
       IMPLICIT        REAL*8  (A-H,O-Z)
       CHARACTER*8     CHEM
c------------------------------------------------------------------------------
       DIMENSION   CHEM(NSMAX),IW(NIW),RW(NRW),IEPTR(80)
c------------------------------------------------------------------------------
       COMMON /SJEPTR/ IEPTR
       EQUIVALENCE (IoIB,IEPTR(9)),(IoJB,IEPTR(11)),
     ;   (IoNB,IEPTR(6)),(IoN,IEPTR(28)), (LoN,IEPTR(29)),
     ;   (IoA,IEPTR(36)),(LoA,IEPTR(37)),(IoW,IEPTR(76))
c------------------------------------------------------------------------------
c    set comparison constant
       ZERO = 0
c
c    get parameters
       NB = IW(IoNB)
c
c    check the matrix
       DO 99 K=1,NB
           KCHK = 0
           DO 91 L=1,MS
               IF (RW(IoA+K+LoA*L).NE.ZERO)  KCHK = 1
91             CONTINUE
           IF (KCHK.EQ.0)  THEN
c            replace the row to prevent singularities
c            this treatment holds X(JB(K)) fixed in ELAM adjustments
               J = IW(IoJB+K)
               RW(IoW+K) = 0
               DO 95 L=1,NB
                   I = IW(IoIB+L)
                   RW(IoA+K+LoA*L) = IW(IoN+I+LoN*J)
95                 CONTINUE
               IF (MS.GT.NB)  THEN
                   L1 = NB + 1
                   DO 97 L=L1,MS
                       RW(IoA+K+LoA*L) = 0
97                     CONTINUE
                   ENDIF
               ENDIF
99         CONTINUE
       RETURN
       END
c******************************************************************************


module ot_mod

    ! precision specification
    use preci, wp => dp

    ! shared variables
    use globals

    implicit none

contains

    subroutine OT(COUNT,XM)
!*******************************************************************
!     This program is written to write the results to the output file
!*******************************************************************
    real (wp), dimension(MAXDISC+MAXDISC+MAXSEC) :: XN,XNK,XM
    real (wp) :: TTVOL,TTVOL2,XNN2,COUNT,TVG,TXLN2SIG,VM,XLN2SIG,XLNVG, &
    XMM1, XNN
    integer :: IND, I
!*******************************************************************
!     DVK(I)    VL(I+1) - VL(I)
!     DVLNV(I)  VL(I+1)*ln(VL(I+1)) - VL(I)*ln(VL(I))
!     TTVOL     Total volume of species (mole/cc)
!     TVG       Geometric mean volume (cm3)
!     XLNVG     Mean logarithm volume (cm3)
!     XLN2SIG   Mean logarithm standard deviation
!     XM        Aerosol concentration (#/cc)
!     XMM1      Total aerosol volume concentration (cm3/cc)
!     XN        Aerosol size distribution function (#/cc/cm)
!     XNN       Total number concentration (#/cc)
!*******************************************************************
    if (ETA == 0) then
        XLNVG = 0.0
        XMM1 = 0.0
        XNN = 0.0
        do I = 2,NDISC(1)
            XN(I) = XM(I)/VG(1,1)
            XMM1 = XMM1 + VG(1,I)*XM(I)
            XNN = XNN + XM(I)
            XLNVG = XLNVG + DLNVG(1,I)*XM(I)
        end do
        do I = 2,NDISC(2)
            IND = I+NDISC(1)
            XN(IND) = XM(IND)/VG(2,1)
            XMM1 = XMM1 + VG(2,I)*XM(IND)
            XNN = XNN + XM(IND)
            XLNVG = XLNVG + DLNVG(2,I)*XM(IND)
        end do
        do I = 1,NSEC
            IND = I+NDISCT
            XN(IND) = XM(IND)/DVK(I)
            XMM1 = XMM1 + VGSN(I)*XM(IND)
            XNN = XNN + XM(IND)
            XLNVG = XLNVG + XM(IND)*(DVLNV(I)/DVK(I)-1.0)
        end do

        XLNVG = XLNVG/XNN
        TVG = dexp(XLNVG)
        VM = XMM1/XNN
        TTVOL = XMM1 + XM(1)*VG(1,1) + XM(1+NDISC(1))*VG(2,1) + (CONCSP(1)*VG(1,1)+CONCSP(2)*VG(2,1))*AVO
        TTVOL2 = XMM1 + XM(1)*VG(1,1) + XM(1+NDISC(1))*VG(2,1)
        XNN2 = XNN + XM(1) + XM(1+NDISC(1))
        XN(1) = XM(1)/VG(1,1)

        XLN2SIG = 0.0
        do I = 2,NDISC(1)
            XLN2SIG = XLN2SIG + (DLNVG(1,I)-XLNVG)**2*XM(I)
        end do
        do I = 2,NDISC(2)
            XLN2SIG = XLN2SIG + (DLNVG(2,I)-XLNVG)**2*XM(I+NDISC(1))
        end do
        do I = 1,NSEC
            XLN2SIG = XLN2SIG + XM(I+NDISCT)*((VL(I+1)*(DLNVL(I+1)-XLNVG)**2 &
            - VL(I)*(DLNVL(I)-XLNVG)**2 - 2.0*DVLNV(I))/DVK(I)+2.0D0*(1.0D0+XLNVG))
        end do
        XLN2SIG = XLN2SIG/XNN/9.0
        TXLN2SIG = dexp(dsqrt(XLN2SIG))

    elseif (ETA == 1) then
        XNN = 0.0
        XLNVG = 0.0
        XMM1 = 0.0
        do I = 2,NDISC(1)
            XNK(I) = XM(I)/VG(1,I)
            XN(I) = XNK(I)/VG(1,1)
            XNN = XNN + XNK(I)
            XMM1 = XMM1 + XM(I)
            XLNVG = XLNVG + DLNVG(1,I)*XNK(I)
        end do
        do I = 2,NDISC(2)
            IND = I+NDISC(1)
            XNK(IND) = XM(IND)/VG(2,I)
            XN(IND) = XNK(IND)/VG(2,1)
            XNN = XNN + XNK(IND)
            XMM1 = XMM1 + XM(IND)
            XLNVG = XLNVG + DLNVG(2,I)*XNK(IND)
        end do
        do I = 1,NSEC
            IND = I+NDISCT
            XNK(IND) = XM(IND)/DVK(I)
            XN(IND) = XNK(IND)/VGS(I)
            XNN = XNN + XNK(IND)*DLNSF
            XMM1 = XMM1 + XM(IND)
            XLNVG = XLNVG + XNK(IND)*DLNVL2(I)
        end do

        XLNVG = XLNVG/XNN
        TVG = dexp(XLNVG)
        VM = XMM1/XNN
        TTVOL = XMM1 + XM(1) + XM(1+NDISC(1)) + (CONCSP(1)*VG(1,1) + CONCSP(2)*VG(2,1))*AVO
        TTVOL2 = XMM1 + XM(1) + XM(1+NDISC(1))
        XNN2 = XNN + XM(1)/VG(1,1) + XM(1+NDISC(1))/VG(2,1)
        XNK(1) = XM(1)/VG(1,1)
        XN(1) = XNK(1)/VG(1,1)

        XLN2SIG = 0.0
        do I = 2,NDISC(1)
            XLN2SIG = XLN2SIG + (DLNVG(1,I)-XLNVG)**2*XNK(I)
        end do
        do I = 2,NDISC(2)
            XLN2SIG=XLN2SIG+(DLNVG(2,I)-XLNVG)**2*XNK(I+NDISC(1))
        end do
        do I = 1,NSEC
            XLN2SIG = XLN2SIG + XM(I+NDISCT)/DVK(I)*((DLNVL(I+1)-XLNVG)**3 - (DLNVL(I)-XLNVG)**3)/3.0D0
        end do
        XLN2SIG = XLN2SIG/XNN/9.0
        TXLN2SIG = dexp(dsqrt(XLN2SIG))

    else
        XNN = 0.0
        XLNVG = 0.0
        XMM1 = 0.0
        do I = 2,NDISC(1)
            XNK(I) = XM(I)/VGSQ(1,I)
            XN(I) = XNK(I)/VG(1,1)
            XNN = XNN + XNK(I)
            XMM1 = XMM1 + XM(I)/VG(1,I)
            XLNVG = XLNVG + DLNVG(1,I)*XNK(I)
        end do
        do I = 2,NDISC(2)
            IND = I+NDISC(1)
            XNK(IND) = XM(IND)/VGSQ(2,I)
            XN(IND) = XNK(IND)/VG(2,1)
            XNN = XNN + XNK(IND)
            XMM1 = XMM1 + XM(IND)/VG(2,I)
            XLNVG = XLNVG + DLNVG(2,I)*XNK(IND)
        end do
        do I = 1,NSEC
            IND = I+NDISCT
            XNK(IND) = XM(IND)/VL(I+1)/VL(I)
            XN(IND) = XM(IND)/VGSSQ(I)/DVK(I)
            XNN = XNN + XNK(IND)
            XMM1 = XMM1 + XM(IND)*DLNSF/DVK(I)
            XLNVG = XLNVG + XM(IND)/DVK(I)*((1.0+DLNVL(I))/VL(I)-(1.0+DLNVL(I+1))/VL(I+1))
        end do

        XLNVG = XLNVG/XNN
        TVG = dexp(XLNVG)
        VM = XMM1/XNN
        TTVOL = XMM1 + XM(1)/VG(1,1) + XM(NDISCA)/VG(2,1) + (CONCSP(1)*VG(1,1)+CONCSP(2)*VG(2,1))*AVO
        TTVOL2 = XMM1 + XM(1)/VG(1,1) + XM(NDISCA)/VG(2,1)
        XNN2 = XNN + XM(1)/VG(1,1)**2 + XM(1+NDISC(1))/VG(2,1)**2
        XNK(1) = XM(1)/VG(1,1)**2
        XN(1) = XNK(1)/VG(1,1)

        XLN2SIG = 0.0
        do I = 2,NDISC(1)
            XLN2SIG = XLN2SIG + (DLNVG(1,I)-XLNVG)**2*XNK(I)
        end do
        do I = 2,NDISC(2)
            XLN2SIG=XLN2SIG+(DLNVG(2,I)-XLNVG)**2*XNK(I+NDISC(1))
        end do
        do I = 1,NSEC
            XLN2SIG = XLN2SIG+XM(I+NDISCT)/DVK(I)*(((DLNVL(I)-XLNVG+1.0)**2+1.0)/VL(I) - ((DLNVL(I+1)-XLNVG+1.0)**2+1.0)/VL(I+1))
        end do
        XLN2SIG = XLN2SIG/XNN/9.0
        TXLN2SIG = dexp(dsqrt(XLN2SIG))
    end if

    open(2, file=RESULT2)
    write(2,110)COUNT
    write(2,111)ETA
    write(2,112)(VG(1,I),XN(I),XM(I),I=2,NDISC(1))
    write(2,112)(VG(2,I),XN(I+NDISC(1)),XM(I+NDISC(1)),I=2,NDISC(2))
    write(2,112)(VGS(I-NDISCT),XN(I),XM(I),I=NDISC1,M)
    write(2,*)
    write(2,118)XNN,TVG,TXLN2SIG,XMM1,VM
    write(2,119)TTVOL
    write(2,*)
    write(2,*)
    110 format(1X,1PE16.7,'  Sec')
    111 format(1X,'ETA = ',I1)
    112 format(1X,1P3E16.7E3)
    118 format(1X,1P5E16.7)
    119 format(1X,1PE16.7)
    open(3, file='selpre.dat')
    write(3,110)COUNT
    write(3,111)ETA
    do I=1,NDISC(1)
        write(3,112)VG(1,I)*XNN2/TTVOL2,XN(I)*TTVOL2/XNN2**2
    end do
    do I=NDISC1,M
        write(3,112)VGS(I-NDISCT)*XNN2/TTVOL2,XN(I)*TTVOL2/XNN2**2
    end do
    write(3,*)
    write(3,118)XNN,TVG,TXLN2SIG,XMM1,VM
    write(3,119)TTVOL
    write(3,*)
    write(3,*)

    open(4, file='sdf.dat')
    write(4,120)COUNT,XNN,TVG,TXLN2SIG,XMM1,VM,TTVOL
    120 format(1X,1P7E16.7E3)

    return
    end subroutine OT

end module ot_mod


subroutine couple(indj,a,b,c)
  !
  !.....THIS IS THE ROUTINE CALCULATES THE MATRIX ELEMENT OF
  !     <Ylm' Xs'|s*l|Ylm Xs>. IT GENERATES THE ARRAY COUP WHICH WILL
  !     BE USED IN THE SPIN-ORIBIT PROGRAM.   L=0 DOESN'T COUPLE.
  !
  USE param
  USE couples
  IMPLICIT REAL*8(A-H,O-Z)

  COMPLEX*16 COUP(LABC,-LABC:LABC,-LABC:LABC,2,2),imag,T(2,2),sum,czero
  imag = (0.d0,1.d0)
  czero = (0.d0,0.d0)

  T(1,1)=exp(imag*(a+c)/2.d0)*cos(b/2.d0)
  T(1,2)=exp(imag*(a-c)/2.d0)*sin(b/2.d0)
  T(2,1)=-dconjg(T(1,2))
  T(2,2)=dconjg(T(1,1))

  !write(6,*)'COUPLE:',a,b,c
  !write(6,*)
  !write(6,*)t(1,1),t(1,2)
  !write(6,*)t(2,1),t(2,2)
  !write(6,*)

  do isi=1,2
     do isf=1,2
        do l=1,labc
           do mi=-labc,labc
              do mf=-labc,labc
                 coup(l,mi,mf,isi,isf)=(0.d0,0.d0)
                 couplo(indj,l,mi,mf,isi,isf)=(0.d0,0.d0)
              enddo
           enddo
        enddo
     enddo
  enddo

  !
  DO L=1,LABC
     DO MF=-L,L
        !
        ! <mf||mf>
        !!PB 15.9.2004          a = dfloat(mf) * cos(theta)/2.d0
        coup(l,mf,mf,1,1) = -dfloat(mf)/2.d0
        coup(l,mf,mf,2,2)  = dfloat(mf)/2.d0
        coup(l,mf,mf,1,2) = czero
        coup(l,mf,mf,2,1) = czero
        do is1=1,2
           do is2=1,2
              sum=czero
              do i=1,2
                 do j=1,2
                    sum=sum+dconjg(T(i,is1))*T(j,is2)*coup(l,mf,mf,i,j)
                 end do
              end do
              couplo(indj,l,mf,mf,is1,is2)=sum
           end do
        end do
        ! <mf||mf-1>
        if (mf.gt.-l) then
           coup(l,mf,mf-1,1,1) = czero
           coup(l,mf,mf-1,2,2) = czero
           coup(l,mf,mf-1,2,1) = czero
           coup(l,mf,mf-1,1,2) = sqrt(dfloat((l+mf)*(l-mf+1)))/2.d0
           do is1=1,2
              do is2=1,2
                 sum=czero
                 do i=1,2
                    do j=1,2
                       sum=sum+dconjg(T(i,is1))*T(j,is2)*coup(l,mf,mf-1,i,j)
                    end do
                 end do
                 couplo(indj,l,mf,mf-1,is1,is2)=sum
              end do
           end do
        endif
        ! <mf||mf+1>
        if (mf.lt.l) then
           coup(l,mf,mf+1,1,1) = czero
           coup(l,mf,mf+1,2,2) = czero
           coup(l,mf,mf+1,2,1) = sqrt(dfloat((l-mf)*(l+mf+1)))/2.d0
           coup(l,mf,mf+1,1,2) = czero
           do is1=1,2
              do is2=1,2
                 sum=czero
                 do i=1,2
                    do j=1,2
                       sum=sum+dconjg(T(i,is1))*T(j,is2)*coup(l,mf,mf+1,i,j)
                    end do
                 end do
                 couplo(indj,l,mf,mf+1,is1,is2)=sum
              end do
           end do
        endif
        ! <mf-1||mf>
        if (mf.gt.-l) then
           coup(l,mf-1,mf,1,1) = czero
           coup(l,mf-1,mf,2,2) = czero
           coup(l,mf-1,mf,2,1) = sqrt(dfloat((l+mf)*(l-mf+1)))/2.d0
           coup(l,mf-1,mf,1,2) = czero
           do is1=1,2
              do is2=1,2
                 sum=czero
                 do i=1,2
                    do j=1,2
                       sum=sum+dconjg(T(i,is1))*T(j,is2)*coup(l,mf-1,mf,i,j)
                    end do
                 end do
                 couplo(indj,l,mf-1,mf,is1,is2)=sum
              end do
           end do
        endif
        ! <mf+1||mf>
        if (mf.lt.l) then
           coup(l,mf,mf+1,1,1) = czero
           coup(l,mf,mf+1,2,2) = czero
           coup(l,mf,mf+1,2,1) = czero
           coup(l,mf,mf+1,1,2) = sqrt(dfloat((l-mf)*(l+mf+1)))/2.d0
           do is1=1,2
              do is2=1,2
                 sum=czero
                 do i=1,2
                    do j=1,2
                       sum=sum+dconjg(T(i,is1))*T(j,is2)*coup(l,mf+1,mf,i,j)
                    end do
                 end do
                 couplo(indj,l,mf+1,mf,is1,is2)=sum
              end do
           end do
        endif
     enddo
  enddo

16 continue
  RETURN
END subroutine couple


module m_Poisson
  use MPI
  use m_decomp2d
  use m_TypeDef
  use m_LogInfo
  use m_Parameters
  use m_MeshAndMetries
  use iso_c_binding
  use m_Variables,only: mb1
  use m_Tools,only: InverseTridiagonal,InversePeriodicTridiagonal
  implicit none
  private
  include "fftw3.f03"

  real(RK),save::normfft
  procedure(),pointer::clcPPE
  type(decomp_info),allocatable::decomp_PPE
  real(RK),save,allocatable,dimension(:)::WaveNumX,WaveNumZ
  type(C_PTR),save::fwd_plan_x,bwd_plan_x,fwd_plan_z,bwd_plan_z
  real(RK),save,allocatable,dimension(:,:,:)::a_reduce,c_reduce

  public:: InitPoissonSolver,clcPPE,Destory_Poisson_FFT_Plan
contains

  !******************************************************************
  ! InitPoissonSolver
  !******************************************************************
  subroutine InitPoissonSolver(prsrc,prphiHalo)
    implicit none
    real(RK),dimension(y1start(1):y1end(1),y1start(2):y1end(2),y1start(3):y1end(3)),intent(inout)::prsrc,prphiHalo

    ! locals
    real(RK)::wa1,wa3,best_time,t1,t2
    integer::i,k,iErr01,iErr02,iChoice,IsReduce,IsReduceR

    ! Modified wave number in x1 and x3 direct.
    allocate(WaveNumX(nxc), Stat =iErr01)
    allocate(WaveNumZ(nzc), Stat =iErr02)
    if(abs(iErr01)+abs(iErr02) /= 0) call MainLog%CheckForError(ErrT_Abort,"InitPoissonSolver","Allocation failed")
    do i=1,nxc
      wa1= twopi*real(i-1,RK)/real(nxc,RK)
      WaveNumX(i)=rdx2/288.0_RK*(cos(three*wa1)-54.0_RK*cos(two*wa1)+783.0_RK*cos(wa1)-730.0_RK)
    enddo
    do k=1,nzc
      wa3= twopi*real(k-1,RK)/real(nzc,RK)
      WaveNumZ(k)=rdz2/288.0_RK*(cos(three*wa3)-54.0_RK*cos(two*wa3)+783.0_RK*cos(wa3)-730.0_RK)
    enddo
    normfft = one/(real(nxc,RK)*real(nzc,RK))

    if(nrank==0) write(*,*) ' '
    if(nrank==0) write(*,*) 'Auto-tuning mode for Poisson Solver......'
    best_time=huge(t1)

    ! Choice-1
    call Create_Poisson_FFT_Plan(x1size,z2size)
    call MPI_BARRIER(MPI_COMM_WORLD,iErr01)
    t1=MPI_WTIME()
    do k=1,15
      call clcPPE_x1(prsrc,prphiHalo)
    enddo
    t2=MPI_WTIME()-t1
    call MPI_ALLREDUCE(t2,t1,1,real_type,MPI_SUM,MPI_COMM_WORLD,iErr01)
    if(nrank==0)print*,'  Choice-1, time=',t1
    if(best_time>t1) then
      best_time=t1
      iChoice=1
    endif
    call Destory_Poisson_FFT_Plan()

    ! Choice-2
    call Create_Poisson_FFT_Plan(x2size,z1size)
    call MPI_BARRIER(MPI_COMM_WORLD,iErr01)
    t1=MPI_WTIME()
    do k=1,15
      call clcPPE_z1(prsrc,prphiHalo)
    enddo
    t2=MPI_WTIME()-t1
    call MPI_ALLREDUCE(t2,t1,1,real_type,MPI_SUM,MPI_COMM_WORLD,iErr01)
    if(nrank==0)print*,'  Choice-2, time=',t1
    if(best_time>t1) then
      best_time=t1
      iChoice=2
    endif
    call Destory_Poisson_FFT_Plan()

    ! Choice-3
    call Create_Poisson_FFT_Plan(x1size,z2size)
    IsReduce=1
    if(z2size(2)<4)IsReduce=0
    call MPI_ALLREDUCE(IsReduce,IsReduceR,1,MPI_INT,MPI_MIN,MPI_COMM_WORLD,iErr01)
    if(IsReduceR==1) then
      allocate(decomp_PPE)
      allocate(a_reduce(y2start(1):y2end(1),2*p_row,y2start(3):y2end(3)))
      allocate(c_reduce(y2start(1):y2end(1),2*p_row,y2start(3):y2end(3)))
      call Initialize_ReduceMatrix(z2start,z2end,'z')
      call MPI_BARRIER(MPI_COMM_WORLD,iErr01)
      t1=MPI_WTIME()
      do k=1,15
        call clcPPE_x1_reduce(prsrc,prphiHalo)
      enddo
      t2=MPI_WTIME()-t1
      call MPI_ALLREDUCE(t2,t1,1,real_type,MPI_SUM,MPI_COMM_WORLD,iErr01)
      if(nrank==0)print*,'  Choice-3, time=',t1
      if(best_time>t1) then
        best_time=t1
        iChoice=3
      endif
      call decomp_info_finalize(decomp_PPE)
      deallocate(decomp_PPE,a_reduce,c_reduce)
    else
      if(nrank==0)print*,'  Choice-3, z2size<4, ignore'
    endif
    call Destory_Poisson_FFT_Plan()

    ! Choice-4
    call Create_Poisson_FFT_Plan(x2size,z1size)
    IsReduce=1
    if(x2size(2)<4)IsReduce=0
    call MPI_ALLREDUCE(IsReduce,IsReduceR,1,MPI_INT,MPI_MIN,MPI_COMM_WORLD,iErr01)
    if(IsReduceR==1) then
      allocate(decomp_PPE)
      allocate(a_reduce(y2start(1):y2end(1),2*p_col,y2start(3):y2end(3)))
      allocate(c_reduce(y2start(1):y2end(1),2*p_col,y2start(3):y2end(3)))
      call Initialize_ReduceMatrix(x2start,x2end,'x')
      call MPI_BARRIER(MPI_COMM_WORLD,iErr01)
      t1=MPI_WTIME()
      do k=1,15
        call clcPPE_z1_reduce(prsrc,prphiHalo)
      enddo
      t2=MPI_WTIME()-t1
      call MPI_ALLREDUCE(t2,t1,1,real_type,MPI_SUM,MPI_COMM_WORLD,iErr01)
      if(nrank==0)print*,'  Choice-4, time=',t1
      if(best_time>t1) then
        best_time=t1
        iChoice=4
      endif
      call decomp_info_finalize(decomp_PPE)
      deallocate(decomp_PPE,a_reduce,c_reduce)
    else
      if(nrank==0)print*,'  Choice-4, x2size<4, ignore'
    endif
    call Destory_Poisson_FFT_Plan()

    if(nrank==0) then
      write(*,'(A,I1)')' The best Poisson Solver choice is probably Choice-',iChoice
      print*,'Corresponding Global Data Transpose is: '
    endif
    if(iChoice==1) then
      clcPPE => clcPPE_x1
      call Create_Poisson_FFT_Plan(x1size,z2size)
      if(nrank==0) print*,'  y1 -> x1 -> z2 -> y2 -> z2 -> x1 -> y1'
    elseif(iChoice==2) then
      clcPPE => clcPPE_z1
      call Create_Poisson_FFT_Plan(x2size,z1size)
      if(nrank==0) print*,'  y1 -> z1 -> x2 -> y2 -> x2 -> z1 -> y1'
    elseif(iChoice==3) then
      clcPPE => clcPPE_x1_reduce
      call Create_Poisson_FFT_Plan(x1size,z2size)
      if(nrank==0) print*,'  y1 -> x1 -> z2 -> x1 -> y1'
      allocate(decomp_PPE)
      allocate(a_reduce(y2start(1):y2end(1),2*p_row,y2start(3):y2end(3)))
      allocate(c_reduce(y2start(1):y2end(1),2*p_row,y2start(3):y2end(3)))
      call Initialize_ReduceMatrix(z2start,z2end,'z')
    elseif(iChoice==4) then
      clcPPE => clcPPE_z1_reduce
      call Create_Poisson_FFT_Plan(x2size,z1size)
      if(nrank==0) print*,'  y1 -> z1 -> x2 -> z1 -> y1'
      allocate(decomp_PPE)
      allocate(a_reduce(y2start(1):y2end(1),2*p_col,y2start(3):y2end(3)))
      allocate(c_reduce(y2start(1):y2end(1),2*p_col,y2start(3):y2end(3)))
      call Initialize_ReduceMatrix(x2start,x2end,'x')
    endif
    if(nrank==0) write(*,*)' '
    prsrc=zero; prphiHalo=zero
  end subroutine InitPoissonSolver

  !******************************************************************
  ! Create_Poisson_FFT_Plan
  !******************************************************************
  subroutine Create_Poisson_FFT_Plan(xsizeIn,zsizeIn)
    implicit none
    integer,dimension(3),intent(in)::xsizeIn,zsizeIn

    ! locals
    integer::plan_type
    type(fftw_iodim)::iodim(1),iodim_howmany(1)
#ifdef OverWriteFFT
    real(RK),dimension(:,:,:),allocatable::Arr
#else
    real(RK),dimension(:,:,:),allocatable::Arr1,Arr2
#endif

    integer(C_FFTW_R2R_KIND)::kind_fwd(1),kind_bwd(1)

    if(FFTW_plan_type == 1) then
      plan_type=FFTW_MEASURE
    else
      plan_type=FFTW_ESTIMATE
    endif

    ! FFT in x
    iodim(1)%n  = xsizeIn(1)
    iodim(1)%is = 1
    iodim(1)%os = 1
    iodim_howmany(1)%n  = xsizeIn(2)*xsizeIn(3)
    iodim_howmany(1)%is = xsizeIn(1)
    iodim_howmany(1)%os = xsizeIn(1)
    kind_fwd = FFTW_R2HC
    kind_bwd = FFTW_HC2R
#ifdef OverWriteFFT
    allocate(Arr(xsizeIn(1),xsizeIn(2),xsizeIn(3)))
    fwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr, Arr, kind_fwd,plan_type)
    bwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr, Arr, kind_bwd,plan_type)
    deallocate(Arr)
#else
    allocate(Arr1(xsizeIn(1),xsizeIn(2),xsizeIn(3)))
    allocate(Arr2(xsizeIn(1),xsizeIn(2),xsizeIn(3)))
    fwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr1,Arr2,kind_fwd,plan_type)
    bwd_plan_x = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr1,Arr2,kind_bwd,plan_type)
    deallocate(Arr1,Arr2)
#endif

    ! FFT in z
    iodim(1)%n  = zsizeIn(3)
    iodim(1)%is = zsizeIn(1)*zsizeIn(2)
    iodim(1)%os = zsizeIn(1)*zsizeIn(2)
    iodim_howmany(1)%n  = zsizeIn(1)*zsizeIn(2)
    iodim_howmany(1)%is = 1
    iodim_howmany(1)%os = 1
    kind_fwd = FFTW_R2HC
    kind_bwd = FFTW_HC2R
#ifdef OverWriteFFT
    allocate(Arr(zsizeIn(1),zsizeIn(2),zsizeIn(3)))
    fwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr, Arr, kind_fwd,plan_type)
    bwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr, Arr, kind_bwd,plan_type)
    deallocate(Arr)
#else
    allocate(Arr1(zsizeIn(1),zsizeIn(2),zsizeIn(3)))
    allocate(Arr2(zsizeIn(1),zsizeIn(2),zsizeIn(3)))
    fwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr1,Arr2,kind_fwd,plan_type)
    bwd_plan_z = fftw_plan_guru_r2r(1,iodim,1,iodim_howmany,Arr1,Arr2,kind_bwd,plan_type)
    deallocate(Arr1,Arr2)
#endif
  end subroutine Create_Poisson_FFT_Plan

  !******************************************************************
  ! Initialize_ReduceMatrix
  !******************************************************************
  subroutine Initialize_ReduceMatrix(startIn,endIn,x_or_z)
    implicit none
    character(len=1),intent(in)::x_or_z
    integer,dimension(3),intent(in)::startIn,endIn

    ! locals
    real(RK)::rTemp
    integer::ic,jc,kc
    logical,dimension(6)::initializeIn
    real(RK),dimension(:,:,:),allocatable::ArrM,ArrC,ArrP

    initializeIn=.false.
    if(x_or_z=='x') then
      initializeIn(4)=.true.
      call decomp_info_init(nxc,2*p_col,nzc,decomp_PPE,initialize=initializeIn)
    elseif(x_or_z=='z') then
      initializeIn(5)=.true.
      call decomp_info_init(nxc,2*p_row,nzc,decomp_PPE,initialize=initializeIn)
    endif
    allocate(ArrM(startIn(1):endIn(1),startIn(2):endIn(2),startIn(3):endIn(3)))
    allocate(ArrC(startIn(1):endIn(1),startIn(2):endIn(2),startIn(3):endIn(3)))
    allocate(ArrP(startIn(1):endIn(1),startIn(2):endIn(2),startIn(3):endIn(3)))
    do kc=startIn(3),endIn(3)
      do jc=startIn(2),endIn(2)
        do ic=startIn(1),endIn(1)
          ArrM(ic,jc,kc)=am2ph(jc)
          ArrC(ic,jc,kc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          ArrP(ic,jc,kc)=ap2ph(jc)
        enddo
      enddo
    enddo
    IF(nrank==0) THEN
      ArrM(1,1,1)=zero
      ArrC(1,1,1)=one
      ArrP(1,1,1)=zero
    ENDIF
    do kc=startIn(3),endIn(3)
      do ic=startIn(1),endIn(1)
        jc=startIn(2)
        ArrM(ic,jc,kc)=ArrM(ic,jc,kc)/ArrC(ic,jc,kc)
        ArrP(ic,jc,kc)=ArrP(ic,jc,kc)/ArrC(ic,jc,kc)
        jc=startIn(2)+1
        ArrM(ic,jc,kc)=ArrM(ic,jc,kc)/ArrC(ic,jc,kc)
        ArrP(ic,jc,kc)=ArrP(ic,jc,kc)/ArrC(ic,jc,kc)
        do jc=startIn(2)+2,endIn(2)
          rTemp=one/(ArrC(ic,jc,kc)-ArrM(ic,jc,kc)*ArrP(ic,jc-1,kc))
          ArrP(ic,jc,kc)= rTemp*ArrP(ic,jc,kc)
          ArrM(ic,jc,kc)=-rTemp*ArrM(ic,jc,kc)*ArrM(ic,jc-1,kc)
        enddo
        do jc=endIn(2)-2,startIn(2)+1,-1
          ArrM(ic,jc,kc)= ArrM(ic,jc,kc)-ArrP(ic,jc,kc)*ArrM(ic,jc+1,kc)
          ArrP(ic,jc,kc)=-ArrP(ic,jc,kc)*ArrP(ic,jc+1,kc)
        enddo
        jc=startIn(2)
        rTemp=one/(one-ArrM(ic,jc+1,kc)*ArrP(ic,jc,kc))
        ArrM(ic,jc,kc)= rTemp*ArrM(ic,jc,kc)
        ArrP(ic,jc,kc)=-rTemp*ArrP(ic,jc,kc)*ArrP(ic,jc+1,kc)
      enddo
    enddo
    deallocate(ArrC)
    allocate(ArrC(startIn(1):endIn(1),2,startIn(3):endIn(3)))

    do kc=startIn(3),endIn(3)
      do ic=startIn(1),endIn(1)
        ArrC(ic,1,kc)=ArrM(ic,startIn(2),kc)
        ArrC(ic,2,kc)=ArrM(ic,endIn(2),  kc)
      enddo
    enddo
    if(x_or_z=='x') then
      call transpose_x2_to_y2(ArrC,a_reduce,decomp_PPE)
    elseif(x_or_z=='z') then
      call transpose_z2_to_y2(ArrC,a_reduce,decomp_PPE)
    endif
    do kc=startIn(3),endIn(3)
      do ic=startIn(1),endIn(1)
        ArrC(ic,1,kc)=ArrP(ic,startIn(2),kc)
        ArrC(ic,2,kc)=ArrP(ic,endIn(2),  kc)
      enddo
    enddo
    if(x_or_z=='x') then
      call transpose_x2_to_y2(ArrC,c_reduce,decomp_PPE)
    elseif(x_or_z=='z') then
      call transpose_z2_to_y2(ArrC,c_reduce,decomp_PPE)
    endif
    deallocate(ArrM,ArrC,ArrP)
  end subroutine Initialize_ReduceMatrix

  !******************************************************************
  ! Destory_Poisson_FFT_Plan
  !******************************************************************
  subroutine Destory_Poisson_FFT_Plan()
    implicit none
    call dfftw_destroy_plan(fwd_plan_x,bwd_plan_x)
    call dfftw_destroy_plan(fwd_plan_z,bwd_plan_z)
    if(allocated(decomp_PPE)) then
      call decomp_info_finalize(decomp_PPE)
      deallocate(decomp_PPE)
    endif
  end subroutine Destory_Poisson_FFT_Plan

  !******************************************************************
  ! clcPPE_x1
  !******************************************************************
  subroutine clcPPE_x1(prsrc, prphiHalo)
    implicit none
    real(RK),dimension(y1start(1):y1end(1),y1start(2):y1end(2),y1start(3):y1end(3)),intent(inout)::prsrc
    real(RK),dimension(mb1%xmm:mb1%xpm,mb1%ymm:mb1%ypm,mb1%zmm:mb1%zpm),intent(out)::prphiHalo

    ! locals
    integer::ic,jc,kc
#ifdef OverWriteFFT
    real(RK),dimension(x1size(1),x1size(2),x1size(3))::arrx
    real(RK),dimension(z2size(1),z2size(2),z2size(3))::arrz
#else
    real(RK),dimension(x1size(1),x1size(2),x1size(3))::arrx1,arrx2
    real(RK),dimension(z2size(1),z2size(2),z2size(3))::arrz1,arrz2
#endif
    real(RK),dimension(y2start(1):y2end(1),y2start(2):y2end(2),y2start(3):y2end(3))::prTemp
    real(RK),dimension(y2start(1):y2end(1),y2start(2):y2end(2))::tridmj,tridcj,tridpj,tridfj

#ifdef OverWriteFFT
    call transpose_y1_to_x1(prsrc,arrx)
    call dfftw_execute_r2r(fwd_plan_x,arrx,arrx)
    call transpose_x1_to_z2(arrx,arrz)
    call dfftw_execute_r2r(fwd_plan_z,arrz,arrz)
    call transpose_z2_to_y2(arrz,prTemp)
#else
    call transpose_y1_to_x1(prsrc,arrx1)
    call dfftw_execute_r2r(fwd_plan_x,arrx1,arrx2)
    call transpose_x1_to_z2(arrx2,arrz1)
    call dfftw_execute_r2r(fwd_plan_z,arrz1,arrz2)
    call transpose_z2_to_y2(arrz2,prTemp)
#endif

    do jc=y2start(2),y2end(2)
      do ic=y2start(1),y2end(1)
        tridmj(ic,jc)=am2ph(jc)
        tridpj(ic,jc)=ap2ph(jc)
      enddo
    enddo
    IF(nrank==0) THEN
      do kc=2,y2end(3)
        do jc=1,nyc
          do ic=1,y2end(1)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prTemp(:,:,kc),y2size(1),nyc)
      enddo

      ! for nrank=0, y1start(1)=y1start(3)=1
      ic=1; jc=1; kc=1;
      tridpj(ic,jc)=zero
      tridcj(ic,jc)=one
      tridmj(ic,jc)=zero
      tridfj(ic,jc)=zero
      do ic=2,y2end(1)
        tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
        tridfj(ic,jc)=prTemp(ic,jc,kc)
      enddo
      do jc=2,nyc
        do ic=1,y2end(1)
          tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          tridfj(ic,jc)=prTemp(ic,jc,kc)
        enddo
      enddo
      call InverseTridiagonal(tridmj,tridcj,tridpj,tridfj,y2size(1),nyc)
      do jc=1,nyc
        do ic=1,y2end(1)
          prTemp(ic,jc,kc)= tridfj(ic,jc)
        enddo
      enddo
    ELSE
      do kc=y2start(3),y2end(3)
        do jc=y2start(2),y2end(2)
          do ic=y2start(1),y2end(1)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prTemp(:,:,kc),y2size(1),nyc)
      enddo
    ENDIF
#ifdef OverWriteFFT
    call transpose_y2_to_z2(prTemp,arrz)
    call dfftw_execute_r2r(bwd_plan_z,arrz, arrz)
    call transpose_z2_to_x1(arrz,arrx)
    call dfftw_execute_r2r(bwd_plan_x,arrx, arrx)
    call transpose_x1_to_y1(arrx,prsrc)
#else
    call transpose_y2_to_z2(prTemp,arrz2)
    call dfftw_execute_r2r(bwd_plan_z,arrz2, arrz1)
    call transpose_z2_to_x1(arrz1,arrx2)
    call dfftw_execute_r2r(bwd_plan_x,arrx2, arrx1)
    call transpose_x1_to_y1(arrx1,prsrc)
#endif

    do kc=y1start(3),y1end(3)
      do jc=y1start(2),y1end(2)
        do ic=y1start(1),y1end(1)
          prphiHalo(ic,jc,kc) = prsrc(ic,jc,kc)*normfft
        enddo
      enddo
    enddo
  end subroutine clcPPE_x1

  !******************************************************************
  ! clcPPE_x1_reduce
  !******************************************************************
  subroutine clcPPE_x1_reduce(prsrc, prphiHalo)
    implicit none
    real(RK),dimension(y1start(1):y1end(1),y1start(2):y1end(2),y1start(3):y1end(3)),intent(inout)::prsrc
    real(RK),dimension(mb1%xmm:mb1%xpm,mb1%ymm:mb1%ypm,mb1%zmm:mb1%zpm),intent(out)::prphiHalo

    ! locals
    real(RK)::rTemp
    integer::ic,jc,kc,jp,jm
#ifdef OverWriteFFT
    real(RK),dimension(x1size(1),x1size(2),x1size(3))::arrx
#else
    real(RK),dimension(x1size(1),x1size(2),x1size(3))::arrx1,arrx2
#endif
    real(RK),dimension(z2start(1):z2end(1),z2start(2):z2end(2),z2start(3):z2end(3))::arrz1,arrz2,arrz3
    real(RK),dimension(z2start(1):z2end(1),2,z2start(3):z2end(3))::arrz2_reduce
    real(RK),dimension(y2start(1):y2end(1),2*p_row,y2start(3):y2end(3))::arry2_reduce
    real(RK),dimension(z2start(1):z2end(1),z2start(2):z2end(2))::tridmj,tridcj,tridpj,tridfj

#ifdef OverWriteFFT
    call transpose_y1_to_x1(prsrc,arrx)
    call dfftw_execute_r2r(fwd_plan_x,arrx,arrx)
    call transpose_x1_to_z2(arrx,arrz2)
    call dfftw_execute_r2r(fwd_plan_z,arrz2,arrz2)
#else
    call transpose_y1_to_x1(prsrc,arrx1)
    call dfftw_execute_r2r(fwd_plan_x,arrx1,arrx2)
    call transpose_x1_to_z2(arrx2,arrz1)
    call dfftw_execute_r2r(fwd_plan_z,arrz1,arrz2)
#endif

    IF(nrank==0) THEN
      do kc=2,z2end(3)
        do jc=z2start(2),z2end(2)
          do ic=z2start(1),z2end(1)
            tridmj(ic,jc)=am2ph(jc)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
            tridpj(ic,jc)=ap2ph(jc)
            tridfj(ic,jc)=arrz2(ic,jc,kc)
          enddo
        enddo
        do ic=z2start(1),z2end(1)
          jc=z2start(2)
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
          jc=z2start(2)+1
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        enddo
        do jc=z2start(2)+2,z2end(2)
          jm=jc-1
          do ic=z2start(1),z2end(1)
            rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
            tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
            tridpj(ic,jc)= rTemp*tridpj(ic,jc)
            tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
          enddo
        enddo
        do jc=z2end(2)-2,z2start(2)+1,-1
          jp=jc+1
          do ic=z2start(1),z2end(1)
            tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
            tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
            tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
          enddo
        enddo
        do ic=z2start(1),z2end(1)
          jc=z2start(2); jp=jc+1
          rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
          tridmj(ic,jc)= rTemp*tridmj(ic,jc)
          tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
          arrz2_reduce(ic,1,kc)=tridfj(ic,z2start(2))
          arrz2_reduce(ic,2,kc)=tridfj(ic,z2end(2))
        enddo
        do jc=z2start(2),z2end(2)
          do ic=z2start(1),z2end(1)
            arrz1(ic,jc,kc)=tridmj(ic,jc)
            arrz3(ic,jc,kc)=tridpj(ic,jc)
            arrz2(ic,jc,kc)=tridfj(ic,jc)
          enddo
        enddo
      enddo

      ! for nrank=0, z2start(1)=z2start(2)=1
      ic=1; jc=1; kc=1
      tridmj(ic,jc)=zero
      tridcj(ic,jc)=one
      tridpj(ic,jc)=zero
      tridfj(ic,jc)=zero
      do ic=2,z2end(1)
        tridmj(ic,jc)=am2ph(jc)
        tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
        tridpj(ic,jc)=ap2ph(jc)
        tridfj(ic,jc)=arrz2(ic,jc,kc)
      enddo
      do jc=2,z2end(2)
        do ic=z2start(1),z2end(1)
          tridmj(ic,jc)=am2ph(jc)
          tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          tridpj(ic,jc)=ap2ph(jc)
          tridfj(ic,jc)=arrz2(ic,jc,kc)
        enddo
      enddo
      do ic=z2start(1),z2end(1)
        jc=z2start(2)
        tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
        tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
        tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        jc=z2start(2)+1
        tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
        tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
        tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
      enddo
      do jc=z2start(2)+2,z2end(2)
        jm=jc-1
        do ic=z2start(1),z2end(1)
          rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
          tridpj(ic,jc)= rTemp*tridpj(ic,jc)
          tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
        enddo
      enddo
      do jc=z2end(2)-2,z2start(2)+1,-1
        jp=jc+1
        do ic=z2start(1),z2end(1)
          tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
          tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
          tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
        enddo
      enddo
      do ic=z2start(1),z2end(1)
        jc=z2start(2); jp=jc+1
        rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
        tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
        tridmj(ic,jc)= rTemp*tridmj(ic,jc)
        tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
        arrz2_reduce(ic,1,kc)=tridfj(ic,z2start(2))
        arrz2_reduce(ic,2,kc)=tridfj(ic,z2end(2))
      enddo
      do jc=z2start(2),z2end(2)
        do ic=z2start(1),z2end(1)
          arrz1(ic,jc,kc)=tridmj(ic,jc)
          arrz3(ic,jc,kc)=tridpj(ic,jc)
          arrz2(ic,jc,kc)=tridfj(ic,jc)
        enddo
      enddo
    ELSE
      do kc=z2start(3),z2end(3)
        do jc=z2start(2),z2end(2)
          do ic=z2start(1),z2end(1)
            tridmj(ic,jc)=am2ph(jc)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
            tridpj(ic,jc)=ap2ph(jc)
            tridfj(ic,jc)=arrz2(ic,jc,kc)
          enddo
        enddo
        do ic=z2start(1),z2end(1)
          jc=z2start(2)
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
          jc=z2start(2)+1
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        enddo
        do jc=z2start(2)+2,z2end(2)
          jm=jc-1
          do ic=z2start(1),z2end(1)
            rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
            tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
            tridpj(ic,jc)= rTemp*tridpj(ic,jc)
            tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
          enddo
        enddo
        do jc=z2end(2)-2,z2start(2)+1,-1
          jp=jc+1
          do ic=z2start(1),z2end(1)
            tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
            tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
            tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
          enddo
        enddo
        do ic=z2start(1),z2end(1)
          jc=z2start(2); jp=jc+1
          rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
          tridmj(ic,jc)= rTemp*tridmj(ic,jc)
          tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
          arrz2_reduce(ic,1,kc)=tridfj(ic,z2start(2))
          arrz2_reduce(ic,2,kc)=tridfj(ic,z2end(2))
        enddo
        do jc=z2start(2),z2end(2)
          do ic=z2start(1),z2end(1)
            arrz1(ic,jc,kc)=tridmj(ic,jc)
            arrz3(ic,jc,kc)=tridpj(ic,jc)
            arrz2(ic,jc,kc)=tridfj(ic,jc)
          enddo
        enddo
      enddo
    ENDIF
    call transpose_z2_to_y2(arrz2_reduce,arry2_reduce,decomp_PPE)
    do kc=y2start(3),y2end(3)
      call InverseTridiagonal_reduce(a_reduce(:,:,kc),c_reduce(:,:,kc),arry2_reduce(:,:,kc),y2size(1),2*p_row)
    enddo
    call transpose_y2_to_z2(arry2_reduce,arrz2_reduce,decomp_PPE)
    do kc=z2start(3),z2end(3)
      do ic=z2start(1),z2end(1)
        arrz2(ic,z2start(2),kc)=arrz2_reduce(ic,1,kc)
        arrz2(ic,z2end(2),  kc)=arrz2_reduce(ic,2,kc)
      enddo
      do jc=z2start(2)+1,z2end(2)-1
        do ic=z2start(1),z2end(1)
          arrz2(ic,jc,kc)=arrz2(ic,jc,kc)-arrz1(ic,jc,kc)*arrz2_reduce(ic,1,kc)-arrz3(ic,jc,kc)*arrz2_reduce(ic,2,kc)
        enddo
      enddo
    enddo

#ifdef OverWriteFFT
    call dfftw_execute_r2r(bwd_plan_z,arrz2, arrz2)
    call transpose_z2_to_x1(arrz2,arrx)
    call dfftw_execute_r2r(bwd_plan_x,arrx, arrx)
    call transpose_x1_to_y1(arrx,prsrc)
#else
    call dfftw_execute_r2r(bwd_plan_z,arrz2, arrz1)
    call transpose_z2_to_x1(arrz1,arrx2)
    call dfftw_execute_r2r(bwd_plan_x,arrx2, arrx1)
    call transpose_x1_to_y1(arrx1,prsrc)
#endif
    do kc=y1start(3),y1end(3)
      do jc=y1start(2),y1end(2)
        do ic=y1start(1),y1end(1)
          prphiHalo(ic,jc,kc) = prsrc(ic,jc,kc)*normfft
        enddo
      enddo
    enddo
  end subroutine clcPPE_x1_reduce

  !******************************************************************
  ! clcPPE_z1
  !******************************************************************
  subroutine clcPPE_z1(prsrc, prphiHalo)
    implicit none
    real(RK),dimension(y1start(1):y1end(1),y1start(2):y1end(2),y1start(3):y1end(3)),intent(inout)::prsrc
    real(RK),dimension(mb1%xmm:mb1%xpm,mb1%ymm:mb1%ypm,mb1%zmm:mb1%zpm),intent(out)::prphiHalo

    ! locals
    integer::ic,jc,kc
#ifdef OverWriteFFT
    real(RK),dimension(x2size(1),x2size(2),x2size(3))::arrx
    real(RK),dimension(z1size(1),z1size(2),z1size(3))::arrz
#else
    real(RK),dimension(x2size(1),x2size(2),x2size(3))::arrx1,arrx2
    real(RK),dimension(z1size(1),z1size(2),z1size(3))::arrz1,arrz2
#endif
    real(RK),dimension(y2start(1):y2end(1),y2start(2):y2end(2),y2start(3):y2end(3))::prTemp
    real(RK),dimension(y2start(1):y2end(1),y2start(2):y2end(2))::tridmj,tridcj,tridpj,tridfj

#ifdef OverWriteFFT
    call transpose_y1_to_z1(prsrc,arrz)
    call dfftw_execute_r2r(fwd_plan_z,arrz,arrz)
    call transpose_z1_to_x2(arrz,arrx)
    call dfftw_execute_r2r(fwd_plan_x,arrx,arrx)
    call transpose_x2_to_y2(arrx,prTemp)
#else
    call transpose_y1_to_z1(prsrc,arrz1)
    call dfftw_execute_r2r(fwd_plan_z,arrz1,arrz2)
    call transpose_z1_to_x2(arrz2,arrx1)
    call dfftw_execute_r2r(fwd_plan_x,arrx1,arrx2)
    call transpose_x2_to_y2(arrx2,prTemp)
#endif
    do jc=y2start(2),y2end(2)
      do ic=y2start(1),y2end(1)
        tridmj(ic,jc)=am2ph(jc)
        tridpj(ic,jc)=ap2ph(jc)
      enddo
    enddo
    IF(nrank==0) THEN
      do kc=2,y2end(3)
        do jc=1,nyc
          do ic=1,y2end(1)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prTemp(:,:,kc),y2size(1),nyc)
      enddo

      ! for nrank=0, y1start(1)=y1start(3)=1
      ic=1; jc=1; kc=1;
      tridpj(ic,jc)=zero
      tridcj(ic,jc)=one
      tridmj(ic,jc)=zero
      tridfj(ic,jc)=zero
      do ic=2,y2end(1)
        tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
        tridfj(ic,jc)=prTemp(ic,jc,kc)
      enddo
      do jc=2,nyc
        do ic=1,y2end(1)
          tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          tridfj(ic,jc)=prTemp(ic,jc,kc)
        enddo
      enddo
      call InverseTridiagonal(tridmj,tridcj,tridpj,tridfj,y2size(1),nyc)
      do jc=1,nyc
        do ic=1,y2end(1)
          prTemp(ic,jc,kc)= tridfj(ic,jc)
        enddo
      enddo
    ELSE
      do kc=y2start(3),y2end(3)
        do jc=y2start(2),y2end(2)
          do ic=y2start(1),y2end(1)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          enddo
        enddo
        call InverseTridiagonal(tridmj,tridcj,tridpj,prTemp(:,:,kc),y2size(1),nyc)
      enddo
    ENDIF
#ifdef OverWriteFFT
    call transpose_y2_to_x2(prTemp,arrx)
    call dfftw_execute_r2r(bwd_plan_x,arrx, arrx)
    call transpose_x2_to_z1(arrx,arrz)
    call dfftw_execute_r2r(bwd_plan_z,arrz, arrz)
    call transpose_z1_to_y1(arrz,prsrc)
#else
    call transpose_y2_to_x2(prTemp,arrx2)
    call dfftw_execute_r2r(bwd_plan_x,arrx2, arrx1)
    call transpose_x2_to_z1(arrx1,arrz2)
    call dfftw_execute_r2r(bwd_plan_z,arrz2, arrz1)
    call transpose_z1_to_y1(arrz1,prsrc)
#endif
    do kc=y1start(3),y1end(3)
      do jc=y1start(2),y1end(2)
        do ic=y1start(1),y1end(1)
          prphiHalo(ic,jc,kc) = prsrc(ic,jc,kc)*normfft
        enddo
      enddo
    enddo
  end subroutine clcPPE_z1

  !******************************************************************
  ! clcPPE_z1_reduce
  !******************************************************************
  subroutine clcPPE_z1_reduce(prsrc, prphiHalo)
    implicit none
    real(RK),dimension(y1start(1):y1end(1),y1start(2):y1end(2),y1start(3):y1end(3)),intent(inout)::prsrc
    real(RK),dimension(mb1%xmm:mb1%xpm,mb1%ymm:mb1%ypm,mb1%zmm:mb1%zpm),intent(out)::prphiHalo

    ! locals
    real(RK)::rTemp
    integer::ic,jc,kc,jp,jm
#ifdef OverWriteFFT
    real(RK),dimension(z1size(1),z1size(2),z1size(3))::arrz
#else
    real(RK),dimension(z1size(1),z1size(2),z1size(3))::arrz1,arrz2
#endif
    real(RK),dimension(x2start(1):x2end(1),2,x2start(3):x2end(3))::arrx2_reduce
    real(RK),dimension(y2start(1):y2end(1),2*p_col,y2start(3):y2end(3))::arry2_reduce
    real(RK),dimension(x2start(1):x2end(1),x2start(2):x2end(2))::tridmj,tridcj,tridpj,tridfj
    real(RK),dimension(x2start(1):x2end(1),x2start(2):x2end(2),x2start(3):x2end(3))::arrx1,arrx2,arrx3

#ifdef OverWriteFFT
    call transpose_y1_to_z1(prsrc,arrz)
    call dfftw_execute_r2r(fwd_plan_z,arrz,arrz)
    call transpose_z1_to_x2(arrz,arrx2)
    call dfftw_execute_r2r(fwd_plan_x,arrx2,arrx2)
#else
    call transpose_y1_to_z1(prsrc,arrz1)
    call dfftw_execute_r2r(fwd_plan_z,arrz1,arrz2)
    call transpose_z1_to_x2(arrz2,arrx1)
    call dfftw_execute_r2r(fwd_plan_x,arrx1,arrx2)
#endif
    IF(nrank==0) THEN
      do kc=2,x2end(3)
        do jc=x2start(2),x2end(2)
          do ic=x2start(1),x2end(1)
            tridmj(ic,jc)=am2ph(jc)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
            tridpj(ic,jc)=ap2ph(jc)
            tridfj(ic,jc)=arrx2(ic,jc,kc)
          enddo
        enddo
        do ic=x2start(1),x2end(1)
          jc=x2start(2)
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
          jc=x2start(2)+1
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        enddo
        do jc=x2start(2)+2,x2end(2)
          jm=jc-1
          do ic=x2start(1),x2end(1)
            rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
            tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
            tridpj(ic,jc)= rTemp*tridpj(ic,jc)
            tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
          enddo
        enddo
        do jc=x2end(2)-2,x2start(2)+1,-1
          jp=jc+1
          do ic=x2start(1),x2end(1)
            tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
            tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
            tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
          enddo
        enddo
        do ic=x2start(1),x2end(1)
          jc=x2start(2); jp=jc+1
          rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
          tridmj(ic,jc)= rTemp*tridmj(ic,jc)
          tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
          arrx2_reduce(ic,1,kc)=tridfj(ic,x2start(2))
          arrx2_reduce(ic,2,kc)=tridfj(ic,x2end(2))
        enddo
        do jc=x2start(2),x2end(2)
          do ic=x2start(1),x2end(1)
            arrx1(ic,jc,kc)=tridmj(ic,jc)
            arrx3(ic,jc,kc)=tridpj(ic,jc)
            arrx2(ic,jc,kc)=tridfj(ic,jc)
          enddo
        enddo
      enddo

      ! for nrank=0, x2start(2)=x2start(3)=1
      ic=1; jc=1; kc=1
      tridmj(ic,jc)=zero
      tridcj(ic,jc)=one
      tridpj(ic,jc)=zero
      tridfj(ic,jc)=zero
      do ic=2,x2end(1)
        tridmj(ic,jc)=am2ph(jc)
        tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
        tridpj(ic,jc)=ap2ph(jc)
        tridfj(ic,jc)=arrx2(ic,jc,kc)
      enddo
      do jc=2,x2end(2)
        do ic=1,x2end(1)
          tridmj(ic,jc)=am2ph(jc)
          tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
          tridpj(ic,jc)=ap2ph(jc)
          tridfj(ic,jc)=arrx2(ic,jc,kc)
        enddo
      enddo
      do ic=x2start(1),x2end(1)
        jc=x2start(2)
        tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
        tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
        tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        jc=x2start(2)+1
        tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
        tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
        tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
      enddo
      do jc=x2start(2)+2,x2end(2)
        jm=jc-1
        do ic=x2start(1),x2end(1)
          rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
          tridpj(ic,jc)= rTemp*tridpj(ic,jc)
          tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
        enddo
      enddo
      do jc=x2end(2)-2,x2start(2)+1,-1
        jp=jc+1
        do ic=x2start(1),x2end(1)
          tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
          tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
          tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
        enddo
      enddo
      do ic=x2start(1),x2end(1)
        jc=x2start(2); jp=jc+1
        rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
        tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
        tridmj(ic,jc)= rTemp*tridmj(ic,jc)
        tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
        arrx2_reduce(ic,1,kc)=tridfj(ic,x2start(2))
        arrx2_reduce(ic,2,kc)=tridfj(ic,x2end(2))
      enddo
      do jc=x2start(2),x2end(2)
        do ic=x2start(1),x2end(1)
          arrx1(ic,jc,kc)=tridmj(ic,jc)
          arrx3(ic,jc,kc)=tridpj(ic,jc)
          arrx2(ic,jc,kc)=tridfj(ic,jc)
        enddo
      enddo
    ELSE
      do kc=x2start(3),x2end(3)
        do jc=x2start(2),x2end(2)
          do ic=x2start(1),x2end(1)
            tridmj(ic,jc)=am2ph(jc)
            tridcj(ic,jc)=ac2ph(jc)+WaveNumX(ic)+WaveNumZ(kc)
            tridpj(ic,jc)=ap2ph(jc)
            tridfj(ic,jc)=arrx2(ic,jc,kc)
          enddo
        enddo
        do ic=x2start(1),x2end(1)
          jc=x2start(2)
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
          jc=x2start(2)+1
          tridmj(ic,jc)=tridmj(ic,jc)/tridcj(ic,jc)
          tridpj(ic,jc)=tridpj(ic,jc)/tridcj(ic,jc)
          tridfj(ic,jc)=tridfj(ic,jc)/tridcj(ic,jc)
        enddo
        do jc=x2start(2)+2,x2end(2)
          jm=jc-1
          do ic=x2start(1),x2end(1)
            rTemp=one/(tridcj(ic,jc)-tridmj(ic,jc)*tridpj(ic,jm))
            tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridmj(ic,jc)*tridfj(ic,jm))
            tridpj(ic,jc)= rTemp*tridpj(ic,jc)
            tridmj(ic,jc)=-rTemp*tridmj(ic,jc)*tridmj(ic,jm)
          enddo
        enddo
        do jc=x2end(2)-2,x2start(2)+1,-1
          jp=jc+1
          do ic=x2start(1),x2end(1)
            tridfj(ic,jc)= tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp)
            tridmj(ic,jc)= tridmj(ic,jc)-tridpj(ic,jc)*tridmj(ic,jp)
            tridpj(ic,jc)=-tridpj(ic,jc)*tridpj(ic,jp)
          enddo
        enddo
        do ic=x2start(1),x2end(1)
          jc=x2start(2); jp=jc+1
          rTemp=one/(one-tridmj(ic,jp)*tridpj(ic,jc))
          tridfj(ic,jc)= rTemp*(tridfj(ic,jc)-tridpj(ic,jc)*tridfj(ic,jp))
          tridmj(ic,jc)= rTemp*tridmj(ic,jc)
          tridpj(ic,jc)=-rTemp*tridpj(ic,jc)*tridpj(ic,jp)
          arrx2_reduce(ic,1,kc)=tridfj(ic,x2start(2))
          arrx2_reduce(ic,2,kc)=tridfj(ic,x2end(2))
        enddo
        do jc=x2start(2),x2end(2)
          do ic=x2start(1),x2end(1)
            arrx1(ic,jc,kc)=tridmj(ic,jc)
            arrx3(ic,jc,kc)=tridpj(ic,jc)
            arrx2(ic,jc,kc)=tridfj(ic,jc)
          enddo
        enddo
      enddo
    ENDIF
    call transpose_x2_to_y2(arrx2_reduce,arry2_reduce,decomp_PPE)
    do kc=y2start(3),y2end(3)
      call InverseTridiagonal_reduce(a_reduce(:,:,kc),c_reduce(:,:,kc),arry2_reduce(:,:,kc),y2size(1),2*p_col)
    enddo
    call transpose_y2_to_x2(arry2_reduce,arrx2_reduce,decomp_PPE)
    do kc=x2start(3),x2end(3)
      do ic=x2start(1),x2end(1)
        arrx2(ic,x2start(2),kc)=arrx2_reduce(ic,1,kc)
        arrx2(ic,x2end(2),  kc)=arrx2_reduce(ic,2,kc)
      enddo
      do jc=x2start(2)+1,x2end(2)-1
        do ic=x2start(1),x2end(1)
          arrx2(ic,jc,kc)=arrx2(ic,jc,kc)-arrx1(ic,jc,kc)*arrx2_reduce(ic,1,kc)-arrx3(ic,jc,kc)*arrx2_reduce(ic,2,kc)
        enddo
      enddo
    enddo

#ifdef OverWriteFFT
    call dfftw_execute_r2r(bwd_plan_x,arrx2,arrx2)
    call transpose_x2_to_z1(arrx2,arrz)
    call dfftw_execute_r2r(bwd_plan_z,arrz,arrz)
    call transpose_z1_to_y1(arrz,prsrc)
#else
    call dfftw_execute_r2r(bwd_plan_x,arrx2,arrx1)
    call transpose_x2_to_z1(arrx1,arrz2)
    call dfftw_execute_r2r(bwd_plan_z,arrz2,arrz1)
    call transpose_z1_to_y1(arrz1,prsrc)
#endif
    do kc=y1start(3),y1end(3)
      do jc=y1start(2),y1end(2)
        do ic=y1start(1),y1end(1)
          prphiHalo(ic,jc,kc) = prsrc(ic,jc,kc)*normfft
        enddo
      enddo
    enddo
  end subroutine clcPPE_z1_reduce

  !******************************************************************
  ! InverseTridiagonal_reduce
  !******************************************************************
  subroutine InverseTridiagonal_reduce(aj,cj,fj,m,n)
    implicit none
    integer,intent(in)::m,n
    real(RK),dimension(m,n),intent(in):: aj,cj
    real(RK),dimension(m,n),intent(inout)::fj

    ! locals
    integer:: i,j
    real(RK),dimension(m):: vecm
    real(RK),dimension(m,n)::arrmn

    do i=1,m
      vecm(i)=one
    enddo
    do j=2,n
      do i=1,m
        arrmn(i,j)=cj(i,j-1)/vecm(i)
        vecm(i)=one-aj(i,j)*arrmn(i,j)
        fj(i,j)=(fj(i,j)-aj(i,j)*fj(i,j-1))/vecm(i)
      enddo
    enddo
    do j=n-1,1,-1
      do i=1,m
        fj(i,j)=fj(i,j)-arrmn(i,j+1)*fj(i,j+1)
       enddo
    enddo
  end subroutine InverseTridiagonal_reduce
end module m_Poisson


c  Part of R package KernSmooth
c  Copyright (C) 1995  M. P. Wand
c
c  Unlimited use and distribution (see LICENCE).

cccccccccc FORTRAN subroutine sstdg cccccccccc

c For computing the diagonal entries of the "binned"
c version of SS^T, where S is a smoother matrix for
c local polynomial fitting.

c Last changed: 10/02/95

      subroutine sstdg(xcnts,delta,hdisc,Lvec,indic,
     +                 midpts,M,iQ,fkap,ipp,ippp,ss,uu,Smat,
     +                 Umat,work,det,ipvt,SSTd)
      integer i,j,k,Lvec(*),M,iQ,mid,indic(*),midpts(*),
     +        ipvt(*),info,ii,ipp,ippp,indss
      double precision xcnts(*),fkap(*),hdisc(*),
     +                 delta,ss(M,ippp),uu(M,ippp),Smat(ipp,ipp),
     +                 Umat(ipp,ipp),SSTd(*),fac,work(*),det(2)

c Obtain kernel weights

      mid = Lvec(1) + 1
      do 10 i=1,(iQ-1)
         midpts(i) = mid
         fkap(mid) = 1.0d0
         do 20 j=1,Lvec(i)
            fkap(mid+j) = exp(-(delta*j/hdisc(i))**2/2)
            fkap(mid-j) = fkap(mid+j)
20       continue
         mid = mid + Lvec(i) + Lvec(i+1) + 1
10       continue
      midpts(iQ) = mid
      fkap(mid) = 1.0d0
      do 30 j=1,Lvec(iQ)
         fkap(mid+j) = exp(-(delta*j/hdisc(iQ))**2/2)
         fkap(mid-j) = fkap(mid+j)
30    continue

c Combine kernel weights and grid counts

      do 40 k = 1,M
         if (xcnts(k).ne.0) then
            do 50 i = 1,iQ
               do 60 j = max(1,k-Lvec(i)),min(M,k+Lvec(i))
                  if (indic(j).eq.i) then
                     fac = 1.0d0
                     ss(j,1) = ss(j,1) + xcnts(k)*fkap(k-j+midpts(i))
                     uu(j,1) = uu(j,1) +
     +                         xcnts(k)*fkap(k-j+midpts(i))**2
                     do 70 ii = 2,ippp
                        fac = fac*delta*(k-j)
                        ss(j,ii) = ss(j,ii)
     +                  + xcnts(k)*fkap(k-j+midpts(i))*fac
                        uu(j,ii) = uu(j,ii)
     +                  + xcnts(k)*(fkap(k-j+midpts(i))**2)*fac
70                   continue
                  endif
60             continue
50          continue
         endif
40    continue

      do 80 k = 1,M
         SSTd(k) = dble(0)
         do 90 i = 1,ipp
            do 100 j = 1,ipp
               indss = i + j - 1
               Smat(i,j) = ss(k,indss)
               Umat(i,j) = uu(k,indss)
100         continue
90       continue

         call dgefa(Smat,ipp,ipp,ipvt,info)
         call dgedi(Smat,ipp,ipp,ipvt,det,work,01)

         do 110 i = 1,ipp
            do 120 j = 1,ipp
               SSTd(k) =  SSTd(k) + Smat(1,i)*Umat(i,j)*Smat(j,1)
120         continue
110      continue

80    continue

      return
      end

cccccccccc End of sstdg cccccccccc


c
c	This program exercises this subroutine in 1D along a field line

c
	real*4 outn(4)
	real*4 r,al,alatr,amlt,akp
	integer*4 itime(2)

      itime(1)=2002185
      ihr=12
      imin=0
      isec=0
      itime(2)=(ihr*3600 + imin*60 + isec) * 1000

	open(unit=3,file='test_radial.txt')

	akp=4.0
	alatd=45.0
	alatr=alatd/180.0*3.1415927
      amlt=16.0
      rmin=1.0 + 70.0 / 6371.0
      rmax=10.0

	do r=rmin,rmax,0.02
	  alt=(r - 1.0) * 6371.0
        call gcpm_v24(itime,r,amlt,alatr,akp,outn)
        write(3,*) r,alt,outn(1)
  	  print*,r,alt,outn(1)
	enddo
      close(unit=3)

	stop
	end