! ====================================================================
!   Subroutine Datediff
!
!   Purpose: Calculation the difference of two date [d].
! ====================================================================
! =========================Incoming variables=========================
!   date1       The first date [yyyymmdd].
!   date2       The second date [yyyymmdd].
! =========================Outcoming variables========================
!   nd          The different day between date1 and date2 [d].
! ====================================================================
    SUBROUTINE Datediff(date1,date2,nd)
    IMPLICIT NONE
    INTEGER (KIND=4) :: nd
    INTEGER (KIND=4) :: jDATE
    CHARACTER (LEN=8) :: date1,date2

    nd = jDATE(date2)-jDATE(date1)

    RETURN
    END SUBROUTINE Datediff

! ====================================================================
!   Function ifrun
!
!   Purpose: IF leap year or not.
! ====================================================================
! =========================Incoming variables=========================
!   year        The imput year [yyyymmdd].
! =========================Outcoming variables========================
!   ifrun       1 for leap year; 0 for others.
! ====================================================================
    INTEGER Function ifrun(year)
    IMPLICIT NONE
    INTEGER (KIND=4) :: year

    IF (mod(year,4)==0 .and. mod(year,100).ne.0) THEN
        ifrun=1
    ELSEIF (mod(year,400)==0 .and. mod(year,100)==0) THEN
        ifrun=1
    ELSE
        ifrun=0
    ENDIF

    RETURN
    END Function ifrun

! ====================================================================
!   Function JDate
!
!   Purpose: Calculation the Julian day with the beginning of 1960-1-1
!            When the date is 1960-1-1, the result is 1.
! ====================================================================
! =========================Incoming variables=========================
!   date        The imput date [yyyymmdd].
! =========================Outcoming variables========================
!   JDate       The different beween for the date and 1960-1-1.
! ====================================================================
    INTEGER Function JDate(date)
    IMPLICIT NONE
    CHARACTER (LEN=8) :: date
    INTEGER (KIND=4) :: nY, nM, nD, numrun, nmd, nyd, i
    INTEGER (KIND=4) :: ifrun

    READ(date(1:4),"(i4)")nY
    READ(date(5:6),"(i2)")nM
    READ(date(7:8),"(i2)")nD

    IF (ny<1960) PRINT*,"error in year chioces"
    nyd=ny-1960 ! Difference of year.
    numrun=0

    DO i=1960,nY
        numrun=numrun+ifrun(i)
    ENDDO

    SELECT CASE(nm-1)
    CASE(0)
        nmd=0
    CASE(1)
        nmd=31
    CASE(2)
        nmd=59
    CASE(3)
        nmd=90
    CASE(4)
        nmd=120
    CASE(5)
        nmd=151
    CASE(6)
        nmd=181
    CASE(7)
        nmd=212
    CASE(8)
        nmd=243
    CASE(9)
        nmd=273
    CASE(10)
        nmd=304
    CASE(11)
        nmd=334
    END SELECT

    IF (ifrun(ny).and.nm<3) nmd=nmd-1 ! leap year does not have 2-29
    Jdate=nyd*365+numrun+nmd+nd

    END Function JDate

! ====================================================================
!   SUBROUTINE DateAdd
!
!   Purpose: The new date when a date adds integer days.
! ====================================================================
! =========================Incoming variables=========================
!   date        The imput date [yyyymmdd].
!   interval    The integer that will be added to the date [d].
! =========================Outcoming variables========================
!   date1       the new date which has been added [yyyymmdd].
! ====================================================================
    SUBROUTINE DateAdd(date,interval,date1)
    IMPLICIT NONE

    CHARACTER (LEN=8) :: date
    CHARACTER (LEN=8) :: date1
    INTEGER (kind=4) :: ny, nm, nd, n, interval, i, ifrun

    READ(date(1:4),"(i4)")ny
    READ(date(5:6),"(i2)")nm
    READ(date(7:8),"(i2)")nd
    n=interval
    DO i=1,n
        nd=nd+1
        IF (nd>31.and.(nm.eq.1.or.nm.eq.3.or.nm.eq.5.or.nm.eq.7.or.nm.eq.8.or.nm.eq.10.or.nm.eq.12)) THEN
            nd=1
            nm=nm+1
        ELSEIF (nd>30.and.(nm.eq.4.or.nm.eq.6.or.nm.eq.9.or.nm.eq.11)) THEN
            nd=1
            nm=nm+1
        ELSEIF (nm==2.and.ifrun(ny).and.nd>29) THEN
            nd=1
            nm=nm+1
        ELSEIF (nm==2.and.ifrun(ny)==0.and.nd>28) THEN
            nd=1
            nm=nm+1
        ENDIF
!       Month add.

        IF (nm>12) THEN
            nm=1
            ny=ny+1
        ENDIF
    ENDDO
    WRITE(date1,"(i4.4,i2.2,i2.2)")ny,nm,nd

    END SUBROUTINE DateAdd

! ====================================================================
!   SUBROUTINE Tcontrol
!
!   Purpose: t+dt.
!            Considering print time, boundary condition time and
!            endding time, self-adaption the dt.
! ====================================================================
    SUBROUTINE Tcontrol
    USE parm
    IMPLICIT NONE
    INTEGER (KIND=KI) :: i
    REAL (KIND=KR) :: dt1

    IF (t+dt>TAtm .and. t<TAtm-1E-8) THEN
        dt1 = TAtm - t
        dt = min(dt,dt1)
    ENDIF

    IF (t+dt>TPrint(PLevel) .and. t<(TPrint(PLevel)-1E-8)) THEN
        dt1 = TPrint(PLevel) - t
        dt = min(dt,dt1)
    ENDIF

    IF(t+dt>Tend .and. t<Tend) THEN
        dt1 = Tend-t
        dt = min(dt,dt1)
    ENDIF
!    t = t+dt

    END SUBROUTINE Tcontrol


module precision
  implicit none
  ! explicit visibility declaration
  private
  ! self-documentation
  public :: int1,int2,int4,int8
  public :: real4,real8
  public :: ik, rk
  ! integer kinds
  integer, parameter :: int1 = selected_int_kind(1)
  integer, parameter :: int2 = selected_int_kind(2)
  integer, parameter :: int4 = selected_int_kind(8)
  integer, parameter :: int8 = selected_int_kind(10)
  ! floating point kinds
  integer, parameter :: real4 = selected_real_kind(6)
  integer, parameter :: real8 = selected_real_kind(15)
  integer, parameter :: real16 = selected_real_kind(32)
  ! generic kinds
  integer, parameter :: ik = int4   ! generic integer kind
  integer, parameter :: rk = real8 ! generic real kind
end module precision


program test1
  use SparseKit
  implicit none
  type(Sparse) :: matrix

  matrix = sparse( nnz = 16, rows = 4)

  call matrix%append( val =    4.d0, row = 1, col = 1)
  call matrix%append( val =  -30.d0, row = 1, col = 2)
  call matrix%append( val =   60.d0, row = 1, col = 3)
  call matrix%append( val =  -35.d0, row = 1, col = 4)
  call matrix%append( val =  -30.d0, row = 2, col = 1)
  call matrix%append( val =  300.d0, row = 2, col = 2)
  call matrix%append( val = -675.d0, row = 2, col = 3)
  call matrix%append( val =  420.d0, row = 2, col = 4)
  call matrix%append( val =   60.d0, row = 3, col = 1)
  call matrix%append( val = -675.d0, row = 3, col = 2)
  call matrix%append( val = 1620.d0, row = 3, col = 3)
  call matrix%append( val =-1050.d0, row = 3, col = 4)
  call matrix%append( val =  -35.d0, row = 4, col = 1)
  call matrix%append( val =  420.d0, row = 4, col = 2)
  call matrix%append( val =-1050.d0, row = 4, col = 3)
  call matrix%append( val =  700.d0, row = 4, col = 4)

  call matrix%makeCRS

  print'(/,A,E12.5,/)','A(3,2) = ', matrix%get      ( 3, 3)
  print'(A,1X,I0,/)','nnz    = ', matrix%getnnz()
  print'(A,1X,I0,/)','n      = ', matrix%getn()

end program test1

tests/test1 - Armado de matriz y acceso a valores/main.f90


      SUBROUTINE DEC (N, NDIM, A, IP, IER)
C VERSION REAL DOUBLE PRECISION
      INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J
      DOUBLE PRECISION A,T
      DIMENSION A(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
C  INPUT..
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF ARRAY  A .
C     A = MATRIX TO BE TRIANGULARIZED.
C  OUTPUT..
C     A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U .
C     A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C     IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C     IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE
C           SINGULAR AT STAGE K.
C  USE  SOL  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N).
C  IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = K
        DO 10 I = KP1,N
          IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I
 10     CONTINUE
        IP(K) = M
        T = A(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        A(M,K) = A(K,K)
        A(K,K) = T
 20     CONTINUE
        IF (T .EQ. 0.D0) GO TO 80
        T = 1.D0/T
        DO 30 I = KP1,N
 30       A(I,K) = -A(I,K)*T
        DO 50 J = KP1,N
          T = A(M,J)
          A(M,J) = A(K,J)
          A(K,J) = T
          IF (T .EQ. 0.D0) GO TO 45
          DO 40 I = KP1,N
 40         A(I,J) = A(I,J) + A(I,K)*T
 45       CONTINUE
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (A(N,N) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DEC -------------------------
      END
C
C
      SUBROUTINE SOL (N, NDIM, A, B, IP)
C VERSION REAL DOUBLE PRECISION
      INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1
      DOUBLE PRECISION A,B,T
      DIMENSION A(NDIM,N), B(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N = ORDER OF MATRIX.
C    NDIM = DECLARED DIMENSION OF ARRAY  A .
C    A = TRIANGULARIZED MATRIX OBTAINED FROM DEC.
C    B = RIGHT HAND SIDE VECTOR.
C    IP = PIVOT VECTOR OBTAINED FROM DEC.
C  DO NOT USE IF DEC HAS SET IER .NE. 0.
C  OUTPUT..
C    B = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        T = B(M)
        B(M) = B(K)
        B(K) = T
        DO 10 I = KP1,N
 10       B(I) = B(I) + A(I,K)*T
 20     CONTINUE
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        B(K) = B(K)/A(K,K)
        T = -B(K)
        DO 30 I = 1,KM1
 30       B(I) = B(I) + A(I,K)*T
 40     CONTINUE
 50   B(1) = B(1)/A(1,1)
      RETURN
C----------------------- END OF SUBROUTINE SOL -------------------------
      END
c
c
      SUBROUTINE DECH (N, NDIM, A, LB, IP, IER)
C VERSION REAL DOUBLE PRECISION
      INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J,LB,NA
      DOUBLE PRECISION A,T
      DIMENSION A(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A HESSENBERG
C  MATRIX WITH LOWER BANDWIDTH LB
C  INPUT..
C     N = ORDER OF MATRIX A.
C     NDIM = DECLARED DIMENSION OF ARRAY  A .
C     A = MATRIX TO BE TRIANGULARIZED.
C     LB = LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED, LB.GE.1).
C  OUTPUT..
C     A(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U .
C     A(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C     IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C     IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE
C           SINGULAR AT STAGE K.
C  USE  SOLH  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  DETERM(A) = IP(N)*A(1,1)*A(2,2)*...*A(N,N).
C  IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     THIS IS A SLIGHT MODIFICATION OF
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = K
        NA = MIN0(N,LB+K)
        DO 10 I = KP1,NA
          IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I
 10     CONTINUE
        IP(K) = M
        T = A(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        A(M,K) = A(K,K)
        A(K,K) = T
 20     CONTINUE
        IF (T .EQ. 0.D0) GO TO 80
        T = 1.D0/T
        DO 30 I = KP1,NA
 30       A(I,K) = -A(I,K)*T
        DO 50 J = KP1,N
          T = A(M,J)
          A(M,J) = A(K,J)
          A(K,J) = T
          IF (T .EQ. 0.D0) GO TO 45
          DO 40 I = KP1,NA
 40         A(I,J) = A(I,J) + A(I,K)*T
 45       CONTINUE
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (A(N,N) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DECH ------------------------
      END
C
C
      SUBROUTINE SOLH (N, NDIM, A, LB, B, IP)
C VERSION REAL DOUBLE PRECISION
      INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1,LB,NA
      DOUBLE PRECISION A,B,T
      DIMENSION A(NDIM,N), B(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N = ORDER OF MATRIX A.
C    NDIM = DECLARED DIMENSION OF ARRAY  A .
C    A = TRIANGULARIZED MATRIX OBTAINED FROM DECH.
C    LB = LOWER BANDWIDTH OF A.
C    B = RIGHT HAND SIDE VECTOR.
C    IP = PIVOT VECTOR OBTAINED FROM DEC.
C  DO NOT USE IF DECH HAS SET IER .NE. 0.
C  OUTPUT..
C    B = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        T = B(M)
        B(M) = B(K)
        B(K) = T
        NA = MIN0(N,LB+K)
        DO 10 I = KP1,NA
 10       B(I) = B(I) + A(I,K)*T
 20     CONTINUE
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        B(K) = B(K)/A(K,K)
        T = -B(K)
        DO 30 I = 1,KM1
 30       B(I) = B(I) + A(I,K)*T
 40     CONTINUE
 50   B(1) = B(1)/A(1,1)
      RETURN
C----------------------- END OF SUBROUTINE SOLH ------------------------
      END
C
      SUBROUTINE DECC (N, NDIM, AR, AI, IP, IER)
C VERSION COMPLEX DOUBLE PRECISION
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J
      DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION
C  ------ MODIFICATION FOR COMPLEX MATRICES --------
C  INPUT..
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF ARRAYS  AR AND AI .
C     (AR, AI) = MATRIX TO BE TRIANGULARIZED.
C  OUTPUT..
C     AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART.
C     AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART.
C     AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C                                                    REAL PART.
C     AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C                                                    IMAGINARY PART.
C     IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C     IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE
C           SINGULAR AT STAGE K.
C  USE  SOL  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = K
        DO 10 I = KP1,N
          IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT.
     &          DABS(AR(M,K))+DABS(AI(M,K))) M = I
 10     CONTINUE
        IP(K) = M
        TR = AR(M,K)
        TI = AI(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        AR(M,K) = AR(K,K)
        AI(M,K) = AI(K,K)
        AR(K,K) = TR
        AI(K,K) = TI
 20     CONTINUE
        IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80
        DEN=TR*TR+TI*TI
        TR=TR/DEN
        TI=-TI/DEN
        DO 30 I = KP1,N
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          AR(I,K)=-PRODR
          AI(I,K)=-PRODI
 30       CONTINUE
        DO 50 J = KP1,N
          TR = AR(M,J)
          TI = AI(M,J)
          AR(M,J) = AR(K,J)
          AI(M,J) = AI(K,J)
          AR(K,J) = TR
          AI(K,J) = TI
          IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48
          IF (TI .EQ. 0.D0) THEN
            DO 40 I = KP1,N
            PRODR=AR(I,K)*TR
            PRODI=AI(I,K)*TR
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 40         CONTINUE
            GO TO 48
          END IF
          IF (TR .EQ. 0.D0) THEN
            DO 45 I = KP1,N
            PRODR=-AI(I,K)*TI
            PRODI=AR(I,K)*TI
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 45         CONTINUE
            GO TO 48
          END IF
          DO 47 I = KP1,N
            PRODR=AR(I,K)*TR-AI(I,K)*TI
            PRODI=AI(I,K)*TR+AR(I,K)*TI
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 47         CONTINUE
 48       CONTINUE
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DECC ------------------------
      END
C
C
      SUBROUTINE SOLC (N, NDIM, AR, AI, BR, BI, IP)
C VERSION COMPLEX DOUBLE PRECISION
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1
      DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N = ORDER OF MATRIX.
C    NDIM = DECLARED DIMENSION OF ARRAYS  AR AND AI.
C    (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DEC.
C    (BR,BI) = RIGHT HAND SIDE VECTOR.
C    IP = PIVOT VECTOR OBTAINED FROM DEC.
C  DO NOT USE IF DEC HAS SET IER .NE. 0.
C  OUTPUT..
C    (BR,BI) = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        TR = BR(M)
        TI = BI(M)
        BR(M) = BR(K)
        BI(M) = BI(K)
        BR(K) = TR
        BI(K) = TI
        DO 10 I = KP1,N
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(I) = BR(I) + PRODR
          BI(I) = BI(I) + PRODI
 10       CONTINUE
 20     CONTINUE
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K)
        PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K)
        PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K)
        BR(K)=PRODR/DEN
        BI(K)=PRODI/DEN
        TR = -BR(K)
        TI = -BI(K)
        DO 30 I = 1,KM1
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(I) = BR(I) + PRODR
          BI(I) = BI(I) + PRODI
 30       CONTINUE
 40     CONTINUE
 50     CONTINUE
        DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1)
        PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1)
        PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1)
        BR(1)=PRODR/DEN
        BI(1)=PRODI/DEN
      RETURN
C----------------------- END OF SUBROUTINE SOLC ------------------------
      END
C
C
      SUBROUTINE DECHC (N, NDIM, AR, AI, LB, IP, IER)
C VERSION COMPLEX DOUBLE PRECISION
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER N,NDIM,IP,IER,NM1,K,KP1,M,I,J
      DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION
C  ------ MODIFICATION FOR COMPLEX MATRICES --------
C  INPUT..
C     N = ORDER OF MATRIX.
C     NDIM = DECLARED DIMENSION OF ARRAYS  AR AND AI .
C     (AR, AI) = MATRIX TO BE TRIANGULARIZED.
C  OUTPUT..
C     AR(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; REAL PART.
C     AI(I,J), I.LE.J = UPPER TRIANGULAR FACTOR, U ; IMAGINARY PART.
C     AR(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C                                                    REAL PART.
C     AI(I,J), I.GT.J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
C                                                    IMAGINARY PART.
C     LB = LOWER BANDWIDTH OF A (DIAGONAL NOT COUNTED), LB.GE.1.
C     IP(K), K.LT.N = INDEX OF K-TH PIVOT ROW.
C     IP(N) = (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER = 0 IF MATRIX A IS NONSINGULAR, OR K IF FOUND TO BE
C           SINGULAR AT STAGE K.
C  USE  SOL  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  IF IP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      IF (LB .EQ. 0) GO TO 70
      IF (N .EQ. 1) GO TO 70
      NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = K
        NA = MIN0(N,LB+K)
        DO 10 I = KP1,NA
          IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT.
     &          DABS(AR(M,K))+DABS(AI(M,K))) M = I
 10     CONTINUE
        IP(K) = M
        TR = AR(M,K)
        TI = AI(M,K)
        IF (M .EQ. K) GO TO 20
        IP(N) = -IP(N)
        AR(M,K) = AR(K,K)
        AI(M,K) = AI(K,K)
        AR(K,K) = TR
        AI(K,K) = TI
 20     CONTINUE
        IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80
        DEN=TR*TR+TI*TI
        TR=TR/DEN
        TI=-TI/DEN
        DO 30 I = KP1,NA
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          AR(I,K)=-PRODR
          AI(I,K)=-PRODI
 30       CONTINUE
        DO 50 J = KP1,N
          TR = AR(M,J)
          TI = AI(M,J)
          AR(M,J) = AR(K,J)
          AI(M,J) = AI(K,J)
          AR(K,J) = TR
          AI(K,J) = TI
          IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48
          IF (TI .EQ. 0.D0) THEN
            DO 40 I = KP1,NA
            PRODR=AR(I,K)*TR
            PRODI=AI(I,K)*TR
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 40         CONTINUE
            GO TO 48
          END IF
          IF (TR .EQ. 0.D0) THEN
            DO 45 I = KP1,NA
            PRODR=-AI(I,K)*TI
            PRODI=AR(I,K)*TI
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 45         CONTINUE
            GO TO 48
          END IF
          DO 47 I = KP1,NA
            PRODR=AR(I,K)*TR-AI(I,K)*TI
            PRODI=AI(I,K)*TR+AR(I,K)*TI
            AR(I,J) = AR(I,J) + PRODR
            AI(I,J) = AI(I,J) + PRODI
 47         CONTINUE
 48       CONTINUE
 50       CONTINUE
 60     CONTINUE
 70   K = N
      IF (DABS(AR(N,N))+DABS(AI(N,N)) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DECHC -----------------------
      END
C
C
      SUBROUTINE SOLHC (N, NDIM, AR, AI, LB, BR, BI, IP)
C VERSION COMPLEX DOUBLE PRECISION
      IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER N,NDIM,IP,NM1,K,KP1,M,I,KB,KM1
      DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N = ORDER OF MATRIX.
C    NDIM = DECLARED DIMENSION OF ARRAYS  AR AND AI.
C    (AR,AI) = TRIANGULARIZED MATRIX OBTAINED FROM DEC.
C    (BR,BI) = RIGHT HAND SIDE VECTOR.
C    LB = LOWER BANDWIDTH OF A.
C    IP = PIVOT VECTOR OBTAINED FROM DEC.
C  DO NOT USE IF DEC HAS SET IER .NE. 0.
C  OUTPUT..
C    (BR,BI) = SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      IF (N .EQ. 1) GO TO 50
      NM1 = N - 1
      IF (LB .EQ. 0) GO TO 25
      DO 20 K = 1,NM1
        KP1 = K + 1
        M = IP(K)
        TR = BR(M)
        TI = BI(M)
        BR(M) = BR(K)
        BI(M) = BI(K)
        BR(K) = TR
        BI(K) = TI
        DO 10 I = KP1,MIN0(N,LB+K)
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(I) = BR(I) + PRODR
          BI(I) = BI(I) + PRODI
 10       CONTINUE
 20     CONTINUE
 25     CONTINUE
      DO 40 KB = 1,NM1
        KM1 = N - KB
        K = KM1 + 1
        DEN=AR(K,K)*AR(K,K)+AI(K,K)*AI(K,K)
        PRODR=BR(K)*AR(K,K)+BI(K)*AI(K,K)
        PRODI=BI(K)*AR(K,K)-BR(K)*AI(K,K)
        BR(K)=PRODR/DEN
        BI(K)=PRODI/DEN
        TR = -BR(K)
        TI = -BI(K)
        DO 30 I = 1,KM1
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(I) = BR(I) + PRODR
          BI(I) = BI(I) + PRODI
 30       CONTINUE
 40     CONTINUE
 50     CONTINUE
        DEN=AR(1,1)*AR(1,1)+AI(1,1)*AI(1,1)
        PRODR=BR(1)*AR(1,1)+BI(1)*AI(1,1)
        PRODI=BI(1)*AR(1,1)-BR(1)*AI(1,1)
        BR(1)=PRODR/DEN
        BI(1)=PRODI/DEN
      RETURN
C----------------------- END OF SUBROUTINE SOLHC -----------------------
      END
C
      SUBROUTINE DECB (N, NDIM, A, ML, MU, IP, IER)
      REAL*8 A,T
      DIMENSION A(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED
C  MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU
C  INPUT..
C     N       ORDER OF THE ORIGINAL MATRIX A.
C     NDIM    DECLARED DIMENSION OF ARRAY  A.
C     A       CONTAINS THE MATRIX IN BAND STORAGE.   THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  A  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  A.
C     ML      LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C     MU      UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C  OUTPUT..
C     A       AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C     IP      INDEX VECTOR OF PIVOT INDICES.
C     IP(N)   (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER     = 0 IF MATRIX A IS NONSINGULAR, OR  = K IF FOUND TO BE
C                SINGULAR AT STAGE K.
C  USE  SOLB  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N)  WITH MD=ML+MU+1.
C  IF IP(N)=O, A IS SINGULAR, SOLB WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     THIS IS A MODIFICATION OF
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      MD = ML + MU + 1
      MD1 = MD + 1
      JU = 0
      IF (ML .EQ. 0) GO TO 70
      IF (N .EQ. 1) GO TO 70
      IF (N .LT. MU+2) GO TO 7
      DO 5 J = MU+2,N
      DO 5 I = 1,ML
  5   A(I,J) = 0.D0
  7   NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = MD
        MDL = MIN(ML,N-K) + MD
        DO 10 I = MD1,MDL
          IF (DABS(A(I,K)) .GT. DABS(A(M,K))) M = I
 10     CONTINUE
        IP(K) = M + K - MD
        T = A(M,K)
        IF (M .EQ. MD) GO TO 20
        IP(N) = -IP(N)
        A(M,K) = A(MD,K)
        A(MD,K) = T
 20     CONTINUE
        IF (T .EQ. 0.D0) GO TO 80
        T = 1.D0/T
        DO 30 I = MD1,MDL
 30       A(I,K) = -A(I,K)*T
        JU = MIN0(MAX0(JU,MU+IP(K)),N)
        MM = MD
        IF (JU .LT. KP1) GO TO 55
        DO 50 J = KP1,JU
          M = M - 1
          MM = MM - 1
          T = A(M,J)
          IF (M .EQ. MM) GO TO 35
          A(M,J) = A(MM,J)
          A(MM,J) = T
 35       CONTINUE
          IF (T .EQ. 0.D0) GO TO 45
          JK = J - K
          DO 40 I = MD1,MDL
            IJK = I - JK
 40         A(IJK,J) = A(IJK,J) + A(I,K)*T
 45       CONTINUE
 50       CONTINUE
 55     CONTINUE
 60     CONTINUE
 70   K = N
      IF (A(MD,N) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DECB ------------------------
      END
C
C
      SUBROUTINE SOLB (N, NDIM, A, ML, MU, B, IP)
      REAL*8 A,B,T
      DIMENSION A(NDIM,N), B(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B .
C  INPUT..
C    N      ORDER OF MATRIX A.
C    NDIM   DECLARED DIMENSION OF ARRAY  A .
C    A      TRIANGULARIZED MATRIX OBTAINED FROM DECB.
C    ML     LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C    MU     UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C    B      RIGHT HAND SIDE VECTOR.
C    IP     PIVOT VECTOR OBTAINED FROM DECB.
C  DO NOT USE IF DECB HAS SET IER .NE. 0.
C  OUTPUT..
C    B      SOLUTION VECTOR, X .
C-----------------------------------------------------------------------
      MD = ML + MU + 1
      MD1 = MD + 1
      MDM = MD - 1
      NM1 = N - 1
      IF (ML .EQ. 0) GO TO 25
      IF (N .EQ. 1) GO TO 50
      DO 20 K = 1,NM1
        M = IP(K)
        T = B(M)
        B(M) = B(K)
        B(K) = T
        MDL = MIN(ML,N-K) + MD
        DO 10 I = MD1,MDL
          IMD = I + K - MD
 10       B(IMD) = B(IMD) + A(I,K)*T
 20     CONTINUE
 25   CONTINUE
      DO 40 KB = 1,NM1
        K = N + 1 - KB
        B(K) = B(K)/A(MD,K)
        T = -B(K)
        KMD = MD - K
        LM = MAX0(1,KMD+1)
        DO 30 I = LM,MDM
          IMD = I - KMD
 30       B(IMD) = B(IMD) + A(I,K)*T
 40     CONTINUE
 50   B(1) = B(1)/A(MD,1)
      RETURN
C----------------------- END OF SUBROUTINE SOLB ------------------------
      END
C
      SUBROUTINE DECBC (N, NDIM, AR, AI, ML, MU, IP, IER)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AR(NDIM,N), AI(NDIM,N), IP(N)
C-----------------------------------------------------------------------
C  MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED COMPLEX
C  MATRIX WITH LOWER BANDWIDTH ML AND UPPER BANDWIDTH MU
C  INPUT..
C     N       ORDER OF THE ORIGINAL MATRIX A.
C     NDIM    DECLARED DIMENSION OF ARRAY  A.
C     AR, AI     CONTAINS THE MATRIX IN BAND STORAGE.   THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  AR (REAL
C                PART) AND AI (IMAGINARY PART)  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  AR AND AI.
C     ML      LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C     MU      UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C  OUTPUT..
C     AR, AI  AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C     IP      INDEX VECTOR OF PIVOT INDICES.
C     IP(N)   (-1)**(NUMBER OF INTERCHANGES) OR O .
C     IER     = 0 IF MATRIX A IS NONSINGULAR, OR  = K IF FOUND TO BE
C                SINGULAR AT STAGE K.
C  USE  SOLBC  TO OBTAIN SOLUTION OF LINEAR SYSTEM.
C  DETERM(A) = IP(N)*A(MD,1)*A(MD,2)*...*A(MD,N)  WITH MD=ML+MU+1.
C  IF IP(N)=O, A IS SINGULAR, SOLBC WILL DIVIDE BY ZERO.
C
C  REFERENCE..
C     THIS IS A MODIFICATION OF
C     C. B. MOLER, ALGORITHM 423, LINEAR EQUATION SOLVER,
C     C.A.C.M. 15 (1972), P. 274.
C-----------------------------------------------------------------------
      IER = 0
      IP(N) = 1
      MD = ML + MU + 1
      MD1 = MD + 1
      JU = 0
      IF (ML .EQ. 0) GO TO 70
      IF (N .EQ. 1) GO TO 70
      IF (N .LT. MU+2) GO TO 7
      DO 5 J = MU+2,N
      DO 5 I = 1,ML
      AR(I,J) = 0.D0
      AI(I,J) = 0.D0
  5   CONTINUE
  7   NM1 = N - 1
      DO 60 K = 1,NM1
        KP1 = K + 1
        M = MD
        MDL = MIN(ML,N-K) + MD
        DO 10 I = MD1,MDL
          IF (DABS(AR(I,K))+DABS(AI(I,K)) .GT.
     &          DABS(AR(M,K))+DABS(AI(M,K))) M = I
 10     CONTINUE
        IP(K) = M + K - MD
        TR = AR(M,K)
        TI = AI(M,K)
        IF (M .EQ. MD) GO TO 20
        IP(N) = -IP(N)
        AR(M,K) = AR(MD,K)
        AI(M,K) = AI(MD,K)
        AR(MD,K) = TR
        AI(MD,K) = TI
 20     IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 80
        DEN=TR*TR+TI*TI
        TR=TR/DEN
        TI=-TI/DEN
        DO 30 I = MD1,MDL
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          AR(I,K)=-PRODR
          AI(I,K)=-PRODI
 30       CONTINUE
        JU = MIN0(MAX0(JU,MU+IP(K)),N)
        MM = MD
        IF (JU .LT. KP1) GO TO 55
        DO 50 J = KP1,JU
          M = M - 1
          MM = MM - 1
          TR = AR(M,J)
          TI = AI(M,J)
          IF (M .EQ. MM) GO TO 35
          AR(M,J) = AR(MM,J)
          AI(M,J) = AI(MM,J)
          AR(MM,J) = TR
          AI(MM,J) = TI
 35       CONTINUE
          IF (DABS(TR)+DABS(TI) .EQ. 0.D0) GO TO 48
          JK = J - K
          IF (TI .EQ. 0.D0) THEN
            DO 40 I = MD1,MDL
            IJK = I - JK
            PRODR=AR(I,K)*TR
            PRODI=AI(I,K)*TR
            AR(IJK,J) = AR(IJK,J) + PRODR
            AI(IJK,J) = AI(IJK,J) + PRODI
 40         CONTINUE
            GO TO 48
          END IF
          IF (TR .EQ. 0.D0) THEN
            DO 45 I = MD1,MDL
            IJK = I - JK
            PRODR=-AI(I,K)*TI
            PRODI=AR(I,K)*TI
            AR(IJK,J) = AR(IJK,J) + PRODR
            AI(IJK,J) = AI(IJK,J) + PRODI
 45         CONTINUE
            GO TO 48
          END IF
          DO 47 I = MD1,MDL
            IJK = I - JK
            PRODR=AR(I,K)*TR-AI(I,K)*TI
            PRODI=AI(I,K)*TR+AR(I,K)*TI
            AR(IJK,J) = AR(IJK,J) + PRODR
            AI(IJK,J) = AI(IJK,J) + PRODI
 47         CONTINUE
 48       CONTINUE
 50       CONTINUE
 55     CONTINUE
 60     CONTINUE
 70   K = N
      IF (DABS(AR(MD,N))+DABS(AI(MD,N)) .EQ. 0.D0) GO TO 80
      RETURN
 80   IER = K
      IP(N) = 0
      RETURN
C----------------------- END OF SUBROUTINE DECBC ------------------------
      END
C
C
      SUBROUTINE SOLBC (N, NDIM, AR, AI, ML, MU, BR, BI, IP)
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION AR(NDIM,N), AI(NDIM,N), BR(N), BI(N), IP(N)
C-----------------------------------------------------------------------
C  SOLUTION OF LINEAR SYSTEM, A*X = B ,
C                  VERSION BANDED AND COMPLEX-DOUBLE PRECISION.
C  INPUT..
C    N      ORDER OF MATRIX A.
C    NDIM   DECLARED DIMENSION OF ARRAY  A .
C    AR, AI TRIANGULARIZED MATRIX OBTAINED FROM DECB (REAL AND IMAG. PART).
C    ML     LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C    MU     UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
C    BR, BI RIGHT HAND SIDE VECTOR (REAL AND IMAG. PART).
C    IP     PIVOT VECTOR OBTAINED FROM DECBC.
C  DO NOT USE IF DECB HAS SET IER .NE. 0.
C  OUTPUT..
C    BR, BI SOLUTION VECTOR, X (REAL AND IMAG. PART).
C-----------------------------------------------------------------------
      MD = ML + MU + 1
      MD1 = MD + 1
      MDM = MD - 1
      NM1 = N - 1
      IF (ML .EQ. 0) GO TO 25
      IF (N .EQ. 1) GO TO 50
      DO 20 K = 1,NM1
        M = IP(K)
        TR = BR(M)
        TI = BI(M)
        BR(M) = BR(K)
        BI(M) = BI(K)
        BR(K) = TR
        BI(K) = TI
        MDL = MIN(ML,N-K) + MD
        DO 10 I = MD1,MDL
          IMD = I + K - MD
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(IMD) = BR(IMD) + PRODR
          BI(IMD) = BI(IMD) + PRODI
 10     CONTINUE
 20     CONTINUE
 25     CONTINUE
      DO 40 KB = 1,NM1
        K = N + 1 - KB
        DEN=AR(MD,K)*AR(MD,K)+AI(MD,K)*AI(MD,K)
        PRODR=BR(K)*AR(MD,K)+BI(K)*AI(MD,K)
        PRODI=BI(K)*AR(MD,K)-BR(K)*AI(MD,K)
        BR(K)=PRODR/DEN
        BI(K)=PRODI/DEN
        TR = -BR(K)
        TI = -BI(K)
        KMD = MD - K
        LM = MAX0(1,KMD+1)
        DO 30 I = LM,MDM
          IMD = I - KMD
          PRODR=AR(I,K)*TR-AI(I,K)*TI
          PRODI=AI(I,K)*TR+AR(I,K)*TI
          BR(IMD) = BR(IMD) + PRODR
          BI(IMD) = BI(IMD) + PRODI
 30       CONTINUE
 40     CONTINUE
        DEN=AR(MD,1)*AR(MD,1)+AI(MD,1)*AI(MD,1)
        PRODR=BR(1)*AR(MD,1)+BI(1)*AI(MD,1)
        PRODI=BI(1)*AR(MD,1)-BR(1)*AI(MD,1)
        BR(1)=PRODR/DEN
        BI(1)=PRODI/DEN
 50   CONTINUE
      RETURN
C----------------------- END OF SUBROUTINE SOLBC ------------------------
      END
c
C
      subroutine elmhes(nm,n,low,igh,a,int)
C
      integer i,j,m,n,la,nm,igh,kp1,low,mm1,mp1
      real*8 a(nm,n)
      real*8 x,y
      real*8 dabs
      integer int(igh)
C
C     this subroutine is a translation of the algol procedure elmhes,
C     num. math. 12, 349-368(1968) by martin and wilkinson.
C     handbook for auto. comp., vol.ii-linear algebra, 339-358(1971).
C
C     given a real general matrix, this subroutine
C     reduces a submatrix situated in rows and columns
C     low through igh to upper hessenberg form by
C     stabilized elementary similarity transformations.
C
C     on input:
C
C      nm must be set to the row dimension of two-dimensional
C        array parameters as declared in the calling program
C        dimension statement;
C
C      n is the order of the matrix;
C
C      low and igh are integers determined by the balancing
C        subroutine  balanc.      if  balanc  has not been used,
C        set low=1, igh=n;
C
C      a contains the input matrix.
C
C     on output:
C
C      a contains the hessenberg matrix.  the multipliers
C        which were used in the reduction are stored in the
C        remaining triangle under the hessenberg matrix;
C
C      int contains information on the rows and columns
C        interchanged in the reduction.
C        only elements low through igh are used.
C
C     questions and comments should be directed to b. s. garbow,
C     applied mathematics division, argonne national laboratory
C
C     ------------------------------------------------------------------
C
      la = igh - 1
      kp1 = low + 1
      if (la .lt. kp1) go to 200
C
      do 180 m = kp1, la
       mm1 = m - 1
       x = 0.0d0
       i = m
C
       do 100 j = m, igh
          if (dabs(a(j,mm1)) .le. dabs(x)) go to 100
          x = a(j,mm1)
          i = j
  100   continue
C
       int(m) = i
       if (i .eq. m) go to 130
C    :::::::::: interchange rows and columns of a ::::::::::
       do 110 j = mm1, n
          y = a(i,j)
          a(i,j) = a(m,j)
          a(m,j) = y
  110   continue
C
       do 120 j = 1, igh
          y = a(j,i)
          a(j,i) = a(j,m)
          a(j,m) = y
  120   continue
C    :::::::::: end interchange ::::::::::
  130   if (x .eq. 0.0d0) go to 180
       mp1 = m + 1
C
       do 160 i = mp1, igh
          y = a(i,mm1)
          if (y .eq. 0.0d0) go to 160
          y = y / x
          a(i,mm1) = y
C
          do 140 j = m, n
  140      a(i,j) = a(i,j) - y * a(m,j)
C
          do 150 j = 1, igh
  150      a(j,m) = a(j,m) + y * a(j,i)
C
  160   continue
C
  180 continue
C
  200 return
C    :::::::::: last card of elmhes ::::::::::
      end


program main

   use, intrinsic :: iso_fortran_env
   use mpi_f08

   implicit none

   integer, parameter :: n=1000000
   integer(kind=int32) :: i
   integer(kind=int32) :: ierror ! To control errors in MPI calls
   integer(kind=int32) :: rank   ! Unique number received by each process
   integer(kind=int32) :: num_proc ! Total number of processes
   real(kind=real64)   :: wtime
   real(kind=real64), allocatable, dimension(:) :: array

   ! Initialize MPI. This must be the first MPI call
   call MPI_Init(ierror)

   ! Get the number of processes
   call MPI_Comm_size(MPI_COMM_WORLD, num_proc, ierror)

   ! Get the individual process rank
   call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierror)

   if (rank == 0) then
      wtime = MPI_Wtime()

      ! Only rank = 0 print this
      write (*, '(a)') ''
      write (*, '(a,i2,2x,a)') 'RANK:', rank, ' Master process reporting:'
      write (*, '(a,i2,2x,a,i3)') 'RANK:', rank, &
         ' The number of MPI processes is ', num_proc

   else

      ! Every MPI process will print this message.
      write (*, '(a,i2,2x,a,i8)') 'RANK:', rank, &
      ' Allocating array of size:', rank*n

      ! Each rank will allocate an array of a different size
      allocate (array(rank*n))
      do i = 1, size(array)
         array(i) = log(real(rank))+sqrt(real(i))
      end do

      ! Reporting sum of array
      write (*, '(a,i2,2x,a,e12.3)') 'RANK:', rank, ' Sum of array:', sum(array)
      deallocate(array)

   end if

   if (rank == 0) then
      write (*, '(a)') ''
      write (*, '(a,i2,2x,a)') 'RANK:', rank, ' Master process reporting:'
      write (*, '(a,i2,2x,a)') 'RANK:', rank, &
      ' Normal end of execution for master'

      wtime = MPI_Wtime() - wtime
      write (*, '(a)') ''
      write (*, '(a,i2,2x,a,g14.6,a)') &
         'RANK:', rank, ' Elapsed wall clock time = ', wtime, ' seconds.'
      write (*, '(a)') ''

   end if

   ! No more MPI calls after Finalize
   call MPI_Finalize(ierror)

   ! Ranks are intrinsic to each process and this conditional is legal
   if (rank == 0) then
      write (*, '(a)') ''
      write (*, '(a,i2,2x,a)') 'RANK:', rank, ' Master process reporting:'
      write (*, '(a,i2,2x,a)') 'RANK:', rank, ' Normal end of execution for all'
   end if

   stop

end program


      subroutine f_main
!  ********************************************************************
!  ********************************************************************
      use qdmodule
      use avh_olo
      implicit none
      integer :: nn
      character(4) :: next
      real(kind(1d0)) :: mu
!
!      call olo_onshell( 1d-6 )
!      call olo_unit( 6 ,'printall' )
!
      next = 'next'
      do while (next.eq.'next')
        read(5,*) nn ,mu
        call olo_scale( mu )
        if     (nn.eq.2) then
          call test_2
        elseif (nn.eq.3) then
          call test_3
        else!if(nn.eq.4) then
          call test_4
        endif
        read(5,*) next
      enddo
      end subroutine

      subroutine test_4
!  ********************************************************************
!  ********************************************************************
      use qdmodule
      use avh_olo
      implicit none
      complex(kind(1d0)) :: p1,p2,p3,p4,p12,p23,m1,m2,m3,m4,zdp(0:2)
      type(qd_complex) :: p1_qd,p2_qd,p3_qd,p4_qd,p12_qd,p23_qd
      type(qd_complex) :: m1_qd,m2_qd,m3_qd,m4_qd,zqd(0:2)
!
      read(5,*) p1
      read(5,*) p2
      read(5,*) p3
      read(5,*) p4
      read(5,*) p12
      read(5,*) p23
      read(5,*) m1
      read(5,*) m2
      read(5,*) m3
      read(5,*) m4
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'p2 : (',real(p2),',',aimag(p2),')'
      write(6,101) 'p3 : (',real(p3),',',aimag(p3),')'
      write(6,101) 'p4 : (',real(p4),',',aimag(p4),')'
      write(6,101) 'p12: (',real(p12),',',aimag(p12),')'
      write(6,101) 'p23: (',real(p23),',',aimag(p23),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
      write(6,101) 'm3 : (',real(m3),',',aimag(m3),')'
      write(6,101) 'm4 : (',real(m4),',',aimag(m4),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_qd =p1
      p2_qd =p2
      p3_qd =p3
      p4_qd =p4
      p12_qd=p12
      p23_qd=p23
      m1_qd =m1
      m2_qd =m2
      m3_qd =m3
      m4_qd =m4
      call olo( zdp ,p1,p2,p3,p4,p12,p23  ,m1,m2,m3,m4 )
      call olo( zqd ,p1_qd,p2_qd,p3_qd,p4_qd,p12_qd,p23_qd &
                    ,m1_qd,m2_qd,m3_qd,m4_qd )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call qdwrite(6,qdreal(zqd(0)))
      call qdwrite(6,aimag(zqd(0)))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call qdwrite(6,qdreal(zqd(1)))
      call qdwrite(6,aimag(zqd(1)))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call qdwrite(6,qdreal(zqd(2)))
      call qdwrite(6,aimag(zqd(2)))
      write(6,*)
!
      end subroutine

      subroutine test_3
!  ********************************************************************
!  ********************************************************************
      use qdmodule
      use avh_olo
      implicit none
      complex(kind(1d0)) :: p1,p2,p3,m1,m2,m3,zdp(0:2)
      type(qd_complex) :: p1_qd,p2_qd,p3_qd
      type(qd_complex) :: m1_qd,m2_qd,m3_qd,zqd(0:2)
!
      read(5,*) p1
      read(5,*) p2
      read(5,*) p3
      read(5,*) m1
      read(5,*) m2
      read(5,*) m3
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'p2 : (',real(p2),',',aimag(p2),')'
      write(6,101) 'p3 : (',real(p3),',',aimag(p3),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
      write(6,101) 'm3 : (',real(m3),',',aimag(m3),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_qd=p1
      p2_qd=p2
      p3_qd=p3
      m1_qd=m1
      m2_qd=m2
      m3_qd=m3
      call olo( zdp ,p1,p2,p3 ,m1,m2,m3 )
      call olo( zqd ,p1_qd,p2_qd,p3_qd ,m1_qd,m2_qd,m3_qd )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call qdwrite(6,qdreal(zqd(0)))
      call qdwrite(6,aimag(zqd(0)))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call qdwrite(6,qdreal(zqd(1)))
      call qdwrite(6,aimag(zqd(1)))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call qdwrite(6,qdreal(zqd(2)))
      call qdwrite(6,aimag(zqd(2)))
      write(6,*)
!
      end subroutine

      subroutine test_2
!  ********************************************************************
!  ********************************************************************
      use qdmodule
      use avh_olo
      implicit none
      complex(kind(1d0)) :: p1,m1,m2,zdp(0:2)
      type(qd_complex) :: m1_qd,m2_qd,p1_qd,zqd(0:2)
!
      read(5,*) p1
      read(5,*) m1
      read(5,*) m2
      write(6,101) 'p1 : (',real(p1),',',aimag(p1),')'
      write(6,101) 'm1 : (',real(m1),',',aimag(m1),')'
      write(6,101) 'm2 : (',real(m2),',',aimag(m2),')'
  101 format(a6,d31.24,a1,d31.24,a1)
!
      p1_qd = p1
      m1_qd = m1
      m2_qd = m2
      call olo( zdp ,p1 ,m1,m2 )
      call olo( zqd ,p1_qd ,m1_qd,m2_qd )
!
      write(6,'(a10)') ' eps^( 0):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(0)
      call qdwrite(6,qdreal(zqd(0)))
      call qdwrite(6,aimag(zqd(0)))
      write(6,'(a10)') ' eps^(-1):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(1)
      call qdwrite(6,qdreal(zqd(1)))
      call qdwrite(6,aimag(zqd(1)))
      write(6,'(a10)') ' eps^(-2):'
      write(6,'(a8,2d24.16)') '    olo:',zdp(2)
      call qdwrite(6,qdreal(zqd(2)))
      call qdwrite(6,aimag(zqd(2)))
      write(6,*)
!
      end subroutine


Subroutine fstate(iseed, srt, dm3, dm4, px, py, pz, iflag)
  Dimension px(4), py(4), pz(4), pe(4)
  Common /rndf77/nseed
  Save
  iflag = -1
  pio = 3.1415926
  aka = 0.498
  icount = 0
  ekmax = (srt-dm3-dm4)/2.
  If (ekmax<=aka) Return
  pkmax = sqrt(ekmax**2-aka**2)
  If (dm3<=0.0 .Or. dm4<=0.0) Then
    Write (1, *) 'error: minus mass!!!'
    Return
  End If
  50 Continue
  icount = icount + 1
  If (icount>10) Return
  ptkmi2 = -1./4.145*alog(ranart(nseed))
  ptkm = sqrt(ptkmi2)
  3 v1 = ranart(nseed)
  v2 = ranart(nseed)
  rsq = v1**2 + v2**2
  If (rsq>=1.0 .Or. rsq<=0.) Goto 3
  fac = sqrt(-2.*alog(rsq)/rsq)
  guass = v1*fac
  If (guass>=5.) Goto 3
  xstar = guass/5.
  pzkm = pkmax*xstar
  ekm = sqrt(aka**2+pzkm**2+ptkm**2)
  If (ranart(nseed)>aka/ekm) Goto 50
  bbb = ranart(nseed)
  px(3) = ptkm*cos(2.*pio*bbb)
  py(3) = ptkm*sin(2.*pio*bbb)
  If (ranart(nseed)>0.5) pzkm = -1.*pzkm
  pz(3) = pzkm
  pe(3) = ekm
  150 ptkpl2 = -1./3.68*alog(ranart(nseed))
  ptkp = sqrt(ptkpl2)
  13 v1 = ranart(nseed)
  v2 = ranart(nseed)
  rsq = v1**2 + v2**2
  If (rsq>=1.0 .Or. rsq<=0.) Goto 13
  fac = sqrt(-2.*alog(rsq)/rsq)
  guass = v1*fac
  If (guass>=3.25) Goto 13
  xstar = guass/3.25
  pzkp = pkmax*xstar
  ekp = sqrt(aka**2+pzkp**2+ptkp**2)
  If (ranart(nseed)>aka/ekp) Goto 150
  bbb = ranart(nseed)
  px(4) = ptkp*cos(2.*pio*bbb)
  py(4) = ptkp*sin(2.*pio*bbb)
  If (ranart(nseed)>0.5) pzkp = -1.*pzkp
  pz(4) = pzkp
  pe(4) = ekp
  resten = srt - pe(3) - pe(4)
  restpz = -pz(3) - pz(4)
  If (resten<=abs(restpz)) Goto 50
  restms = sqrt(resten**2-restpz**2)
  If (restms<(dm3+dm4)) Goto 50
  ptp2 = -1./2.76*alog(ranart(nseed))
  ptp = sqrt(ptp2)
  bbb = ranart(nseed)
  px(2) = ptp*cos(2.*pio*bbb)
  py(2) = ptp*sin(2.*pio*bbb)
  px(1) = -1.*(px(4)+px(3)+px(2))
  py(1) = -1.*(py(4)+py(3)+py(2))
  rmt3 = sqrt(dm3**2+px(1)**2+py(1)**2)
  rmt4 = sqrt(dm4**2+px(2)**2+py(2)**2)
  If (restms<(rmt3+rmt4)) Goto 50
  pzcms = sqrt((restms**2-(rmt3+rmt4)**2)*(restms**2-(rmt3-rmt4)**2))/2./restms
  If (ranart(nseed)>0.5) Then
    pz(1) = pzcms
    pz(2) = -pzcms
  Else
    pz(1) = -pzcms
    pz(2) = pzcms
  End If
  beta = restpz/resten
  gama = 1./sqrt(1.-beta**2)
  pz(1) = pz(1)*gama + beta*gama*sqrt(rmt3**2+pz(1)**2)
  pz(2) = pz(2)*gama + beta*gama*sqrt(rmt4**2+pz(2)**2)
  pe(1) = sqrt(rmt3**2+pz(1)**2)
  pe(2) = sqrt(rmt4**2+pz(2)**2)
  iflag = 1
  Return
End Subroutine fstate


C    @(#)sen_dhdx2.f	20.2 6/27/97
      subroutine sen_dhdx2 (kt, mt, y)
      complex y(2,2)
C
C     This subroutine computes the Jacobian elements dPij/dX
C     for branch KT-MT.
C
      include 'ipfinc/parametr.inc'

      include 'ipfinc/amtrx.inc'
      include 'ipfinc/blank.inc'
      include 'ipfinc/bus.inc'
      include 'ipfinc/ecvar.inc'

      real ikr, iki, imr, imi

      ek = e(kt)
      fk = f(kt)
      em = e(mt)
      fm = f(mt)
      ikr = 0.0
      iki = 0.0

      g12 = real (y(1,2))
      b12 = aimag (y(1,2))
      imr = em*g12-fm*b12
      imi = em*b12+fm*g12
      ikr = ikr+imr
      iki = iki+imi
      rh = imr*fk-imi*ek
      rn = imr*ek+imi*fk
      dpt(1,mt) = dpt(1,mt) - rh
      dpt(2,mt) = dpt(2,mt) - rn

      vksq = ek**2 + fk**2
      g12 = real (y(1,1)) * vksq
      b12 = aimag (y(1,1)) * vksq
      pk = ikr*ek+iki*fk+g12
      qk = ikr*fk-iki*ek-b12
      rh =  -qk - b12
      rn = pk + g12
      dpt(1,kt) = dpt(1,kt) - rh
      dpt(2,kt) = dpt(2,kt) - rn
      return
      end


! Solves for the new precursor solution vector
! with backward Euler time integration
! Input:
!
! Output:
!

subroutine solve_precursor_euler(isotope,delay_group,n, nl_iter )

    USE flags_M
    USE material_info_M
    USE mesh_info_M
    USE time_info_M
    USE global_parameters_M
    USE solution_vectors_M
    USE element_matrices_M
    use Mod_SetupOutputFiles

    implicit none

!---Dummy
    integer,intent(in) :: isotope
    integer,intent(in) :: delay_group
    integer,intent(in) :: nl_iter
    integer,intent(in) :: n

!---Local
    integer :: i,j,f,g
    real(dp), dimension(3) :: A_inv_times_RHS

!---
    A_inv_times_RHS(:) = 0.0

    A_inv_times_RHS = matmul(inverse_A_matrix,RHS_transient_final_vec)

!---Solve for new precursor at delta t
    if(td_method_type == 0) then
        do i = 1, nodes_per_elem
            precursor_soln_new(isotope,delay_group, n,i) = &
                precursor_soln_prev(isotope, delay_group, n,i) + &
                delta_t*( RHS_transient_final_vec(i) )
        end do
    end if

    if(td_method_type == 1) then
        do i = 1, nodes_per_elem
            precursor_soln_new(isotope,delay_group, n,i) = &
                precursor_soln_last_time(isotope, delay_group, n,i) + &
                delta_t*( A_inv_times_RHS(i))

            !residual(isotope,delay_group,n,i) = precursor_soln_new(isotope,delay_group,n,i) - &
            !                                 precursor_soln_last_time(isotope,delay_group,n,i) - &
            !                                 delta_t*(H_times_soln_vec(i) + &
            !                                 (allPrecursorData(isotope) % groupBeta(delay_group)/gen_time)*&
            !                                 elem_vec_A_times_q(i) + &
            !                                 A_times_W_times_upwind_elem_vec(i))

        end do
    end if

!---End precursor solve

!---Null transient unit test
    if( reactivity_input == 0.0) then
        !---Make sure change in the solution is zero for null transient
        do i = 1, nodes_per_elem
            if(A_inv_times_RHS(i) > 0.0) then
                !write(outfile_unit, fmt='(a)'), 'FAILING NULL TRANSIENT TEST'
            end if
        end do
    end if

!if(t0 > 4.0) then
!    DEBUG = .TRUE.
!end if
!*************************************
    if (DEBUG .eqv. .TRUE.) then
    !---Write out solution for current element

        write(outfile_unit,fmt='(a,1I6,a,1I6)'),'Previous Solution | element --> ',&
        n, ' Group -->',delay_group
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(a,1I6,f16.3)'), 'Node -->', &
              conn_matrix(n,j), precursor_soln_prev(isotope, delay_group,n,j)
        end do
        write(outfile_unit,fmt='(a)'), ' '
        write(outfile_unit,fmt='(a,1I6,a,1I6)'),'New Solution | element --> ', &
                                                 n, ' Group -->',delay_group
        do j=1,nodes_per_elem
              write(outfile_unit,fmt='(a,1I6,f16.3)'), 'Node -->', &
              conn_matrix(n,j), precursor_soln_new(isotope, delay_group,n,j)
        end do
        write(outfile_unit,fmt='(a)'), '********************************'
    end if

DEBUG = .FALSE.

end subroutine solve_precursor_euler


!*******************************************************************
		SUBROUTINE SCHMIDT (uwor,uwor2,lk,Z_min,yeari)
!*******************************************************************
!
!        Schmidt Work
!       ---------------
!
!		This routine calculates the Schmidt Work for the current day
!		and sends the output to a file:'Ldddhhmm.NUM'
!		i.e. has the same name as the simulation file
!
!     NOTES:  nlayers = number of layers of INTERP DATA(STEP = 0.1)
!             all arrays begin with subscrip zero
!             all arrays of data interp to 0.1m have subscript of zero
!             referring to depth of 0.1m (Top of first layer)
!
! Modified for Lake Tahoe
! Written by Joaquim P. Losada and Geoff Schladow
! UC-Davis, January 2001
!*******************************************************************
      USE DLMWQ_VARIABLES
      USE DLMWQ_SERVICES
		IMPLICIT NONE
      SAVE
		INTEGER(4)     :: uwor,uwor2,nlayers
		INTEGER(4)     :: i,j,ii,ik,jj,ijk,lk,njday
		LOGICAL*4 NOPROBLEMS

		REAL(8)	:: thermdepth
		REAL(8)	:: xp,zc,xmass,VolSum,Mass,den4
		REAL(8)  :: IsoDen,DepthSum
		REAL(8)	:: Heat, Contingut
		REAL(8)	:: WS,WS_min,WT,WT_min
!IF		REAL(8)  :: densty
		REAL(8)	:: Mix_depth_F,Mix_depth_C
		REAL(8)  :: AreaT, z_star, T_average,T_ave_vol,sum_vol
		REAL(8)  :: T_ave_vol_LT100, sum_vol_LT100, T_ave_vol_GT100,sum_vol_GT100
		REAL(8)  :: heat_con(maxns),depth_con(maxns),depthcon
		INTEGER(4) :: year, yeari
		REAL(8) :: Z_min
		REAL(8), PARAMETER	:: Amax		= 465969.4*1000.0d0
		REAL(8), PARAMETER	:: Cp		= 4186.0d0
		REAL(8), PARAMETER	:: grav		= 9.81d0
!
!quim Interpolate density and temperature each 0.1m
!

		CALL INTERPOLATE_LAYER_DATA(nlayers,idepth,density,tempy,salty)

		IF (nlayers.lt.1) THEN
			noproblems = .false.
			GOTO 4406
		ENDIF
!
!quim  Mixing Depth detection
!
		xmom = CALC_XMOM(nlayers)

		IF (xmom .lt. 0.0d0) THEN
			xmom       = 0.10
			thermdepth = 0.10
			GOTO 8182
		ELSE
			thermdepth = xmom
		ENDIF

8182	CONTINUE

		ii = nlayers-1
		DO WHILE((tempy(nlayers-1)-tempy(ii-1)).le. 0.0000001)
			ii = ii - 1
			IF(ii.eq.0) GOTO 4421
		ENDDO

4421	CONTINUE
		Mix_depth_F = idepth(ii)

		ii = nlayers-1
		DO WHILE((tempy(nlayers-1)-tempy(ii-1)).le. 0.01)
			ii = ii - 1
			IF(ii.eq.0) GOTO 4422
		ENDDO

4422	CONTINUE
		Mix_depth_C = idepth(ii)
!
!quim Schmidt Work
!
		VolSum  = 0.0d0
		Mass    = 0.0d0
		WS		= 0.0d0

		AreaT   = area(1)*1D6
		VolSum  = VolSum + vol(1)*1D3
		DepthSum	= DepthSum + vol(1)*(depth(ns) - depth(1))*1D3
		Mass    = Mass   + vol(1)*(den(1)+1000.0d0)*1D3

		DO ii =2,ns
			AreaT   = area(ii)*1D6
			VolSum  = VolSum   + vol(ii)*1D3
			DepthSum= DepthSum + vol(ii)*(depth(ns) - depth(ii))*1D3
			Mass    = Mass     + vol(ii)*(den(ii)+1000.0d0)*1D3
		ENDDO

		DepthSum = dble(DepthSum/VolSum)
		IsoDen   = dble(Mass/VolSum)

		ii = 0
		DO WHILE (density(ii)-(IsoDen-1000.0d0).gt.0.0d0)
			IF(ii.eq.nlayers-1) THEN
				WS = 0.0
				GOTO 4406
			ENDIF
			ii = ii + 1
		ENDDO
		z_star = idepth(nlayers-1) - idepth(ii)

		ii = nlayers-1
		DO WHILE (density(ii)-(IsoDen-1000.0d0).lt.0.0d0)
			IF(ii.eq.0) THEN
				WS = 0.0
				GOTO 4406
			ENDIF
			ii = ii - 1
		ENDDO

		z_star = (z_star + (idepth(nlayers-1) - idepth(ii)))/2.0

		WS  =  vol(1)*1d3*(den(1)+1000.0d0 - IsoDen)*(depth(ns)-depth(1)-z_star)

		DO ii = 2,ns
			AreaT = area(ii)*1D6
     		WS   = WS + vol(ii)*1D3*(den(ii)+1000.0d0 - IsoDen)*(depth(ns)-depth(ii)-z_star)
			IF (WS.lt.0.0d0) WS = 0.0d0
		ENDDO

! 04 June 2004 Error area(ii)!!
		WS		= grav*WS/(area(ns)*1D6)

4406  CONTINUE
!
!	Total Work
!
		den4	= 1000.0d0 + densty(4.0d0,100.0d0)
		WT		= (grav*DepthSum*(den4-IsoDen)*(VolSum/(area(ns)*1d6)))

!	WT		= (grav*DepthSum*(den4-IsoDen)*VolSum*
!     &		  (Z_red/DepthMax)**2.0d0)

4207  CONTINUE
!
!	Heat Contens
!
		heat		= 0.0d0
		contingut	= 0.0d0

		DO ii = 1,ns
			AreaT     = area(ii)*1D3
			contingut = contingut + Cp*(den(ii)+1000.0d0)*vol(ii)*1d3*temp(ii)	!(Joules)
		ENDDO

		heat		= contingut
																	  !(Joules)
		contingut   = Cp*(den(1)+1000.0d0)*vol(1)*1d3*temp(1)	 !(Joules)
		depthcon    = depth(1)
		depth_con   = 0.0d0

		DO ii = 2,ns
			AreaT         = area(ii)*1D3
			contingut     = contingut + Cp*(den(ii)+1000.0d0)*vol(ii)*1d3*temp(ii)	!(Joules)
			heat_con(ii)  = contingut/heat
			depthcon      = depthcon  + depth(ii) - depth(ii-1)
			depth_con(ii) = depthcon /depth(ns)
		ENDDO
!
!gbs  Temperautre volume averaged
!d
		T_ave_vol = 0.0d0
		sum_vol   = 0.0d0
		T_ave_vol_LT100 = 0.0d0
		sum_vol_LT100   = 0.0d0
		T_ave_vol_GT100 = 0.0d0
		sum_vol_GT100   = 0.0d0

		DO ii = 2,ns
			T_ave_vol = T_ave_vol+temp(ii)*vol(ii)
			sum_vol = sum_vol+vol(ii)
!	PRINT*,'GOLOKA WORK', DEPTH(NS)
!	PAUSE

			IF(DEPTH(II).GE.(DEPTH(NS)-100.0D0)) THEN	!EPILIMNION
				T_ave_vol_LT100 = T_ave_vol_LT100+temp(ii)*vol(ii)
				sum_vol_LT100 = sum_vol_LT100+vol(ii)
			ELSE
				T_ave_vol_GT100 = T_ave_vol_GT100+temp(ii)*vol(ii)	!HYPOLIMNION
				sum_vol_GT100 = sum_vol_GT100+vol(ii)
			ENDIF
		ENDDO
		T_ave_vol=T_ave_vol/sum_vol
		T_ave_vol_LT100=T_ave_vol_LT100/sum_vol_LT100
		T_ave_vol_GT100=T_ave_vol_GT100/sum_vol_GT100

!
!    Temperature Depth Averaged
!
		T_average	= 0.0d0					! Temp (oC)

		DO ii = 0,nlayers-2	   !Gbs changed "nlayers-1" to "nlayers-2"
			T_average	= T_average	+ tempy(ii)*(idepth(ii+1)-idepth(ii))
	!		print*,(idepth(ii+1)-idepth(ii))
		ENDDO
		T_average	= T_average/idepth(nlayers-1)	!Gbs changed "ns" to "nlayers-1"

		WRITE(uwor,4407) jday,depth(ns)-depmx,T_average,T_ave_vol,WS,WT,	&
								T_ave_vol_LT100,	T_ave_vol_GT100

!
!		Maximum Mixing Depth
!
		year = int(jday/1000.0)
		IF(year.eq.yeari) THEN
			Z_min = min(Z_min,depmx)
			IF(Z_min.eq.depmx) THEN
				WS_min = WS
				WT_min = WT
			ENDIF
		ELSE
			WRITE(uwor2,4409) yeari,DepthMax-Z_min,WS_min,WT_min
			Z_min = 10000.0
			yeari = year
		ENDIF

4407	FORMAT(I8,f10.2,2(3x,f7.2),2(x,f12.1,x),2(8x,f7.2))
4408	FORMAT(I10,f8.1,f8.1)
4409	FORMAT(I10,f10.2,2f15.1)

		RETURN
		END SUBROUTINE SCHMIDT


MODULE gsw_pot_to_insitu
!===============================================================================
!
! MODULE:
!  gsw_pot_to_insitu
!
! PURPOSE:
!  This module provides additional subroutines needed to compute the in situ
!  temperature from a numerical model's potential temperature (ºC) and practical
!  salinity (psu). It utilizes the TEOS GSW Fortran package, version 3.03,
!  available at http://www.teos-10.org
!
!
!-------------------------------------------------------------------------------
! Author:  Steve Penny
! Institution: University of Maryland, College Park; NWS/NOAA/NCEP
! Contact: Steve.Penny@noaa.gov
!===============================================================================

IMPLICIT NONE

PUBLIC :: t_from_pt, p_from_z    ! Computing in situ from potential temperature
PUBLIC :: sa_from_sp, pt_from_t  ! Computing potential temperature from in situ

PRIVATE

INTEGER, PARAMETER :: r14 = selected_real_kind(14,30)

CONTAINS

!===============================================================================
FUNCTION t_from_pt(pt_in,sp_in,p_in,lon_in,lat_in)
!===============================================================================
  USE common, ONLY: r_size
! USE gsw_oceanographic_toolbox, ONLY: gsw_sa_from_sp, gsw_ct_from_pt, gsw_t_from_ct !, r14
  !STEVE: The toolbox is not coded as a module, so this will not work.
  !       I'll leave it unaltered as a list of functions in order to facilitate forward compatibility.

  IMPLICIT NONE
  REAL(r14) :: gsw_sa_from_sp, gsw_ct_from_pt, gsw_t_from_ct
  REAL(r_size) :: t_from_pt
  REAL(r_size), INTENT(IN) :: pt_in, sp_in, p_in, lon_in, lat_in
  REAL(r14) :: pt, sp, p, lon, lat
  REAL(r14) :: sa, ct, T

  pt = pt_in
  sp = sp_in
  p  = p_in
  lon = lon_in
  lat = lat_in

! Compute in situ temperature from potential temperature by computing
! the conservative temperature from potential temperature then computing
! the in situ temperature from the conservative temperature.
! sa     : Absolute Salinity                   [g/kg]
! sp     : Practical Salinity                  [unitless]
! ct     : Conservative Temperature            [deg C]
! pt     : potential temperature with          [deg C]
!           reference pressure of 0 dbar
! c      : conductivity                        [mS/cm]
! t      : in-situ temperature [ITS-90]        [deg C]
! p      : sea pressure                        [dbar]
! z      : depth                               [m]

  ! Compute the absolute salinity from the practical salinity
  sa = gsw_sa_from_sp(sp,p,lon,lat)

  ! Compute the conservative temperature
  ct = gsw_ct_from_pt(sa,pt)

  ! Compute the in situ temperature
  t_from_pt  = gsw_t_from_ct(sa,ct,p)

END FUNCTION t_from_pt

!===============================================================================
PURE FUNCTION p_from_z(dpth,xlat)
!===============================================================================
! pressure from depth from saunder's formula with eos80.
! reference: saunders,peter m., practical conversion of pressure
!            to depth., j.p.o. , april 1981.
! r millard
! march 9, 1983
! check value: p_from_z=7500.004 dbars;for lat=30 deg., depth=7321.45 meters
! http://sam.ucsd.edu/sio210/propseawater/ppsw_fortran/ppsw.f
  IMPLICIT NONE
  REAL(r14) :: p_from_z
  REAL(r14), INTENT(IN) :: dpth
  REAL(r14), INTENT(IN) :: xlat
  REAL(r14), PARAMETER :: pi=3.141592654
  REAL(r14) :: plat, d, c1

  plat=abs(xlat*pi/180.)
  d=sin(plat)
  c1=5.92e-3+d**2*5.25e-3
  p_from_z=((1-c1)-sqrt(((1-c1)**2)-(8.84e-6*dpth)))/4.42e-6

END FUNCTION p_from_z

!===============================================================================
FUNCTION sa_from_sp(sp,p,long,lat)
!===============================================================================

! Calculates Absolute Salinity, SA, from Practical Salinity, SP
!
! sp     : Practical Salinity                              [unitless]
! p      : sea pressure                                    [dbar]
! long   : longitude                                       [DEG E]
! lat    : latitude                                        [DEG N]
!
! gsw_sa_from_sp   : Absolute Salinity                     [g/kg]

IMPLICIT NONE
REAL (r14) :: sa_from_sp
REAL (r14), INTENT(IN) :: sp, long, lat, p
REAL (r14) :: gsw_sa_from_sp

sa_from_sp = gsw_sa_from_sp(sp,p,long,lat)

END FUNCTION sa_from_sp

!===============================================================================
FUNCTION pt_from_t(sa,t,p,p_ref)
!===============================================================================

! Calculates potential temperature of seawater from in-situ temperature
!
! sa     : Absolute Salinity                               [g/kg]
! t      : in-situ temperature                             [deg C]
! p      : sea pressure                                    [dbar]
! p_ref  : reference sea pressure                          [dbar]
!
! gsw_pt_from_t : potential temperature                    [deg C]

IMPLICIT NONE
REAL (r14) :: pt_from_t
REAL (r14), INTENT(IN) :: sa, t, p, p_ref
REAL (r14) :: gsw_pt_from_t

pt_from_t = gsw_pt_from_t(sa,t,p,p_ref)

END FUNCTION pt_from_t

END MODULE gsw_pot_to_insitu


!==========================================================================
module gsw_mod_gibbs_ice_coefficients
!==========================================================================

use gsw_mod_kinds

implicit none

complex(r8), parameter :: t1 =( 3.68017112855051e-2_r8, 5.10878114959572e-2_r8)
complex(r8), parameter :: t2 =( 3.37315741065416e-1_r8, 3.35449415919309e-1_r8)

complex(r8), parameter :: r1 =( 4.47050716285388e1_r8,  6.56876847463481e1_r8)
complex(r8), parameter :: r20=(-7.25974574329220e1_r8, -7.81008427112870e1_r8)
complex(r8), parameter :: r21=(-5.57107698030123e-5_r8, 4.64578634580806e-5_r8)
complex(r8), parameter :: r22=(2.34801409215913e-11_r8,-2.85651142904972e-11_r8)

! 1./Pt, where Pt = 611.657;  Experimental triple-point pressure in Pa.
real (r8), parameter :: rec_pt = 1.634903221903779e-3_r8
real (r8), parameter :: tt = 273.16_r8 ! Triple-point temperature, kelvin (K).
real (r8), parameter :: rec_tt = 3.660858105139845e-3_r8   ! = 1/tt

real (r8), parameter :: g00 = -6.32020233335886e5_r8
real (r8), parameter :: g01 =  6.55022213658955e-1_r8
real (r8), parameter :: g02 = -1.89369929326131e-8_r8
real (r8), parameter :: g03 =  3.3974612327105304e-15_r8
real (r8), parameter :: g04 = -5.564648690589909e-22_r8

end module

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


      SUBROUTINE cauchy(rbdy, zbdy, rubdy, zubdy, rlim, zlim, residue,
     1   sep, distmax, ntheta, nlim)
      USE vparams, ONLY: twopi, dp, rprec
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER, INTENT(in) :: ntheta, nlim
      REAL(rprec), INTENT(in) :: distmax
      REAL(rprec), DIMENSION(ntheta), INTENT(in) ::
     1     rbdy, zbdy, rubdy, zubdy
      REAL(rprec), DIMENSION(nlim) :: rlim, zlim, residue, sep
C-----------------------------------------------
C   L o c a l   P a r a m e t e r s
C-----------------------------------------------
      REAL(rprec), PARAMETER :: zero=0, p5=0.5_dp, two=2
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: n, i, imin, imax
      REAL(rprec), DIMENSION(ntheta) :: dsq, dsepdu
      REAL(rprec), DIMENSION(ntheta) :: x1u, y1u
      REAL(rprec) :: delu, dmin, delta_d, alpha, gam0
C-----------------------------------------------
c       Check that the points (rlim(i),zlim(i)) are inside boundary surface
c       using Cauchys theorem in "complex"-plane (for a fixed
c       toroidal plane, nphi=const. It is assumed that rbdy, zbdy are
c       extended around the full interval, 0-2pi, in theta.
c       with rbdy(1) = rbdy(ntheta+1) (i.e., ntheta intervals)
c
c       Because of numerical inaccuracies, instead of testing on
c       res = 0 (outside), res = 1 (inside), we USE the test:
c       res >= .5, inside;  res < .5, outside
c**********************************************************************
c
c       LOCAL VARIABLE ARRAYS
c
c       dsq:    Distance squared between limiter poINT and plasma boundary
c       sep:    Minimum dsq for each limiter point
c    dsepdu:    .5* d(dsq)/d(theta)
c   residue:    Contour integral of 1/(X-rlim)in complex X=(R,Z) plane
c
      delu = twopi/ntheta
      dMIN = 1.E-20_DP*distmax

      DO n = 1, nlim
         residue(n) = zero
         x1u = rbdy(:ntheta) - rlim(n)
         y1u = zbdy(:ntheta) - zlim(n)
         dsq(:ntheta) = x1u*x1u + y1u*y1u
         dsepdu(:ntheta) = x1u*rubdy(:ntheta) + y1u*zubdy(:ntheta)
         residue(n) = residue(n) + SUM((x1u*zubdy(:ntheta) -
     1      y1u*rubdy(:ntheta))/(dsq(:ntheta)+dmin))

         residue(n) = residue(n)/ntheta
!
!        Find actual minimum distance from nth limiter point to boundary
!
         sep(n) = distmax
         DO i = 1,ntheta
            IF( dsq(i).le.sep(n) )then
               imin = i
               sep(n) = dsq(i)
            ENDIF
         ENDDO

!        gamu = two*ABS(dsepdu(imin))*delu

         IF (dsepdu(imin) .le. zero) THEN
            imax = 1 + MOD(imin,ntheta)
         ELSE
            imax = imin
            imin = imax - 1
            IF (imin .eq. 0) imin = ntheta
         ENDIF

         delta_d = two*(dsepdu(imax)-dsepdu(imin))
         alpha = delta_d/delu
!        gamu = gamu/delta_d
!        sep(n) = sep(n) - p5*alpha*gamu**2
         IF (alpha .ne. zero)
     1      gam0 = 0.5_dp - (dsq(imax)-dsq(imin))/(alpha*delu**2)
         sep(n) = dsq(imin) - p5*alpha*(gam0*delu)**2
         IF (sep(n) .lt. zero) sep(n) = zero

      END DO

      END SUBROUTINE cauchy


      subroutine tmap(x1,x2,idir)
      use temw, only: rn=>r, ri
      implicit none
      real*8 x1(6),x2(6)
      integer*4 idir

      real*8 x(6)

      if(idir .ge. 0)then
         x(1) = ri(1,1)*x1(1) + ri(1,2)*x1(2) + ri(1,3)*x1(3)
     $        + ri(1,4)*x1(4) + ri(1,5)*x1(5) + ri(1,6)*x1(6)
         x(2) = ri(2,1)*x1(1) + ri(2,2)*x1(2) + ri(2,3)*x1(3)
     $        + ri(2,4)*x1(4) + ri(2,5)*x1(5) + ri(2,6)*x1(6)
         x(3) = ri(3,1)*x1(1) + ri(3,2)*x1(2) + ri(3,3)*x1(3)
     $        + ri(3,4)*x1(4) + ri(3,5)*x1(5) + ri(3,6)*x1(6)
         x(4) = ri(4,1)*x1(1) + ri(4,2)*x1(2) + ri(4,3)*x1(3)
     $        + ri(4,4)*x1(4) + ri(4,5)*x1(5) + ri(4,6)*x1(6)
         x(5) = ri(5,1)*x1(1) + ri(5,2)*x1(2) + ri(5,3)*x1(3)
     $        + ri(5,4)*x1(4) + ri(5,5)*x1(5) + ri(5,6)*x1(6)
         x(6) = ri(6,1)*x1(1) + ri(6,2)*x1(2) + ri(6,3)*x1(3)
     $        + ri(6,4)*x1(4) + ri(6,5)*x1(5) + ri(6,6)*x1(6)
      else
         x(1) = rn(1,1)*x1(1) + rn(1,2)*x1(2) + rn(1,3)*x1(3)
     $        + rn(1,4)*x1(4) + rn(1,5)*x1(5) + rn(1,6)*x1(6)
         x(2) = rn(2,1)*x1(1) + rn(2,2)*x1(2) + rn(2,3)*x1(3)
     $        + rn(2,4)*x1(4) + rn(2,5)*x1(5) + rn(2,6)*x1(6)
         x(3) = rn(3,1)*x1(1) + rn(3,2)*x1(2) + rn(3,3)*x1(3)
     $        + rn(3,4)*x1(4) + rn(3,5)*x1(5) + rn(3,6)*x1(6)
         x(4) = rn(4,1)*x1(1) + rn(4,2)*x1(2) + rn(4,3)*x1(3)
     $        + rn(4,4)*x1(4) + rn(4,5)*x1(5) + rn(4,6)*x1(6)
         x(5) = rn(5,1)*x1(1) + rn(5,2)*x1(2) + rn(5,3)*x1(3)
     $        + rn(5,4)*x1(4) + rn(5,5)*x1(5) + rn(5,6)*x1(6)
         x(6) = rn(6,1)*x1(1) + rn(6,2)*x1(2) + rn(6,3)*x1(3)
     $        + rn(6,4)*x1(4) + rn(6,5)*x1(5) + rn(6,6)*x1(6)
      endif

      x2(1)=x(1)
      x2(2)=x(2)
      x2(3)=x(3)
      x2(4)=x(4)
      x2(5)=x(5)
      x2(6)=x(6)
      return
      end