CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C       --U S E R   E L E M E N T    S U B R O U T I N E S---          C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UEL_FEM8.for 8-Noded isoparametric 2d element.                      C
C                                                                      C
C  8-NODED ISOPARAMETRIC ELEMENT                                       C
C  UNIVERSIDAD EAFIT                                                   C
C  2012                                                                C
C  MECANICA APLICADA                                                   C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  USER ELEMENT SUBROUTINE                                             C
C  UEL_FEM8                                                            C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE UEL_FEM8(AMATRX,AMASS,NDOFEL,PROPS,NPROPS,COORDS,MCRD,
     1                    NNODE,JELEM)

C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (NTENS=4,NDI=3,NGPTS=9)
C
C     Parameter arrays from UEL.f
C
      DIMENSION AMATRX(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL),
     1          PROPS(NPROPS),COORDS(MCRD,NNODE),FRST2(NDOFEL,NDOFEL)
C
C     User defined arrays
C
      DIMENSION B(NTENS,NDOFEL),BT(NDOFEL,NTENS),FRST1(NDOFEL,NDOFEL),
     1          XX(MCRD,NNODE),XW(NGPTS),XP(2,NGPTS),AUX1(NTENS,NDOFEL)
C
C     Arrays to be used in UMAT.f
C
      DIMENSION DDSDDE(NTENS, NTENS)
C
C     Clears RHS vector and Stiffness matrix
C
      CALL CLEAR(AMATRX,NDOFEL,NDOFEL)
      CALL CLEAR(AMASS,NDOFEL, NDOFEL)
C
      RO=PROPS(3)
C
C     Generates Gauss points and weights.
C
      CALL GPOINTS3X3(XP,XW)
C
C     Loops around all Gauss points
C
      DO NN=1,NGPTS
C
        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)
C
C       Assembles B matrix
C
        CALL STDM8(JELEM,NNODE,NDOFEL,NTENS,COORDS,B,DDET,RII,SII,XBAR)
        CALL RMASS8(FRST2,NDOFEL,RII,SII)
C
C       Assembles material matrix and updates state variables
C
        CALL UMATELA(DDSDDE,PROPS, NPROPS,NTENS,NDI)
C
        CALL MMULT(DDSDDE,NTENS,NTENS,B,NTENS,NDOFEL,AUX1)
        CALL CLEAR(BT,NDOFEL,NTENS)
        CALL MTRAN(B,NTENS,NDOFEL,BT)
C
C       Assembles stiffness matrix and RHS vector contribution
C
        CALL MMULT(BT,NDOFEL,NTENS,AUX1,NTENS,NDOFEL,FRST1)
C
C       Considers Gauss weight and Jacobian determinant representing
C       volume differential.
C
        CALL SMULT(FRST1,NDOFEL,NDOFEL,ALF*DDET*XBAR)
        CALL SMULT(FRST2,NDOFEL,NDOFEL,ALF*DDET*XBAR*RO)
C
C       Updates Stiffness and mass matrix.
C
        CALL UPDMAT(AMATRX,NDOFEL,NDOFEL,FRST1)
        CALL UPDMAT(AMASS, NDOFEL,NDOFEL,FRST2)
C
C       Clears material Jacobian and temporary stiffness matrix
C       array for new Gauss point
C
        CALL CLEAR(DDSDDE,NTENS,NTENS)
        CALL CLEAR(FRST1,NDOFEL,NDOFEL)
        CALL CLEAR(FRST2,NDOFEL,NDOFEL)
C
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  USER ELEMENT SUBROUTINE                                             C
C  UEL_FEM9                                                            C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE UEL_FEM9(AMATRX,AMASS,NDOFEL,PROPS,NPROPS,COORDS,MCRD,
     1                    NNODE,JELEM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (NTENS=4,NDI=3,NGPTS=9)
C
C     Parameter arrays from UEL.f
C
      DIMENSION AMATRX(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL),
     1          PROPS(NPROPS),COORDS(MCRD,NNODE),FRST2(NDOFEL,NDOFEL)
C
C     User defined arrays
C
      DIMENSION B(NTENS,NDOFEL),BT(NDOFEL,NTENS),FRST1(NDOFEL,NDOFEL),
     1          XX(MCRD,NNODE),XW(NGPTS),XP(2,NGPTS),AUX1(NTENS,NDOFEL)
C
C     Arrays to be used in UMAT.f
C
      DIMENSION DDSDDE(NTENS, NTENS)
C
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  UEL_COS8.for 8-Noded isoparametric 2d element.                      C
C                                                                      C
C  8-NODED ISOPARAMETRIC ELEMENT                                       C
C  UNIVERSIDAD EAFIT                                                   C
C  2012                                                                C
C  MECANICA APLICADA                                                   C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C  USER ELEMENT SUBROUTINE                                             C
C  UEL_FEM8                                                            C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE UEL_COS8(AMATRX,AMASS,NDOFEL,PROPS,NPROPS,COORDS,MCRD,
     1                    NNODE,JELEM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (NTENS=7,NDI=3,NGPTS=9)
C
C     Parameter arrays from UEL.f
C
      DIMENSION AMATRX(NDOFEL,NDOFEL),AMASS(NDOFEL,NDOFEL),
     1          PROPS(NPROPS),COORDS(MCRD,NNODE),FRST2(NDOFEL,NDOFEL)
C
C     User defined arrays
C
      DIMENSION B(NTENS,NDOFEL),BT(NDOFEL,NTENS),FRST1(NDOFEL,NDOFEL),
     1          XX(MCRD,NNODE),XW(NGPTS),XP(2,NGPTS),AUX1(NTENS,NDOFEL)
C
C     Arrays to be used in UMAT.f
C
      DIMENSION DDSDDE(NTENS, NTENS)
C
C     Clears RHS vector and Stiffness matrix
C
      CALL CLEAR(AMATRX,NDOFEL,NDOFEL)
      CALL CLEAR(AMASS,NDOFEL, NDOFEL)
C
      RO=PROPS(3)
      RI=PROPS(4)
C
C     Generates Gauss points and weights.
C
      CALL GPOINTS3X3(XP,XW)
C
C     Loops around all Gauss points
C
      DO NN=1,NGPTS
C
        RII=XP(1,NN)
        SII=XP(2,NN)
        ALF=XW(NN)
C
C       Assembles B matrix
C
        CALL STDM8C(JELEM,NNODE,NDOFEL,NTENS,COORDS,B,DDET,RII,SII,XBAR)
C
C       Assembles material matrix and updates state variables
C
        CALL UMATCOS(DDSDDE,PROPS, NPROPS,NTENS,NDI)
C
        CALL MMULT(DDSDDE,NTENS,NTENS,B,NTENS,NDOFEL,AUX1)
        CALL CLEAR(BT,NDOFEL,NTENS)
        CALL MTRAN(B,NTENS,NDOFEL,BT)
C
C       Assembles stiffness matrix.
C
        CALL MMULT(BT,NDOFEL,NTENS,AUX1,NTENS,NDOFEL,FRST1)
C
C       Temporary mass matrix.
C
        CALL RMASS8C(FRST2,RO,RI,NDOFEL,RII,SII)
C
C       Considers Gauss weight and Jacobian determinant representing
C       volume differential.
C
        CALL SMULT(FRST1,NDOFEL,NDOFEL,ALF*DDET*XBAR)
        CALL SMULT(FRST2,NDOFEL,NDOFEL,ALF*DDET*XBAR)
C
C       Updates Stiffness and mass matrix.
C
        CALL UPDMAT(AMATRX,NDOFEL,NDOFEL,FRST1)
        CALL UPDMAT(AMASS ,NDOFEL,NDOFEL,FRST2)
C
C       Clears material Jacobian and temporary stiffness matrix
C       array for new Gauss point
C
        CALL CLEAR(DDSDDE,NTENS,NTENS)
        CALL CLEAR(FRST1,NDOFEL,NDOFEL)
        CALL CLEAR(FRST2,NDOFEL,NDOFEL)
C
      END DO
C
      RETURN
C
      END
C


      module MOD_PRIH
      contains
      SUBROUTINE PRIH (LPRIH,ND,RADIUS,HTOT,TEFF,
     $                  T,TAUROSS,JOBNUM,MODHEAD)

      IMPLICIT REAL*8(A-H,O-Z)

      DIMENSION RADIUS(ND),HTOT(ND),T(ND),TAUROSS(ND)
      CHARACTER MODHEAD*104
      DATA PI,PISIG/3.141592654d0,5.5411d+4/

      IF (TEFF.LE.0..AND.HTOT(1).GT.0.)
     &             TEFF=(4.*HTOT(1)*RADIUS(1)*RADIUS(1)*PISIG)**0.25
      PRINT 10,MODHEAD,JOBNUM, TEFF
 10   FORMAT (10H1$$$$$$$$$,/,1X,  A,  20X,'JOB NO.',I5,
     $     ///,20X,'ASTROPHYSICAL FLUX AS A FUNCTION OF DEPTH',/,
     $         20X,'=========================================',
     $      //,20X,'TEFF = ',F20.0
     $   //,5X,'DEPTH INDEX  TAU-ROSSELAND  EL. TEMPERATURE  FLUX ',
     $         '(ERG/CM2/S)    T (KELVIN)            T/TEFF'/)

      DO 1 L=1,ND
      IF(((L-1)/LPRIH)*LPRIH.NE.(L-1) .AND. L.NE.ND) GOTO 1
      TL=(4.*HTOT(L)*RADIUS(L)*RADIUS(L)*PISIG)**0.25
      PRINT 13,L,TAUROSS(L),T(L),4.*HTOT(L),TL,TL/TEFF
   13 FORMAT (5X,I10,1PE14.3,0PF14.0,1PE20.5,0PF15.0,F20.5)
    1 CONTINUE
      RETURN
      END subroutine
      end module


      recursive subroutine bispeu(tx,nx,ty,ny,c,kx,ky,x,y,z,m,wrk,
     *   lwrk, ier)
      implicit none
c  subroutine bispeu evaluates on a set of points (x(i),y(i)),i=1,...,m
c  a bivariate spline s(x,y) of degrees kx and ky, given in the
c  b-spline representation.
c
c  calling sequence:
c     call bispeu(tx,nx,ty,ny,c,kx,ky,x,y,z,m,wrk,lwrk,
c    * iwrk,kwrk,ier)
c
c  input parameters:
c   tx    : real array, length nx, which contains the position of the
c           knots in the x-direction.
c   nx    : integer, giving the total number of knots in the x-direction
c   ty    : real array, length ny, which contains the position of the
c           knots in the y-direction.
c   ny    : integer, giving the total number of knots in the y-direction
c   c     : real array, length (nx-kx-1)*(ny-ky-1), which contains the
c           b-spline coefficients.
c   kx,ky : integer values, giving the degrees of the spline.
c   x     : real array of dimension (mx).
c   y     : real array of dimension (my).
c   m     : on entry m must specify the number points. m >= 1.
c   wrk   : real array of dimension lwrk. used as workspace.
c   lwrk  : integer, specifying the dimension of wrk.
c           lwrk >= kx+ky+2
c
c  output parameters:
c   z     : real array of dimension m.
c           on successful exit z(i) contains the value of s(x,y)
c           at the point (x(i),y(i)), i=1,...,m.
c   ier   : integer error flag
c    ier=0 : normal return
c    ier=10: invalid input data (see restrictions)
c
c  restrictions:
c   m >=1, lwrk>=mx*(kx+1)+my*(ky+1), kwrk>=mx+my
c   tx(kx+1) <= x(i-1) <= x(i) <= tx(nx-kx), i=2,...,mx
c   ty(ky+1) <= y(j-1) <= y(j) <= ty(ny-ky), j=2,...,my
c
c  other subroutines required:
c    fpbisp,fpbspl
c
c  ..scalar arguments..
      integer nx,ny,kx,ky,m,lwrk,ier
c  ..array arguments..
      real*8 tx(nx),ty(ny),c((nx-kx-1)*(ny-ky-1)),x(m),y(m),z(m),
     *     wrk(lwrk)
c  ..local scalars..
      integer iwrk(2)
      integer i, lwest
c  ..
c  before starting computations a data check is made. if the input data
c  are invalid control is immediately repassed to the calling program.
      ier = 10
      lwest = kx+ky+2
      if (lwrk.lt.lwest) go to 100
      if (m.lt.1) go to 100
      ier = 0
      do 10 i=1,m
         call fpbisp(tx,nx,ty,ny,c,kx,ky,x(i),1,y(i),1,z(i),wrk(1),
     *        wrk(kx+2),iwrk(1),iwrk(2))
 10   continue
 100  return
      end


! MinimalDX version 0.1.4 (https://www.github.com/dmey/minimal-dx).
! Copyright 2018-2020 D. Meyer and R. Raustad. Licensed under MIT.

program  test_cooling_point
  !+ Program to compare MinimalDX against original EnergyPlus implementation.

  ! Add InitializePsychRoutines here to fix the allocatable array is already allocated error
  use Psychrometrics, only: InitializePsychRoutines, PsyRhoAirFnPbTdbW, PsyWFnTdbRhPb
  ! EnergyPlus DX Coil model (original implementation)
  use EPlusWrapperCooling, only : SimCalcDoe2DXCoil
  ! DX Coil model (simplified) using EnergyPlus psychrometric routines
  use MinimalDXCoolingDriver, only: SimMinimalDXCooling

  implicit none

  ! The number one ('1') next to the variable description denotes that the variable is dimensionless - e.g.   COP [1]
  real :: OutdoorTDryBulb
      !+ Outdoor dry bulb air temperature `[°C]`
  real :: OutdoorHumRatio
      !+ Outdoor air humidity ratio `[kgH₂O kgAIR⁻¹]`
  real :: OutdoorPressure
      !+ Outdoor barometric pressure `[Pa]`
  real :: InletTDryBulb
      !+ Indoor (inlet) dry bulb air temperature `[°C]`
  real :: InletHumRatio
      !+ Indoor (inlet) air humidity ratio `[kgH₂O kgAIR⁻¹]`
  real :: RatedCOP
      !+ Rated Coefficient Of Performance (COP) `[1]`
  real :: RatedTotCap
      !+ Rated (total) system capacity `[W]`
  real :: SensibleCoolingLoad
  !+ Building sensible load to be met `[W]`
  real :: RatedAirMassFlowRate
      !+ Rated air mass flow rate `[kg s⁻¹]`
  real :: COP
      !+ Actual (calculated) Coefficient Of Performance (COP) `[1]`
  real :: TotalCoolingCapacity
      !+ Actual (calculated) total system capacity `[W]`
  real :: OutletTemperature
      !+ Actual (calculated) outlet air dry bulb temperature existing the cooling coil `[°C]`
  real :: OutletHumRatio
      !+ Actual (calculated) outlet air humidity ratio existing the cooling coil `[kgH₂O kgAIR⁻¹]`
  real :: ElecCoolingPower
      !+ Calculated electrical power consumed by the DX unit `[W]`
  real :: LatCoolingEnergyRate
      ! Total latent cooling energy rate extracted by the coil from the indoor environment `[J kg⁻¹]`
  real :: TotalCoolingEnergyRate
      !+ Total cooling power of the DX unit (energy rate extracted by DX unit from the indoor environment) `[W]`
  real :: TotalSensibleHeatOut
      !+ Total power rejected by the evaporator into the outdoor environment
      !+ i.e. TotalCoolingEnergyRate + ElecCoolingPower `[W]`

  ! call InitializePsychRoutines here to fix the allocatable array is already allocated error
  call InitializePsychRoutines

  OutdoorTDryBulb = 20.
  OutdoorPressure = 90000.
  OutdoorHumRatio = PsyWFnTdbRhPb(OutdoorTDryBulb, 0.5, OutdoorPressure)
  InletTDryBulb = 23.
  InletHumRatio = PsyWFnTdbRhPb(InletTDryBulb, 0.5, OutdoorPressure)
  RatedCOP = 3.
  RatedTotCap = 4000.
  SensibleCoolingLoad = 100.
  RatedAirMassFlowRate = 0.00005 * RatedTotCap * PsyRhoAirFnPbTdbW(OutdoorPressure, InletTDryBulb, InletHumRatio)

  call SimCalcDoe2DXCoil(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                 &
                          InletTDryBulb, InletHumRatio,                                     &
                          RatedCOP, RatedTotCap, SensibleCoolingLoad, RatedAirMassFlowRate, &
                          COP, TotalCoolingCapacity,                                        &
                          OutletTemperature, OutletHumRatio,                                &
                          ElecCoolingPower, LatCoolingEnergyRate,    &
                          TotalCoolingEnergyRate, TotalSensibleHeatOut)

  call SimMinimalDXCooling(OutdoorTDryBulb, OutdoorHumRatio, OutdoorPressure,                 &
                            InletTDryBulb, InletHumRatio,                                     &
                            RatedCOP, RatedTotCap, SensibleCoolingLoad, RatedAirMassFlowRate, &
                            COP, TotalCoolingCapacity,                                        &
                            OutletTemperature, OutletHumRatio,                                &
                            ElecCoolingPower, LatCoolingEnergyRate,    &
                            TotalCoolingEnergyRate, TotalSensibleHeatOut)

end program test_cooling_point


      SUBROUTINE CONM1D
C
C THIS SUBROUTINE COMPUTES THE CONCENTRATED MASS ELEMENTS
C MASS MATRIX FOR THE M1 TYPE ELEMENT
C  DOUBLE PRECISION VERSION
C
C
C ECPT NO.  NAME              TYPE   DESCRIPTION
C 1         IELID             I      ELEMENT ID
C 2         IGP               I      GRID POINT NUMBER
C 3         ICIDT2            I      COORDINATE ID FOR T2
C 4         M(1,1)            R
C 5, 6      M(2,1) TO M(2,2)  R
C 7, 8, 9   M(3,1) TO M(3,3)  R      MASS MATRIX VALUES
C 10 TO 13  M(4,1) TO M(4,4)  R
C 14 TO 18  M(5,1) TO M(5,5)  R
C 19 TO 24  M(6,1) TO M(6,6)  R
C 25        ICIDT1            I      COORDINATE ID FOR T1
C 26        X                 R
C 27        Y                 R      TRANSFORMATION MATRIX
C 28        Z                 R
C
      INTEGER DICT(7),ELID,ESTID,IECPT(25)
      DOUBLE PRECISION MM(36),TT(36),T(36),M(21)
      LOGICAL NOGO
C
C
      COMMON /SYSTEM/ SS,IOUTPT,KSYSTM(56)
C
      COMMON /EMGPRM/ DUM(15),ISMB(3),IPREC,NOGO
      COMMON /EMGEST/ ECPT(100)
      COMMON /EMGDIC/ DMM(2),NLOCS,ELID,ESTID
C
      EQUIVALENCE (ECPT(1),IECPT(1),IELID)
      EQUIVALENCE (DICT(5),DICT5)
C
C     INITIALIZE
C
      IF (ISMB(2) .EQ. 0) RETURN
      DICT(1) = ESTID
      DICT(2) = 1
      DICT(3) = 6
      DICT(4) = 63
      DICT5 = 0
      IP = IPREC
      XOF = ECPT(5)
      YOF = ECPT(6)
      ZOF = ECPT(7)
      DO 50 I=1,21
   50 M(I) = ECPT(I+3)
C
C COMPUTE NON-TRANSFORMED MASS MATRIX. INITIALIZE
C TO ZERO THEN FILL IN NON-ZERO TERMS
C
      DO  100 I = 1,36
  100 MM(I)=  0.D0
C
      K = 0
      DO 110 I = 1,6
      DO 110 J = 1,I
      K = K + 1
      JI = (J-1)*6 + I
      IJ = (I-1)*6 + J
      MM(IJ) = M(K)
  110 MM(JI) = M(K)
C
      ICIDT1 = IECPT(25)
      ICIDT2 = IECPT(3)
C
C PERFORM TRANSFORMATIONS.  IF CSIDS 1 AND 2 ARE EQUAL,
C T1 = T2 SO MASS MARRIX IS COMPLETE
C
      IF (ICIDT2 .EQ. ICIDT1) GO TO 240
C                             T
C NOT EQUAL. SO COMPUTE T = (T ) (T )
C                             1    2
C GET T1 AND T2 IF NEEDED
      IT = 18
      IF (ICIDT1 .EQ. 0) GO TO 130
C
      CALL TRANSD(ECPT(25),T(1))
      GO TO 140
C
C ONLY T2 NEEDED SO T = T2
C
  130 IT = 9
  140 IF(ICIDT2 .EQ. 0) GO TO 150
      CALL TRANSD(ECPT(25),T(10))
C
      IF(ICIDT1 .EQ. 0) GO TO 210
      CALL GMMATD (T(1),3,3,1,  T(10),3,3,0, T(19))
      GO TO 210
C
C HERE T2 IS IDENTITY AND T1 IS AT T(1) SO
C T = T1 (TRANSPOSE).  SO INSERT INTO T
  150 DO 170 I = 1,3
      DO 170 J = 1,3
      IJ = 3*(I - 1) + J
      JI = I + 3*(J-1) + 18
  170 T(JI)=T(IJ)
C
C T = (T ) (T ) IS COMPLETE. INSERT IT IN THE 6X6 TRANSFORMATION MATRIX.
C       1    2
C
  210 DO 220 I = 1,36
  220 TT(I)=0.D0
C
      DO 230 I = 1,3
      IJ = I + IT
      TT(I) = T(IJ)
      TT(I + 6) = T(IJ + 3)
      TT(I + 12) = T(IJ + 6)
      TT(I + 21) = T(IJ)
      TT(I + 27) = T(IJ + 3)
  230 TT(I + 33) = T(IJ + 6)
C           T
C FORM T*M*T  AND STORE IN MM
C
      CALL GMMATD (TT(1),6,6,0,  MM(1),6,6,0, T(1))
      CALL GMMATD(T(1),6,6,0, TT(1),6,6,1, MM(1))
C
  240 CALL EMGOUT (MM,MM,36,1,DICT,2,IP)
      RETURN
      END


PROGRAM AMAssim
USE sub_mod
implicit none
real(4) :: start,finish,t2,t1
logical :: there
! All parameters varied in an Identical Twin Test assimilation.
integer :: i,j,k,row,col
integer :: Readfile   = NO  ! Read parameter set from "enssig" and "enspar", and start from Subpcurr
real, allocatable  :: enspar1(:,:)    ! scratch matrix to store previous runs of parameters
integer            :: NR_enspar=100
integer            :: N_cvm
namelist /MCMCrun/ nruns, EnsLen, NDays, Readfile, NR_enspar, MPIRUN

 !  open the namelist file and read station name.
open(namlst,file='Model.nml',status='old',action='read')
read(namlst,nml=MCMCrun)
close(namlst)

if (MPIRUN .eq. 1) then
   ! ***** Initialize MPI *****
   call MPI_INIT(ierr)

   ! Returns the size of the group associated with a communicator.
   call MPI_COMM_SIZE(MPI_COMM_WORLD, numtasks, ierr)

   ! Determines the rank of the calling process in the communicator
   call MPI_COMM_RANK(MPI_COMM_WORLD, taskid, ierr)

   ! Notes: each mpi process proposes a new point based on the current position
   ! and the updated Pcvm. In each subprocess, the new Loglikelihood is calculated
   ! and compared with previous one. Acceptance is calculated and the new position
   ! is estimated. After that, the new position is sent to the root process, which
   ! combines all child processes, writes to the enspar and enssig file, calculates
   ! the new Pcvm and sends to all child processes
else
   taskid  = 0
   numtasks= 1
endif

call cpu_time(start)

!Initialize the Arrays of model parameters with the biological model chosen
call SetUpArrays

! Initialize the 1D model:
call Model_setup

! Initialize the random number generator with a seed
! call sgrnd(17001)
call random_seed()

! An initial guess that is some factor times the inital parameter estimates
subpguess = Npv

!  Set current to guess
subpcurr  = subpguess
subppro   = subpguess
subppro2  = subpguess
BestLogLike = -1d12
startrun  = 0

! Estimate the priors based on initial parameter values
call EstimatePriors(PriorCvm, InvPriorCvm, error)

! Set the labels for the standard deviations for each type of observation
call SetSigmaLabels

! Take the intial Covariance matrix to be the Prior Covariance Matrix
! (these are in compacted form)
! PriorCvm is the prior covariance matrix generated by the subroutine EstimatePriors
! Cvm is the Covariance Matrix for parameters
Cvm = PriorCvm
Rwtold = 1d0  ! Set the initial weight equal to One

! Set the Proposal covariance matrix, by scaling the Parameter Covariance matrix
Pcvm = Cvm*Spcvm/Np2Vary  ! Np2Vary = d in p. 11 of Laine 2008

! Add a small term to the diagonal entries, so that the matrix will not be singular.
do k = 1, Np2Vary
   Pcvm(k*(k+1)/2) = Pcvm(k*(k+1)/2) + CvEpsilon*Spcvm/Np2Vary
enddo

! Calculate the Cholesky factor for Pcvm, which is called Rchol here.
! The Pcvm and Rchol will not vary until the burn-in finishes.
call cholesky(Pcvm,Np2Vary,Np2Vary*(Np2Vary+1)/2,Rchol,nullty,error)

if (taskid .eq. 0) then
   write(6, *) 'Initial Covariance matrix = '
   do row = 1, Np2Vary
      write(6,3000) (Cvm(row*(row-1)/2+col), col = 1, row )
   end do

   write(6, *) 'Initial Proposal Covariance matrix = '

   DO row = 1, Np2Vary
      write(6,3000) (Pcvm(row*(row-1)/2+col), col = 1, row )
   End do

   write(6, *) 'Cholesky factor for Proposal Covariance matrix = '
   DO row = 1, Np2Vary
      write(6,3000) ( Rchol(row*(row-1)/2+col), col = 1, row )
   Enddo
endif

! Reset subpmean to Zero for the new run
subpmean     = 0d0
subpcurrmean = 0d0
sigmamean    = 0d0

IF(nruns .gt. 1) THEN
  ! Read the ensemble files
  IF (Readfile) then
     inquire(FILE=epfn,exist=there)
     if (.not. there) then
        write(6,*) 'Cannot find the file ',epfn,'! Quit!'
        stop
     else
     ! Read the enspar file
       i = NPar+1
       allocate(enspar1(NR_enspar,i))
       enspar1(:,:) = 0d0
       call Readcsv(epfn,NR_enspar,i, enspar1)

     ! Calculate CVM (Take the final N_cvm chains, otherwise Pcvm too large)
       N_cvm = NR_enspar-BurnInt
       if (NR_enspar > N_cvm) then
          k = NR_enspar-N_cvm+1
          Rwtold=real(N_cvm)
       else
          k = 1
          Rwtold=real(NR_enspar)
       endif

       do i=k,NR_enspar
          do j=1,NPar
             Apvcurr(j)=enspar1(i,j+1)
          enddo

          subpcurr = Npv_(Apvcurr)

          call UpdateCVM(Cvm,subpcurrmean,dble(i-k+1),subpcurr,subpcurrmean,Cvm)
       enddo

       Pcvm = Cvm*Spcvm/NPar
     ! add a small term to the diagonal entries,
     ! so that the matrix will not be singular.
       do k = 1, NPar
         Pcvm(k*(k+1)/2)=Pcvm(k*(k+1)/2) + CvEpsilon*Spcvm/NPar
       enddo

       if (taskid .eq. 0) then
          write(6, *) 'Updated Covariance matrix = '
          do row = 1, NPar
             write(6,3000) (Cvm(row*(row-1)/2+col), col = 1, row )
          end do
          write(6, *) 'Updated Proposal Covariance matrix = '
          DO row = 1, Np2Vary
             write(6,3000) (Pcvm(row*(row-1)/2+col), col = 1, row )
          End do
       endif

       startrun=NR_enspar

     ! Obtain current position:
       do i = 1, NPar
          Apvcurr(i) = enspar1(NR_enspar,i+2)
       enddo

       subpcurr    = Npv_(Apvcurr)
       subppro     = subpcurr
       subpbest    = subpcurr
       CurrLogLike = enspar1(NR_enspar,2)
       deallocate(enspar1)

       if (taskid .eq. 0) then
        ! Write out current parameters:
        do i = 1, Np2Vary
           write(6,101) ParamLabel(i), subpcurr(i), Apvcurr(i)
        enddo
       endif

     ! Read the enssig file (containing two stations)
       i = 1+NDTYPE*Nstn*2
       allocate(enspar1(NR_enspar,i))
       enspar1(:,:) = 0d0
       call Readcsv(esfn,NR_enspar,i, enspar1)

       do i=1,NDTYPE * Nstn
          sigma(i)=enspar1(NR_enspar,1            +i)
           SSqE(i)=enspar1(NR_enspar,1+NDTYPE*Nstn+i)
       enddo

       sigmabest= sigma
       CurrSSqE = SSqE
       deallocate(enspar1)
     endif
  ELSE
     if (taskid .eq. 0) then
     ! Create new ensemble files
     ! Parameter Ensemble file (only one file needed)
       open(epfint,file=epfn,status='replace',action='write')
       write(epfint,1800) (ParamLabel(i), i = 1, Np2Vary)
       close(epfint)

     ! Sigma (standard error) Ensemble file (One file needed)
       open(esfint,file=esfn,status='replace',action='write')
       write(esfint,1900)  (SigmaLabel(i), i = 1,NDTYPE*Nstn), &
                           ( SSqELabel(i), i = 1,NDTYPE*Nstn)
       close(esfint)

     ! Output Ensemble files to store the ensemble of simulated values
     ! Be consistent with subroutine modelensout
       open(eofint, file=eofn,status='replace',action='write')
       write(eofint,'(5(A8))')  'RunNo   ',   &
                                'DOY     ',   &
                                'Depth   ',   &
                                'Name    ',   &
                                'Value   '
       close(eofint)
     endif
  ENDIF
ENDIF

! First, one simulation, to initialize all routines
! This avoids the problem that
! Parameter Values will be read from the data file on the initial run;
! if they are different than the values in this program for Assimilated Params,
! this could return a much different cost.
! If the cost with the Values in the Parm file is much lower,
! the assimilation may almost never accept any new parameter sets)

MeanLogLike = 0d0

if (taskid .eq. 0) then
  write(6, *) ' Testing running time for each model run:'
  ! Write output
  ! run with the Best Parameters, writing to the best output file
  call cpu_time(t1)
  open(bofint, file=bofn,action='write',status='replace')
endif

savefile = .FALSE.
call model(bofint, subppro, SSqE )
CurrLogLike = CalcLogLike(SSqE,sigma,subppro)

if (taskid .eq. 0) then
   write(6, 1001) CurrLogLike
   close(bofint)
   call cpu_time(t2)
   print '("One model run takes ",f8.3," seconds.")', t2-t1
endif

CurrSSqE = SSqE
!------------------------------------------
!	HERE STARTS THE MAIN LOOP
!------------------------------------------
! The counter for the jth run
jrun        = startrun + 1

! Total number of runs
nruns       = nruns + startrun
BestLogLike = CurrLogLike
call MCMC_adapt

if (taskid .eq. 0) then
   write(6, *) ' Finished the main loop for assimilation! '
   write(6, *)
   write(6, *) ' Final Proposal Covariance matrix = '
   DO row = 1, Np2Vary
      write(6,3000) ( Pcvm( row*(row-1)/2 + col ), col = 1, row )
   ENDDO

   write(6, *) ' Writing the last entry in',          &
               ' the ensembles of simulated values.'
   !write output of Ensemble file for simulated values
   call modelensout(eofint, jrun, subpcurr, dumE)

   write(6,*) ' Write out the simulated results with best parameters:'
   call modelensout(eofint, jrun, subpbest, dumE)

   close(eofint)

101  format(A8, 2(1x, 1pe12.2))
1001 format(/,'LogL = ',1pe13.3,/)

1800 format('LogL     ', 100(a15) )
1900 format('LogL     ', 100(a12,2x) )
3000 format(5x,<NPar>(1pe8.1,1x))
   call cpu_time(finish)
   print '("Time = ",f8.3," hours.")', (finish-start)/3600.0
endif

!End mpi
if (MPIRUN .eq. 1) call MPI_finalize(ierr)

END PROGRAM AMAssim


C
C $Id: surf1.f,v 1.5 2008-07-27 03:10:12 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding double precision routine.
C
      subroutine surf1 (m,n,x,y,z,iz,zx1,zxm,zy1,zyn,zxy11,
     *                  zxym1,zxy1n,zxymn,islpsw,zp,temp,
     *                  sigma,ierr)
c
      integer m,n,iz,islpsw,ierr
      real x(m),y(n),z(iz,n),zx1(n),zxm(n),zy1(m),zyn(m),
     *     zxy11,zxym1,zxy1n,zxymn,zp(m,n,3),temp(1),sigma
c
c                                 coded by alan kaylor cline
c                           from fitpack -- january 26, 1987
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute an interpolatory surface passing through a rect-
c angular grid of functional values. the surface determined
c can be represented as the tensor product of splines under
c tension. the x- and y-partial derivatives around the
c boundary and the x-y-partial derivatives at the four
c corners may be specified or omitted. for actual mapping
c of points onto the surface it is necessary to call the
c function surf2.
c
c on input--
c
c   m is the number of grid lines in the x-direction, i. e.
c   lines parallel to the y-axis (m .ge. 2).
c
c   n is the number of grid lines in the y-direction, i. e.
c   lines parallel to the x-axis (n .ge. 2).
c
c   x is an array of the m x-coordinates of the grid lines
c   in the x-direction. these should be strictly increasing.
c
c   y is an array of the n y-coordinates of the grid lines
c   in the y-direction. these should be strictly increasing.
c
c   z is an array of the m * n functional values at the grid
c   points, i. e. z(i,j) contains the functional value at
c   (x(i),y(j)) for i = 1,...,m and j = 1,...,n.
c
c   iz is the row dimension of the matrix z used in the
c   calling program (iz .ge. m).
c
c   zx1 and zxm are arrays of the m x-partial derivatives
c   of the function along the x(1) and x(m) grid lines,
c   respectively. thus zx1(j) and zxm(j) contain the x-part-
c   ial derivatives at the points (x(1),y(j)) and
c   (x(m),y(j)), respectively, for j = 1,...,n. either of
c   these parameters will be ignored (and approximations
c   supplied internally) if islpsw so indicates.
c
c   zy1 and zyn are arrays of the n y-partial derivatives
c   of the function along the y(1) and y(n) grid lines,
c   respectively. thus zy1(i) and zyn(i) contain the y-part-
c   ial derivatives at the points (x(i),y(1)) and
c   (x(i),y(n)), respectively, for i = 1,...,m. either of
c   these parameters will be ignored (and estimations
c   supplied internally) if islpsw so indicates.
c
c   zxy11, zxym1, zxy1n, and zxymn are the x-y-partial
c   derivatives of the function at the four corners,
c   (x(1),y(1)), (x(m),y(1)), (x(1),y(n)), and (x(m),y(n)),
c   respectively. any of the parameters will be ignored (and
c   estimations supplied internally) if islpsw so indicates.
c
c   islpsw contains a switch indicating which boundary
c   derivative information is user-supplied and which
c   should be estimated by this subroutine. to determine
c   islpsw, let
c        i1 = 0 if zx1 is user-supplied (and = 1 otherwise),
c        i2 = 0 if zxm is user-supplied (and = 1 otherwise),
c        i3 = 0 if zy1 is user-supplied (and = 1 otherwise),
c        i4 = 0 if zyn is user-supplied (and = 1 otherwise),
c        i5 = 0 if zxy11 is user-supplied
c                                       (and = 1 otherwise),
c        i6 = 0 if zxym1 is user-supplied
c                                       (and = 1 otherwise),
c        i7 = 0 if zxy1n is user-supplied
c                                       (and = 1 otherwise),
c        i8 = 0 if zxymn is user-supplied
c                                       (and = 1 otherwise),
c   then islpsw = i1 + 2*i2 + 4*i3 + 8*i4 + 16*i5 + 32*i6
c                   + 64*i7 + 128*i8
c   thus islpsw = 0 indicates all derivative information is
c   user-supplied and islpsw = 255 indicates no derivative
c   information is user-supplied. any value between these
c   limits is valid.
c
c   zp is an array of at least 3*m*n locations.
c
c   temp is an array of at least n+n+m locations which is
c   used for scratch storage.
c
c and
c
c   sigma contains the tension factor. this value indicates
c   the curviness desired. if abs(sigma) is nearly zero
c   (e. g. .001) the resulting surface is approximately the
c   tensor product of cubic splines. if abs(sigma) is large
c   (e. g. 50.) the resulting surface is approximately
c   bi-linear. if sigma equals zero tensor products of
c   cubic splines result. a standard value for sigma is
c   approximately 1. in absolute value.
c
c on output--
c
c   zp contains the values of the xx-, yy-, and xxyy-partial
c   derivatives of the surface at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2 or m is less than 2,
c        = 2 if the x-values or y-values are not strictly
c            increasing.
c
c and
c
c   m, n, x, y, z, iz, zx1, zxm, zy1, zyn, zxy11, zxym1,
c   zxy1n, zxymn, islpsw, and sigma are unaltered.
c
c this subroutine references package modules ceez, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
      mm1 = m-1
      mp1 = m+1
      nm1 = n-1
      np1 = n+1
      npm = n+m
      ierr = 0
      if (n .le. 1 .or. m .le. 1) go to 46
      if (y(n) .le. y(1)) go to 47
c
c denormalize tension factor in y-direction
c
      sigmay = abs(sigma)*float(n-1)/(y(n)-y(1))
c
c obtain y-partial derivatives along y = y(1)
c
      if ((islpsw/8)*2 .ne. (islpsw/4)) go to 2
      do 1 i = 1,m
    1   zp(i,1,1) = zy1(i)
      go to 5
    2 dely1 = y(2)-y(1)
      dely2 = dely1+dely1
      if (n .gt. 2) dely2 = y(3)-y(1)
      if (dely1 .le. 0. .or. dely2 .le. dely1) go to 47
      call ceez (dely1,dely2,sigmay,c1,c2,c3,n)
      do 3 i = 1,m
    3   zp(i,1,1) = c1*z(i,1)+c2*z(i,2)
      if (n .eq. 2) go to 5
      do 4 i = 1,m
    4   zp(i,1,1) = zp(i,1,1)+c3*z(i,3)
c
c obtain y-partial derivatives along y = y(n)
c
    5 if ((islpsw/16)*2 .ne. (islpsw/8)) go to 7
      do 6 i = 1,m
        npi = n+i
    6   temp(npi) = zyn(i)
      go to 10
    7 delyn = y(n)-y(nm1)
      delynm = delyn+delyn
      if (n .gt. 2) delynm = y(n)-y(n-2)
      if (delyn .le. 0. .or. delynm .le. delyn) go to 47
      call ceez (-delyn,-delynm,sigmay,c1,c2,c3,n)
      do 8 i = 1,m
        npi = n+i
    8   temp(npi) = c1*z(i,n)+c2*z(i,nm1)
      if (n .eq. 2) go to 10
      do 9 i = 1,m
        npi = n+i
    9   temp(npi) = temp(npi)+c3*z(i,n-2)
   10 if (x(m) .le. x(1)) go to 47
c
c denormalize tension factor in x-direction
c
      sigmax = abs(sigma)*float(m-1)/(x(m)-x(1))
c
c obtain x-partial derivatives along x = x(1)
c
      if ((islpsw/2)*2 .ne. islpsw) go to 12
      do 11 j = 1,n
   11   zp(1,j,2) = zx1(j)
      if ((islpsw/32)*2 .eq. (islpsw/16) .and.
     *    (islpsw/128)*2  .eq. (islpsw/64)) go to 15
   12 delx1 = x(2)-x(1)
      delx2 = delx1+delx1
      if (m .gt. 2) delx2 = x(3)-x(1)
      if (delx1 .le. 0. .or. delx2 .le. delx1) go to 47
      call ceez (delx1,delx2,sigmax,c1,c2,c3,m)
      if ((islpsw/2)*2 .eq. islpsw) go to 15
      do 13 j = 1,n
   13   zp(1,j,2) = c1*z(1,j)+c2*z(2,j)
      if (m .eq. 2) go to 15
      do 14 j = 1,n
   14   zp(1,j,2) = zp(1,j,2)+c3*z(3,j)
c
c obtain x-y-partial derivative at (x(1),y(1))
c
   15 if ((islpsw/32)*2 .ne. (islpsw/16)) go to 16
      zp(1,1,3) = zxy11
      go to 17
   16 zp(1,1,3) = c1*zp(1,1,1)+c2*zp(2,1,1)
      if (m .gt. 2) zp(1,1,3) = zp(1,1,3)+c3*zp(3,1,1)
c
c obtain x-y-partial derivative at (x(1),y(n))
c
   17 if ((islpsw/128)*2 .ne. (islpsw/64)) go to 18
      zxy1ns = zxy1n
      go to 19
   18 zxy1ns = c1*temp(n+1)+c2*temp(n+2)
      if (m .gt. 2) zxy1ns = zxy1ns+c3*temp(n+3)
c
c obtain x-partial derivative along x = x(m)
c
   19 if ((islpsw/4)*2 .ne. (islpsw/2)) go to 21
      do 20 j = 1,n
        npmpj = npm+j
   20   temp(npmpj) = zxm(j)
      if ((islpsw/64)*2 .eq. (islpsw/32) .and.
     *    (islpsw/256)*2 .eq. (islpsw/128)) go to 24
   21 delxm = x(m)-x(mm1)
      delxmm = delxm+delxm
      if (m .gt. 2) delxmm = x(m)-x(m-2)
      if (delxm .le. 0. .or. delxmm .le. delxm) go to 47
      call ceez (-delxm,-delxmm,sigmax,c1,c2,c3,m)
      if ((islpsw/4)*2 .eq. (islpsw/2)) go to 24
      do 22 j = 1,n
        npmpj = npm+j
   22   temp(npmpj) = c1*z(m,j)+c2*z(mm1,j)
      if (m .eq. 2) go to 24
      do 23 j = 1,n
        npmpj = npm+j
   23   temp(npmpj) = temp(npmpj)+c3*z(m-2,j)
c
c obtain x-y-partial derivative at (x(m),y(1))
c
   24 if ((islpsw/64)*2 .ne. (islpsw/32)) go to 25
      zp(m,1,3) = zxym1
      go to 26
   25 zp(m,1,3) = c1*zp(m,1,1)+c2*zp(mm1,1,1)
      if (m .gt. 2) zp(m,1,3) = zp(m,1,3)+c3*zp(m-2,1,1)
c
c obtain x-y-partial derivative at (x(m),y(n))
c
   26 if ((islpsw/256)*2 .ne. (islpsw/128)) go to 27
      zxymns = zxymn
      go to 28
   27 zxymns = c1*temp(npm)+c2*temp(npm-1)
      if (m .gt. 2) zxymns = zxymns+c3*temp(npm-2)
c
c set up right hand sides and tridiagonal system for y-grid
c perform forward elimination
c
   28 del1 = y(2)-y(1)
      if (del1 .le. 0.) go to 47
      deli = 1./del1
      do 29 i = 1,m
   29   zp(i,2,1) = deli*(z(i,2)-z(i,1))
      zp(1,2,3) = deli*(zp(1,2,2)-zp(1,1,2))
      zp(m,2,3) = deli*(temp(npm+2)-temp(npm+1))
      call terms (diag1,sdiag1,sigmay,del1)
      diagi = 1./diag1
      do 30 i = 1,m
   30   zp(i,1,1) = diagi*(zp(i,2,1)-zp(i,1,1))
      zp(1,1,3) = diagi*(zp(1,2,3)-zp(1,1,3))
      zp(m,1,3) = diagi*(zp(m,2,3)-zp(m,1,3))
      temp(1) = diagi*sdiag1
      if (n .eq. 2) go to 34
      do 33 j = 2,nm1
        jm1 = j-1
        jp1 = j+1
        npmpj = npm+j
        del2 = y(jp1)-y(j)
        if (del2 .le. 0.) go to 47
        deli = 1./del2
        do 31 i = 1,m
   31     zp(i,jp1,1) = deli*(z(i,jp1)-z(i,j))
        zp(1,jp1,3) = deli*(zp(1,jp1,2)-zp(1,j,2))
        zp(m,jp1,3) = deli*(temp(npmpj+1)-temp(npmpj))
        call terms (diag2,sdiag2,sigmay,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(jm1))
        do 32 i = 1,m
   32     zp(i,j,1) = diagin*(zp(i,jp1,1)-zp(i,j,1)-
     *                        sdiag1*zp(i,jm1,1))
        zp(1,j,3) = diagin*(zp(1,jp1,3)-zp(1,j,3)-
     *                      sdiag1*zp(1,jm1,3))
        zp(m,j,3) = diagin*(zp(m,jp1,3)-zp(m,j,3)-
     *                      sdiag1*zp(m,jm1,3))
        temp(j) = diagin*sdiag2
        diag1 = diag2
   33   sdiag1 = sdiag2
   34 diagin = 1./(diag1-sdiag1*temp(nm1))
      do 35 i = 1,m
        npi = n+i
   35   zp(i,n,1) = diagin*(temp(npi)-zp(i,n,1)-
     *                      sdiag1*zp(i,nm1,1))
      zp(1,n,3) = diagin*(zxy1ns-zp(1,n,3)-
     *                    sdiag1*zp(1,nm1,3))
      temp(n) = diagin*(zxymns-zp(m,n,3)-
     *                  sdiag1*zp(m,nm1,3))
c
c perform back substitution
c
      do 37 j = 2,n
        jbak = np1-j
        jbakp1 = jbak+1
        t = temp(jbak)
        do 36 i = 1,m
   36     zp(i,jbak,1) = zp(i,jbak,1)-t*zp(i,jbakp1,1)
        zp(1,jbak,3) = zp(1,jbak,3)-t*zp(1,jbakp1,3)
   37   temp(jbak) = zp(m,jbak,3)-t*temp(jbakp1)
c
c set up right hand sides and tridiagonal system for x-grid
c perform forward elimination
c
      del1 = x(2)-x(1)
      if (del1 .le. 0.) go to 47
      deli = 1./del1
      do 38 j = 1,n
        zp(2,j,2) = deli*(z(2,j)-z(1,j))
   38   zp(2,j,3) = deli*(zp(2,j,1)-zp(1,j,1))
      call terms (diag1,sdiag1,sigmax,del1)
      diagi = 1./diag1
      do 39 j = 1,n
        zp(1,j,2) = diagi*(zp(2,j,2)-zp(1,j,2))
   39   zp(1,j,3) = diagi*(zp(2,j,3)-zp(1,j,3))
      temp(n+1) = diagi*sdiag1
      if (m  .eq. 2) go to 43
      do 42 i = 2,mm1
        im1 = i-1
        ip1 = i+1
        npi = n+i
        del2 = x(ip1)-x(i)
        if (del2 .le. 0.) go to 47
        deli = 1./del2
        do 40 j = 1,n
          zp(ip1,j,2) = deli*(z(ip1,j)-z(i,j))
   40     zp(ip1,j,3) = deli*(zp(ip1,j,1)-zp(i,j,1))
        call terms (diag2,sdiag2,sigmax,del2)
        diagin = 1./(diag1+diag2-sdiag1*temp(npi-1))
        do 41 j = 1,n
          zp(i,j,2) = diagin*(zp(ip1,j,2)-zp(i,j,2)-
     *                        sdiag1*zp(im1,j,2))
   41     zp(i,j,3) = diagin*(zp(ip1,j,3)-zp(i,j,3)-
     *                        sdiag1*zp(im1,j,3))
        temp(npi) = diagin*sdiag2
        diag1 = diag2
   42   sdiag1 = sdiag2
   43 diagin = 1./(diag1-sdiag1*temp(npm-1))
      do 44 j = 1,n
        npmpj = npm+j
        zp(m,j,2) = diagin*(temp(npmpj)-zp(m,j,2)-
     *                      sdiag1*zp(mm1,j,2))
   44   zp(m,j,3) = diagin*(temp(j)-zp(m,j,3)-
     *                      sdiag1*zp(mm1,j,3))
c
c perform back substitution
c
      do 45 i = 2,m
        ibak = mp1-i
        ibakp1 = ibak+1
        npibak = n+ibak
        t = temp(npibak)
        do 45 j = 1,n
          zp(ibak,j,2) = zp(ibak,j,2)-t*zp(ibakp1,j,2)
   45     zp(ibak,j,3) = zp(ibak,j,3)-t*zp(ibakp1,j,3)
      return
c
c too few points
c
   46 ierr = 1
      return
c
c points not strictly increasing
c
   47 ierr = 2
      return
      end