CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C----M  A  T  R  I  X   U  T  I  L  I  T  I  E  S   B  L  O  C  K------C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR(A,IN,IM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM)
C
      DO I=1,IN
        DO J=1,IM
          A(I,J)=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARV                                                  C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARV (A,N)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(N)
C
      DO I=1,N
        A(I)=ZERO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE MMULT                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MMULT(A,NRA,NCA,B,NRB,NCB,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NRA,NCA),B(NRB,NCB),C(NRA,NCB)
C
      CALL CLEAR(C,NRA,NCB)
      DUM=0.0D0
      DO I=1,NRA
        DO J=1,NCB
          DO K=1,NCA
            DUM=DUM+A(I,K)*B(K,J)
          END DO
          C(I,J)=DUM
          DUM=0.0D0
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE MTRAN                                                   C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE MTRAN(A,NRA,NCA,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NRA,NCA),B(NCA,NRA)
C
      CALL CLEAR(B,NCA,NRA)
      DO I=1,NRA
        DO J=1,NCA
          B(J,I)=A(I,J)
        END DO
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE NORMVCT                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE NORMVCT(X1,X2,Y1,Y2,CT,ST)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DX=X2-X1
      DY=Y2-Y1
      VMAG=DSQRT(DX*DX+DY*DY)
      CT=DX/VMAG
      ST=DY/VMAG
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARIV                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARIV(IA,N)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION IA(N)
C
      DO I=1,N
        IA(I)=0
      END DO
C
      RETURN
C
      END
C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEARIM                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEARIM(IA,N,M)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION IA(N,M)
C
      DO I=1,N
        DO J=1,M
          IA(I,J)=0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE MAVEC(A,NRA,NCA,B,C)                                C
C      Real matrix times vector                                        C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE MAVEC(A,NRA,NCA,B,C)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
      DIMENSION A(NRA,NCA),B(NCA),C(NRA)
C
      CALL CLEARV(C,NRA)
C
      DO K1=1,NRA
        DO K2=1,NCA
          C(K1)=C(K1)+A(K1,K2)*B(K2)
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SMULT(A,NR,NC,S)                                     C
C      Matrix times a real scalar                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE SMULT(A,NR,NC,S)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=S*DUM
          DUM=0.D0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SMULTI(A,NR,NC,S)                                    C
C      Matrix times an integer                                         C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE SMULTI(A,NR,NC,JJ)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION A(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=JJ*DUM
          DUM=0.D0
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE UPDMAT(A,NR,NC,B)                                    C
C      Updates an existing matrix with an incremental matrix.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE UPDMAT(A,NR,NC,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NR,NC),B(NR,NC)
C
      DO I=1,NR
        DO J=1,NC
          DUM=A(I,J)
          A(I,J)=ZERO
          A(I,J)=DUM+B(I,J)
          DUM=ZERO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR3D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR3D(A,IN,IM,IL)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM,IL)
C
      DO I=1,IN
        DO J=1,IM
          DO K=1,IL
            A(I,J,K)=ZERO
          END DO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE CLEAR4D                                                 C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE CLEAR4D(A,IN,IM,IL,IK)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION A(IN,IM,IL,IK)
C
      DO N=1,IN
        DO M=1,IM
          DO L=1,IL
            DO K=1,IK
              A(N,M,L,K)=ZERO
            END DO
          END DO
        END DO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE UPDVEC(A,NR,B)                                       C
C      Updates an existing vector with an incremental vector.          C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE UPDVEC(A,NR,B)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NR),B(NR)
C
      DO I=1,NR
        DUM=A(I)
        A(I)=ZERO
        A(I)=DUM+B(I)
        DUM=ZERO
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE KVECSUB(A,NRA,B,NRB,C)                               C
C      Substracts one column vector from another column vector         C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE VECSUB(A,NRA,B,NRB,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,1),B(NRB,1),C(NRB,1)
C
      CALL CLEAR(C,NRB,1)
C
      SCALAR=ONENEG
C
      IF (IFLAG.EQ.1) SCALAR=ONE
C
      DO I=1,NRA
        C(I,1)=A(I,1)+B(I,1)*SCALAR
      END DO
C
      RETURN
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE SQRNORM(A,NRA,E)                                     C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE SQRNORM(A,NRA,E)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ZERO=0.D0)
C
      DIMENSION A(NRA)
C
      SQS=ZERO
      DO K1=1,NRA
        SQS=SQS+A(K1)**2
      END DO
C
      E=DSQRT(SQS)
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE VECHAN3D4D                                            C
C     IFLAG=0 =  3D-->4D                                               C
C     IFLAG=1 =  4D-->3D                                               C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE VECHAN3D4D(RV4D,ID1,ID2,ID3,ID4,ICOL,RV3D,JD1,JD2,JD3,
     1IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION RV4D(ID1,ID2,ID3,ID4),RV3D(JD1,JD2,JD3)
C
      IF(IFLAG.EQ.0) THEN
         DO K1=1,ID1
           DO K2=1,ID2
             DO K3=1,ID3
               RV4D(K1,K2,K3,ICOL)=RV3D(K1,K2,K3)
             END DO
           END DO
         END DO
      ELSE
         DO K1=1,ID1
           DO K2=1,ID2
             DO K3=1,ID3
               RV3D(K1,K2,K3)=RV4D(K1,K2,K3,ICOL)
             END DO
           END DO
         END DO
      END IF
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE VECHAN2D3D                                            C
C     IFLAG=0 =  2D-->3D                                               C
C     IFLAG=1 =  3D-->2D                                               C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE VECHAN2D3D(RV3D,ID1,ID2,ID3,ICOL,RV2D,JD1,JD2,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION RV3D(ID1,ID2,ID3),RV2D(JD1,JD2)
C
      IF(IFLAG.EQ.0) THEN
         DO K1=1,ID1
           DO K2=1,ID2
             RV3D(K1,K2,ICOL)=RV2D(K1,K2)
           END DO
         END DO
      ELSE
         DO K1=1,ID1
           DO K2=1,ID2
             RV2D(K1,K2)=RV3D(K1,K2,ICOL)
           END DO
         END DO
      END IF
C
      RETURN
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C SUBROUTINE KPBLOCK                                                   C
C                                                                      C
C PASSES A BLOCK OF A SOURCE MATRIX (SMAT) INTO A TARGET MATRIX (TMAT) C
C STARTING AT ROW ISR AND COLUMN ISC AND ENDING AT ROW IFSR AND COLUMN C
C IFSC                                                                 C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE PBLOCK(TMAT,NRT,NCT,SMAT,NRS,NCS,ISR,ISC,IFSR,IFSC)
C
      IMPLICIT REAL*8 (A-H,O-Z)
C
      DIMENSION TMAT(NRT,NCT),SMAT(NRS,NCS)
C
      CALL CLEAR(TMAT,NRT,NCT)
C
      IF((IFSR-ISR+1).NE.NRT.OR.(IFSC-ISC+1).NE.NCT) THEN
         WRITE (*,*) '****ERROR NO MATCHING PASING BLOCKS****'
         GOTO 10
      END IF
C
      II=ISR
      JJ=ISC
      DO K1=1,NRT
        DO K2=1,NCT
          TMAT(K1,K2)=SMAT(II,JJ)
          JJ=JJ+1
        END DO
        II=II+1
        JJ=ISC
      END DO
C
   10 CONTINUE
C
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C      SUBROUTINE MATSUB(A,NRA,NCA,B,C,IFLAG)                          C
C      Substracts one rectangular matrix from another rectangular      C
C      matrix                                                          C
C      IFLAG=0 for substraction                                        C
C      IFLAG=1 for addition                                            C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
      SUBROUTINE MATSUB(A,NRA,NCA,B,C,IFLAG)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ONE=1.0D0, ONENEG=-1.0D0)
C
      DIMENSION A(NRA,NCA),B(NRA,NCA),C(NRA,NCA)
C
      CALL CLEAR(C,NRA,NCA)
C
      IF (IFLAG.EQ.1) SCALAR=ONE
      IF (IFLAG.EQ.0) SCALAR=ONENEG
C
      DO I=1,NRA
        DO J=1,NCA
          C(I,J)=A(I,J)+B(I,J)*SCALAR
        END DO
      END DO
C
      RETURN
C
      END
C
C11111111122222222223333333333444444444455555555556666666666777777777777
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE IDENTITY                                              C
C     CREATES AN IDENTITY MATRIX OF DIMENSIONS NDIM,NDIM               C
C                                                                      C
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE IDENTITY(DEL,NDIM)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(ONE=1.D0)
C
      DIMENSION DEL(NDIM,NDIM)
C
      CALL CLEAR(DEL,NDIM,NDIM)
C
      DO K1=1,NDIM
        DEL(K1,K1)=ONE
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE INVERSE                                                 C
C                                                                      C
C   IVEERSE OF A MATRIX USING LU DECOMPOSITION                         C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C   A   Matrix to be inverted.                                         C
C   Y   Inverse of A                                                   C
C   N   Dimension                                                      C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE INVERSE(A,Y,NP,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0,ONE=1.D0)
C
      DIMENSION A(NP,NP),Y(NP,NP),INDX(NP),AUX(NP,NP)
C
      CALL CLEAR(AUX,NP,NP)
      CALL COPYMAT(A,AUX,N)
C
      DO I=1,N
        DO J=1,N
          Y(I,J)=ZERO
        END DO
        Y(I,I)=ONE
      END DO
      CALL LUDCMP(AUX,N,NP,INDX,D)
      DO J=1,N
        CALL LUBKSB(AUX,N,NP,INDX,Y(1,J))
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LUDCMP                                                  C
C                                                                      C
C   LU MATRIX DECOMPOSITION                                            C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE LUDCMP(A,N,NP,INDX,D)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER(NMAX=500,TINY=1.0E-20,ZERO=0.D0,ONE=1.D0)
C
      DIMENSION INDX(N),A(NP,NP),VV(NMAX)
C
      D=ONE
      DO I=1,N
        AAMAX=ZERO
        DO J=1,N
          IF(ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
        END DO
cc        IF(AAMAX.EQ.0.) PAUSE 'SINGULAR MATRIX IN LUDCMP'
        VV(I)=ONE/AAMAX
      END DO
C
      DO J=1,N
        DO I=1,J-1
          SUM=A(I,J)
          DO K=1,I-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
        END DO
        AAMAX=ZERO
        DO I=J,N
          SUM=A(I,J)
          DO K=1,J-1
            SUM=SUM-A(I,K)*A(K,J)
          END DO
          A(I,J)=SUM
          DUM=VV(I)*ABS(SUM)
          IF(DUM.GE.AAMAX) THEN
             IMAX=I
             AAMAX=DUM
          END IF
        END DO
        IF(J.NE.IMAX) THEN
           DO K=1,N
             DUM=A(IMAX,K)
             A(IMAX,K)=A(J,K)
             A(J,K)=DUM
           END DO
           D=-D
           VV(IMAX)=-VV(J)
        END IF
        INDX(J)=IMAX
        IF(A(J,J).EQ.0.) A(J,J)=TINY
        IF(J.NE.N) THEN
           DUM=ONE/A(J,J)
           DO I=J+1,N
             A(I,J)=A(I,J)*DUM
           END DO
        END IF
      END DO
C
      RETURN
C
      END
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C                                                                      C
C   SUBROUTINE LUBKSB                                                  C
C                                                                      C
C   FORWARD SUBSTITUTION                                               C
C   TAKEN FROM NUMERICAL RECIPES By Press et al                        C
C                                                                      C
C                                                                      C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C
      SUBROUTINE LUBKSB(A,N,NP,INDX,B)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      PARAMETER (ZERO=0.D0)
C
      DIMENSION INDX(N),A(NP,NP),B(NP)
C
      II=0
      DO I=1,N
        LL=INDX(I)
        SUM=B(LL)
        B(LL)=B(I)
        IF(II.NE.0) THEN
           DO J=II,I-1
             SUM=SUM-A(I,J)*B(J)
           END DO
        ELSE IF(SUM.NE.ZERO) THEN
           II=I
        END IF
        B(I)=SUM
      END DO
C
      DO I=N,1,-1
        SUM=B(I)
        DO J=I+1,N
          SUM=SUM-A(I,J)*B(J)
        END DO
        B(I)=SUM/A(I,I)
      END DO
C
      RETURN
C
      END
C
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C23456789012345678901234567890123456789012345678901234567890123456789012
C                                                                      C
C     SUBROUTINE COPYMAT                                               C
C                                                                      C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE COPYMAT(A,B,N)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      DIMENSION A(N,N),B(N,N)
C
      CALL CLEAR(B,N,N)
C
      DO K1=1,N
        DO K2=1,N
          B(K1,K2)=A(K1,K2)
        END DO
      END DO
C
      RETURN
C
      END
C


module dfs_mod
	implicit none
	private
	public :: dfs

	integer, dimension(:), allocatable :: color, entry, leave
	integer :: timer
	contains

	subroutine dfs(G_in, v, color_in, entry_in, leave_in)
		integer, dimension(:,:), intent(in) :: G_in
		integer :: v
		integer, dimension(:) :: color_in, entry_in, leave_in

		integer :: max

		max = size(G_in(1,:))
		allocate(color(max), entry(max), leave(max))
		color = 0
		entry = 0
		leave = 0
		timer = 0
		call dfs_help(G_in, v)

		! 0 -- не посещена, 1 -- в ней, -1 -- посещена
		color_in = color
		entry_in = entry
		leave_in = leave

		deallocate(color, entry, leave)
	end subroutine dfs

	recursive subroutine dfs_help(G_in, v)
		integer, dimension(:,:), intent(in) :: G_in
		integer :: i, v

		timer = timer + 1
		entry(v) = timer
		color(v) = 1
		!TODO Слишком много раз смотрю размер
		do i = 1, size(G_in(:,1))
			if (G_in(v,i) >= 0 .and. color(i) == 0) then
				call dfs_help(G_in, i)
			endif
		enddo
		timer = timer + 1
		color(v) = -1
		leave(v) = timer
	end subroutine dfs_help
end module dfs_mod


program  rosetta_divbyzero
   implicit none
   integer, parameter :: rdp = kind(1.d0)
   real(rdp) :: normal,zero

   normal = 1.d0
   zero = 0.d0

   call div_by_zero_check(normal,zero)

 contains

   subroutine  div_by_zero_check(x,y)
      use, intrinsic  :: ieee_exceptions
      use, intrinsic  :: ieee_arithmetic
      implicit none
      real(rdp), intent(in) :: x,y

      real(rdp) :: check
      type(ieee_status_type) :: status_value
      logical :: flag
      flag = .false.
      ! Get the flags
      call ieee_get_status(status_value)
      ! Set the flags quiet
      call ieee_set_flag(ieee_divide_by_zero,.false.)
      write(*,*)"Inf supported? ",ieee_support_inf(check)

      ! Calculation involving exception handling
      check = x/y
      write(*,*)"Is check finite?",ieee_is_finite(check), check

      call ieee_get_flag(ieee_divide_by_zero, flag)
      if (flag) write(*,*)"Warning!  Division by zero detected"

      ! Restore the flags
      call ieee_set_status(status_value)

   end subroutine div_by_zero_check

end program rosetta_divbyzero


      SUBROUTINE MATGEN
C
C     THE PURPOSE OF THIS MODULE IS TO GENERATE CERTAIN KINDS OF
C     MATRICES ACCORDING TO ONE OF SEVERAL SIMPLE USER SELECTED OPTIONS
C
C     MATGEN      TAB/OUT/P1/P2/P3/P4/P5/P6/P7/P8/P9/P10/P11  $
C
C     TAB - INPUT TABLE - (OPTIONAL) FOR USE IN GENERATING THE MATIRX
C                 (THIS DATA MAY BE ASSUMED TO BE INPUT VIA DTI CARDS.)
C             = EQEXIN TABLE  FOR P1 =  9
C             = USET   TABLE  FOR P1 = 11
C             = ANY GINO FILE FOR P1 = 10
C
C     OUT - OUTPUT MATRIX - IF PURGED AND P1 IS NOT 10, P1 WILL BE SET
C               TO -1 AND RETURN
C
C     P1      - INPUT - INTEGER, OPTION SELECTION. (DEFULAT P1 = 3)
C             = 1, GENERATE A RSP IDENTITY MATRIX OF ORDER P2.
C             = 2, GENERATE AN IDENTITY MATRIX OF ORDER P2, FORM 8
C             = 3, GENERATE A DIAGONAL MATRIX FORM INPUT FILE T
C             = 4, GENERATE A PARTERN MATRIX
C             = 5, GENERATE A MATRIX OF PSEUDO-RANDOM NUMBERS.
C             = 6, GENERATE PARTITION VECTOR OF ORDER P2, WITH P3 ZERO'S
C                  CLOOWED BY P4 ONE'S FOLLOWED BY P5 ZERO'S ETC.
C                  REMAINER IS ALWAYS AERO. TOO MANY DEFINITIONS IS AN
C                  ERROR.
C             = 7, GENERATE A NULL MATRIX
C             = 8, GENERATE A MATRIX FROM EQUATIONS BASED ON ITS INDICES
C             = 9, GENERATE A TRANSFORMATION BETWEEN EXTERNAL AND
C                  INTERANL MATRICES, OF G-SET SIZE.
C                  P2 = 0, OUTPUTS INT-EXT (DEFAULT)
C                  P2 = 1, OUTPUTS TRANSPOSE EXT-INT
C                  P3 = NO. OF TERMS IN G-SET (REQUIRED). USE LUSET IN
C                       MOST SOLUTION SEQUENCES.
C             =10, ALLOW USER TO ALTER DATA BLOCK TRAILER.
C             =11, GENERATE A RECTANGULAR MATRIX, DRIVEN BY USET TABLE
C
C     P2 - P11 -   OPTION PARAMETERS - INTEGER - INPUT AND OUTPUT
C                  INPUT  AS OPTION VALUE (1 THRU NP)
C                  OUTPUT AS -1 IF AND ONLY IF OUTPUT DATA BLOCK IS PRE-
C                  PURGED
C                  DEFAULT VALUES FOR P2 THRU P11 ARE ZEROS
C
C
      IMPLICIT INTEGER (A-Z)
      EXTERNAL         LSHIFT
      INTEGER          MCB(7),NAM(2),P(11),CODE(2),IX(12)
      REAL             VAL,RX(7),TMP(7)
      DOUBLE PRECISION D(2)
      CHARACTER        UFM*23,UWM*25,UIM*29,SFM*25
      COMMON /XMSSG /  UFM,UWM,UIM,SFM
      COMMON /BLANK /  P1,P2,P3,P4,P5,P6,P7,P8,P9,P10,P11
      COMMON /SYSTEM/  SYSBUF,NOUT,DUM37(37),NBPW,DUM14(14),IPREC
      COMMON /MACHIN/  MACHX
      COMMON /ZBLPKX/  VAL(4),ROW
      COMMON /PACKX /  ITA,ITB,I2,J2,INCR2
CZZ   COMMON /ZZMGEN/  X(1)
      COMMON /ZZZZZZ/  X(20000)
      EQUIVALENCE      (VAL(1),D(1)),(X(1),IX(1),RX(1)),(P(1),P1)
      DATA    NAM   /  4HMATG,4HEN  /,  NP /  11   /
      DATA    EQE   ,  XIN / 4HEQEX, 4HIN  /, CODE / 6,1 /
      DATA    OUT   ,  T      /
     1        201   ,  101    /
C
C     IF OUTPUT DATA BLOCK IS PRE-PURGED, SET P1 = -1 AND RETURN
C
      IF (P1 .EQ. 10) GO TO 30
      MCB(1) = OUT
      CALL RDTRL (MCB)
      IF (MCB(1) .LE. 0) GO TO 1580
C
C     CHECK INPUT FILE REQUIREMENT
C
   30 IX(1) = T
      CALL RDTRL (IX(1))
      IF (P1 .EQ. 10) GO TO 1000
      IF (P1.EQ.3 .OR. P1.EQ.9 .OR. P1.EQ.10 .OR. P1.EQ.11) GO TO 50
      IF (IX(1) .EQ. 0) GO TO 50
      CALL FNAME (IX(1),RX(2))
      WRITE  (NOUT,40) UWM,RX(2),RX(3),P1
   40 FORMAT (A25,' FROM MODULE MATGEN. INPUT DATA BLOCK ',2A4,' IS ',
     1       'NOT NEEDED FOR OPTION',I3)
C
C     CHECK OPEN CORE AND OPEN OUTPUT DATA BLOCK
C
   50 LCOR = KORSZ(IX(1))
      IF (P1 .EQ. 2) GO TO 200
      IF (LCOR .LT. SYSBUF) GO TO 1500
      IBUF1 = LCOR  - SYSBUF - 1
      IBUF2 = IBUF1 - SYSBUF
      CALL GOPEN (OUT,IX(IBUF1),1)
      LCOR = LCOR - SYSBUF
C
C     TEST FOR VALID OPTION AND BRANCH ON OPTION.
C
      IF (P1 .EQ. 0) P1 = 3
      IF (P1.LT.0 .OR. P1.GT.NP) GO TO 1510
      GO TO (100,200,300,400,500,600,700,800,900,1000,1100), P1
C
C     OPTION 1 - GENERATE A RSP IDENTITY MATRIX OF ORDER P2, AND TRAILER
C     ========   P2 = ORDER OF MATRIX
C                P3 = SKEW FLAG, IF NONZERO, GENERATE A SKEW-DIAGONAL
C                     MATRIX
C                P4 = PRECISION (1 OR 2). IF ZERO, USE MACHINE PRECISION
C
  100 IF (P2 .GT. 0) GO TO 110
      IPX = 2
      PX  = P2
      GO TO 1530
  110 ITA = 1
      ITB = P4
      IF (P4 .EQ. 0) ITB = IPREC
      INCR2 = 1
      CALL MAKMCB (MCB,OUT,P2,6,ITB)
      DO 150 I = 1,P2
      RX(I) = 1.0
      I2 = I
      J2 = I
      CALL PACK (IX,OUT,MCB)
  150 CONTINUE
CWKBI SPR93023 12/93
      CALL CLOSE ( OUT, 1 )
      GO TO 210
C
C     OPTION 2 - GENERATE AN IDENTITY TRAILER (FORM = 8)
C     ========   P2 = ORDER OF MATRIX
C
C                ** CAUTION ** FORM = 8 MATRICES DO NOT REALLY EXIST
C                ONLY CERTAIN  ROUTINES CAN PROCESS THEM
C                e.g. FBS, MPYAD, CEAD etc.
C
  200 MCB(1) = OUT
      MCB(2) = P2
      MCB(3) = P2
      MCB(4) = 8
      MCB(5) = 1
      MCB(6) = 1
C     MCB(7) = LSHIFT(1,NBPW-2) + P2
      MCB(7) = LSHIFT(1,NBPW-2 - (NBPW-32)) + P2
C
C     ADD (NBPW-32) TO MCB(7) SO THAT CRAY, WITH 48-BIT INTEGER WILL
C     NOT GET INTO TROUBLE. (SEE SDCOMP AND WRTTRL)
C
  210 CALL WRTTRL (MCB)
      GO TO 1700
C
C     OPTION 3 - GENERATE A DIAGONAL MATRIX FROM INPUT TABLE T
C     ========   P2 = DATA TYPE OF T
C                P3 = 0, FORM 6 MATRIX IS GENERATED
C                   = 1, FORM 3 MATRIX IS GENERATED
C
C     THIS OPTION IS THE ORIGINAL MATGEN IN COSMIC MATGEN
C     SKIP HEADER RECORD, AND BEGINNING RECORD ON T
C     PICKUP DATA IN ARRAY OF 7 WORDS. DIAGONAL VAULE ON THE 3RD
C
  300 LCOR = LCOR - SYSBUF
      IF (LCOR .LT. SYSBUF) GO TO 1500
      IF (P2 .EQ. 0) P2 = 1
      CALL OPEN (*1550,T,IX(IBUF2),0)
      CALL SKPREC (T,2)
      ITA = P2
      ITB = IPREC
      INCR2 = 1
      FORM = 6
      IF (P3 .EQ. 1) FORM = 3
      CALL MAKMCB (MCB,OUT,0,FORM,IPREC)
      M  = 0
  310 CALL READ (*1560,*330,T,TMP,7,0,0)
      M  = M + 1
      IF (P3 .EQ. 1) GO TO 320
      I2 = M
      J2 = M
      CALL PACK (TMP(3),OUT,MCB)
      GO TO 310
  320 RX(M) = TMP(3)
      GO TO 310
  330 IF (P3 .EQ. 1) GO TO 340
      MCB(3) = MCB(2)
      GO TO 350
  340 I2 = 1
      J2 = M
      CALL PACK (RX,OUT,MCB)
      MCB(2) = 1
      MCB(3) = M
  350 CALL CLOSE (T,1)
      GO TO 210
C
C     OPTION 4 - GENERATE A PATTERN MATRIX
C     ========   P2 = NUNBER OF COLUMNS
C                P3 = NUMBER OF ROWS
C                P4 = PRECISION (1 OR 2). IF 0, USE MACHINE PRECISION
C                P5 = NUMBER OF TERMS PER STRING. IF 0, USE 1
C                P6 = INCREMENT BETWEEN STRINGS. IF 0, USE 1
C                P7 = ROW NUMBER OF 1ST STRING IN COLUMN 1. IF 0, USE 1
C                P8 = INCREMENT TO 1ST ROW FOR SUBSEQUENT COLUMNS.
C                P9 = NUMBER OF COLS BEFORE RETURNING TO P7.
C
C                THE VALUE OF EACH NON-ZERO TERM IN THE MATRIX WILL BE
C                THE COLUMN NUMBER
C                e.g. TO GENERATE A 10x10 DIAGONAL MATRIX WITH THE COL.
C                NUMBER IN EACH DIAGONAL POSITION, CODE
C
C                MATGEN   ,/DIAG/4/10/10/0/1/10/1/1/10  $
C
  400 P2 = MAX0(P2,1)
      P3 = MAX0(P3,1)
      IF (P4.NE.1 .AND. P4.NE.2) P4 = 0
      IF (P4 .EQ. 0) P4 = IPREC
      P5 = MAX0(P5,1)
      P6 = MAX0(P6,1)
      P7 = MAX0(P7,1)
      P8 = MAX0(P8,0)
      P9 = MAX0(P9,1)
      IROW1 = P7
      L = 1
      CALL MAKMCB (MCB,OUT,P3,2,P4)
C
      DO 440 J = 1,P2
      IF (P4 .EQ. 1) VAL(1) = J
      IF (P4 .EQ. 2) D(  1) = J
      ROW = IROW1
      CALL BLDPK (P4,P4,OUT,0,0)
  410 CONTINUE
      DO 420 K = 1,P5
      IF (ROW .GT. P3) GO TO 430
      CALL ZBLPKI
      ROW = ROW + 1
  420 CONTINUE
      ROW = ROW + P6 - 1
      GO TO 410
  430 CALL BLDPKN (OUT,0,MCB)
CWKBI 9/93
  435 CONTINUE
      L = L + 1
      IROW1 = IROW1 + P8
CWKBR 9/93 IF (L .LE. P9) GO TO 430
      IF (L .LE. P9) GO TO 435
      L = 1
      IROW1 = P7
  440 CONTINUE
      GO TO 1400
C
C     OPTION 5 - GENERATE A MATRIX OF PSEUDO-RANDOM NUMBERS. THE NUMBERS
C     ========   SPAN THE RANGE 1. TO 1.0 WITH A NORMAL DISTRIBUTION
C                P2 = NUMBER OF COLUMNS
C                P3 = NUMBER OF ROWS
C                P4 = PRECISION (1 OR 2).  IF 0, USED MACHINE PRECISION
C                P5 = SEED FOR RANDOM NUMBER GENERATION.  IF P5.LE.0,
C                     THE TIME OF DAY (SECONDS PAST MIDNIGHT) WILL BE
C                     USED
C
C     OPTION 5 WAS WRITTEN BY G.CHAN/UNISYS 2/93
C
  500 ITA = 1
      ITB = P4
      IF (P4 .EQ. 0) ITB = IPREC
      FORM = 2
      IF (P2 .EQ. P3) FORM = 1
      I2 = 1
      J2 = P3
      INCR2 = 1
      CALL MAKMCB (MCB,OUT,P2,FORM,ITB)
      K  = P5
      IF (MACHX .EQ. 4) GO TO 560
C                   CDC
      IF (MACHX .EQ. 9) GO TO 530
C                    HP
C
      DO 520 I = 1,P2
      IF (P5 .EQ. 0) CALL CPUTIM (K,K,0)
      K  = (K/2)*2 + 1
      DO 510 J = 1,P3
CWKBR 5/95 SUN     RX(J) = RAN(K)
      RX(J) = RAND(K)
  510 CONTINUE
      CALL PACK (RX(1),OUT,MCB)
  520 CONTINUE
      GO TO 590
C
C     HP ONLY
C     ACTIVATE SRAND AND RAND() BELOW, AND COMMENT OUT RAN(K) ABOVE
C
  530 CONTINUE
      WRITE  (NOUT,535) SFM
  535 FORMAT (A25,'. MATGEN NEEDS TO ACTIVATE SRAND AND RAND() FOR HP')
      CALL MESAGE (-61,0,0)
      DO 550 I = 1,P2
      IF (P5 .EQ. 0) CALL CPUTIM (K,K,0)
C     CALL SRAND (K)
      DO 540 J = 1,P3
C     RX(J) = RAND()
  540 CONTINUE
      CALL PACK (RX(1),OUT,MCB)
  550 CONTINUE
      GO TO 590
C
C     CDC ONLY
C     ACTIVATE SRAND AND RAND() BELOW, AND COMMENT OUT RAN(K) ABOVE
C
  560 CONTINUE
      WRITE  (NOUT,565) SFM
  565 FORMAT (A25,'. MATGEN NEEDS TO ACTIVATE RANSET AND RANF() FOR CDC'
     1       )
      CALL MESAGE (-61,0,0)
      DO 580 I = 1,P2
      IF (P5 .EQ. 0) CALL CPUTIM (K,K,0)
C     CALL RANSET (K)
      DO 570 J = 1,P3
C     RX(J) = RANF()
  570 CONTINUE
      CALL PACK (RX(1),OUT,MCB)
  580 CONTINUE
C
  590 CALL CLOSE  (OUT,1)
      CALL WRTTRL (MCB(1))
      GO TO 1700
C
C     OPTION 6 - GENERATE A PARTITIONING VECTOR FOR USE IN PARTN OR
C     ========   MERGE
C                P2 = NUMBER OF ROWS
C                P3,P5,P7,P9  = NUMBER OF ROWS WITH ZERO COEFFICIENTS
C                P4,P6,P8,P10 = NUMBER OF ROWS WITH UNIT COEFFICIENTS
C
C                IF SUM OF P3 THRU P10 IS .LT. P2, THE REMAINING TERMS
C                CONTAIN ZEROS
C                IF SUM OF P3 THRU P10 IS .GT. P2, THE TERMS ARE IGNORED
C                AFTER P2
C                e.g. GENERATE A VECTOR OF 5 UNIT TERMS FOLLOWED BY 7
C                ZEROS, FOLLOWED BY TWO UNIT TERMS
C
C                MATGEN,   ,/UPART/6/14/0/5/7/2   $
C
C     OPTION 6 WAS ORIGINALLY WRITTEN BY P.KIRCHMAN/SWALES 1/92
C     RE-CODED BY G.CHAN/UNISYS FOR ALL COMPILERS,  2/93
C
  600 IPX = 2
      PX  = P2
      IF (P2 .LE. 0) GO TO 1530
      INCR2 = 1
      I2  = 1
      J2  = P2
      ITA = 1
      ITB = 1
      CALL MAKMCB (MCB,OUT,P2,2,ITB)
      TOT = 0
      DO 610 I = 3,11
  610 TOT = TOT + P(I)
      IF (TOT .GT. P2) WRITE (NOUT,620) UFM,P1,P2
      IF (TOT .LT. P2) WRITE (NOUT,630) UWM,P1
  620 FORMAT (A23,' FROM MATGEN, OPTION',I3,'. TOO MANY ENTRIES FOR ',
     1       'SPECIFIED SIZE',I7)
  630 FORMAT (A25,' FORM MATGEN, OPTION',I3,'. THE NUMBER OF ENTRIES ',
     1       'SPECIFIED BY PARAMETERS IS LESS THAN THE TOTAL SIZE', /5X,
     2       'OF THE PARTITION. THE REMAINING RENTRIES ARE ZERO FILLED')
      K = 1
      DO 660 I = 3,9,2
      PI = P(I)
      DO 640 J = 1,PI
CWKBR SPR 93023 12/93      IX(K) = 0
      RX(K) = 0.
  640 K = K + 1
      PI = P(I+1)
      DO 650 J = 1,PI
CWKBR SPR 93024 12/93      IX(K) = 1
      RX(K) = 1.0
  650 K = K + 1
  660 CONTINUE
      IF (K .GE. P2) GO TO 680
      DO 670 I = K,P2
  670 IX(I) = 0
  680 CALL PACK (IX,OUT,MCB)
      CALL CLOSE (OUT,1)
      CALL WRTTRL (MCB)
      GO TO 1700
C
C     OPTION 7 - GENERATE A NULL MATRIX
C     ========   P2 = NUMBER OF ROWS
C                P3 = NUMBER OF COLUMNS
C                P4 = FORM; IF P4 = 0, AND P2 = P3, FORM WILL BE 6
C                     (SYMMETRIC). OTHERWISE P4 IS 2 (RECTANGULAR)
C                P5 = TYPE: IF P5 = 0, TYPE IS MACHINE PRECISION
C
  700 D(1) = 0.0D0
      D(2) = 0.0D0
      ITA = 1
      ITB = P5
      IF (P5 .EQ. 0) ITB = IPREC
      FORM = P4
      IF (P4.EQ.0 .AND. P2.EQ.P3) FORM = 6
      IF (P4.EQ.0 .AND. P2.NE.P3) FORM = 2
      I2 = 1
      J2 = 1
      INCR2 = 1
      CALL MAKMCB (MCB,OUT,P2,FORM,ITB)
      DO 750 I = 1,P3
      CALL PACK (VAL,OUT,MCB)
  750 CONTINUE
      CALL CLOSE  (OUT,1)
      CALL WRTTRL (MCB(1))
      GO TO 1700
C
C     OPTION 8 - GENERATE A MATRIX FROM EQUATIONS BASED ON IT INDICES
C     ========   P2 =  0, GENERATE ALL TERMS
C                  .NE.0, GENERATE ONLY DIAGONAL TERMS
C                P3 =     NUMBER OF ROWS
C                P4 =     NUMBER OF COLUMNS
C                P5 =     NUMBER OF THE RECORD IN THE INPUT DTI TABLE
C                         USED TO DEFINE REAL COEFFICIENTS
C                  .LT.0, COEFFICIENT TAKEN FROM DTI TRAILER
C                         COEFF(TRAILER1) = FLOAT(TRAILER2)   TRAILER
C                         COEFF(TRAILER3) = FLOAT(TRAILER4)   ITEMS ARE
C                         COEFF(TRAILER5) = FLOAT(TRAILER6)   INTEGERS
C
C                   = 0,  DATA PAIRS FROM RECORD 0 (DATA BLOCK HEADER
C                         RECORD) ARE INTERPRETED AS DFINING
C                         COEFF(V1) = V2     V1 IS INTEGER, V2 IS REAL
C                  .GT.0, DATA PAIRS FROM RECORD P5 INTERPRETED AS ABOVE
C                P6 =     NUMBER OF THE RECORD IN THE INPUT DTI TABLE
C                         USED TO DEFINE IMAGINARY DOEFFICIENTS D(I)
C                  .LE.0, NO DOEFFICIENTS DEFINED
C                  .GT.0, DATA PAIRS FROM RECORD P6 INTERPRETED AS ABOVE
C                         WHERE D(V1) = V2
C                P7 =     FORM OF OUTPUT MATRIX
C                  .LE.0, FORM = 1 OR 2, DEPENDING ON P3 AND P4
C                  .GT.0, FORM SET TO P7
C                P8 =     COEFFICIENT PRINT FLAG
C                   = 0,  DO NOT PRINT COEFFICIENT LISTS
C                  .NE.0, PRINT COEFFICIENTS LISTS C(L) AND D(L) FROM
C                         DTI INPUT. (PRINT D(L) LIST ONLY IF P6.GT.0)
C
C                SEE USER MANUAL FOR THE EQUATION USED TO DETERMINE THE
C                COEFFICIENT OF THE (I,J)TH TERM OF THE OUTPUT MATRIX
C
  800 WRITE (NOUT,1200) UWM,P1
      GO TO 1700
C
C     OPTION 9 - GENERATE A TRANSFORMATION BETWEEN EXTERNAL AND INTERNAL
C     ========   MATRICES FOR G-SET SIZE MATRICES
C                P2 = 0, OUTPUT NON-TRANSPOSED FACTOR, UEXT = MAT*UINT
C                   = 1, OUTPUT TRANSPOSED FACTOR, UEXT = MAT*UINT
C                P3 = NUMBER OF TERMS IN G-SET. THE PARAMETER LUSET
C                     CONTAINS THIS NUMBER IN MOST SOLUTION SEQUENCES
C
C                EXAMPLES -
C                1. TRANSFORM A g-SET SIZE VECTOR TO EXTERNAL SEQUENCE
C                ALTER XX  $ AFTER SDR1, ALL SDR1 OUTPUTS ARE IN
C                            INTERNAL SEQUENCE
C                MATGEN  EQEXIN/INTEXT/9//LUSET $
C                MPYAD   INTEXT,UGV,/UGVEXT/1 $
C
C                2. TRANSFORM AN a-SET SIZE MATRIX TO EXTERNAL SEQUENCE
C                ALTER XX  $ AFTER KAA IS GENERATED, ALL MATRICES ARE IN
C                            INTERNAL SEQUENCE
C                MATGET  EQEXIN/INTEXT/9/0/LUSET $
C                SMPYAD  INTEXT,KAGG,INTEXT,,/KAAGEXT/3////1////6 $
C                $ (KAAGEXT) = TRANSPOSE(INTEXT)*(KAAG)*(INTEXT)
C                $ ITS FORM IS 6 (SYMMETRIC)
C
C     OPTION 9 WAS ORIGINALLY WRITTEN BY P.KIRCHMAN/SWALES 1/92
C     RE-CODED BY G.CHAN/UNISYS FOR ALL COMPILERS,  2/93
C
  900 IPX = 3
      PX  = P(3)
      IF (PX .LE. 0) GO TO 1530
      NUSET = PX
      L     = 2
      NVAL  = IX(L)
      CALL FNAME (T,TMP(1))
      IF (TMP(1).NE.EQE .OR. TMP(2).NE.XIN) GO TO 1600
      CALL OPEN (*1550,T,IX(IBUF2),0)
      CALL FWDREC (*1560,T)
      CALL FWDREC (*1560,T)
      CALL READ (*1560,*910,T,IX(1),IBUF2-1,1,L)
  910 CALL CLOSE (T,1)
      IF (L .NE. NVAL*2) GO TO 1620
      ITA = IPREC
      ITB = ITA
      CALL MAKMCB (MCB,OUT,NUSET,2,ITB)
      INCR2 = 1
      VAL(1)= 1.0
      IF (ITA .EQ. 2) D(1) = 1.0D+0
      TOT   = 0
      IF (P2 .GT. 0) GO TO 930
C
C     NO TRANSPOSE
C
      DO 920 I = 1,NVAL
      IS2 = I*2
      A = IX(IS2)/10
      B = MOD(IX(IS2),10)
      C = CODE(B)
      DO 920 J = 1,C
      I2 = A
      J2 = A
      CALL PACK (VAL,OUT,MCB)
  920 A = A + 1
      TOT = TOT + C
      GO TO 980
C
C     TRANSPOSE
C
  930 NVAL2 = NVAL*2
      POS = 1
      DO 940 I = 1,NVAL
      IS2 = I*2
      A = IX(IS2)/10
      B = MOD(IX(IS2),10)
      IX(IS2-1) = POS
  940 POS = POS + CODE(B)
      DO 970 I = 4,NVAL2,2
      J = NVAL2
      FLAG = 0
  950 IF (IX(J) .GE. IX(J-2)) GO TO 960
      FLAG = 1
      K = IX(J  )
      L = IX(J-1)
      IX(J  ) = IX(J-2)
      IX(J-1) = IX(J-3)
      IX(J-2) = K
      IX(J-3) = L
  960 J = J - 2
      IF (J .GE. I) GO TO 950
      IF (FLAG .EQ. 0) GO TO 980
  970 CONTINUE
C
  980 DO 990 I = 1,NVAL
      IS2 = I*2
      A = IX(IS2)/10
      B = MOD(IX(IS2),10)
      A = IX(IS2-1)
      C = CODE(B)
      DO 990 J = 1,C
      I2 = A
      J2 = A
      CALL PACK (VAL,OUT,MCB)
  990 A  = A + 1
      TOT = NVAL*C
      IF (NUSET .NE. TOT) GO TO 1640
      CALL WRTTRL (MCB)
      CALL CLOSE  (OUT,1)
      GO TO 1700
C
C     OPTION 10 - ALLOW USER TO ALTER DATA BLOCK TRAILER
C     =========
C     IF PI IS NEGATIVE, THE CORRESPONDING TRAILER WORD (I) IS SET TO
C     ZERO
C
 1000 IF (IX(1) .EQ. 0) GO TO 1050
      CALL FNAME (IX(1),IX(11))
      WRITE  (NOUT,1010) UIM,IX(11),IX(12),(IX(I),I=2,7)
 1010 FORMAT (A29,' FROM MATGEN MODULE, OPTION 10. TRAILER OF ',2A4,2H -
     1,      /5X,'OLD - ',6I7)
      DO 1020 I = 2,7
      IF (P(I) .NE. 0) IX(I) = P(I)
      IF (P(I) .LT. 0) IX(I) = 0
 1020 CONTINUE
      WRITE  (NOUT,1030) (IX(I),I=2,7)
 1030 FORMAT (5X,'NEW - ',6I7)
      IF (IX(2).EQ.IX(3) .AND. IX(4).EQ.2 .AND. IX(7).NE.0)
     1   WRITE (NOUT,1040) UIM
 1040 FORMAT (A29,'. SINCE ROW = COLUMN, RECTANGULAR FORM 2 WILL BE ',
     1       'CHANGED TO SQUARE FORM 1 AUTOMATICALLY')
      IX(1) = 199
      CALL WRTTRL (IX(1))
      GO TO 1700
C
 1050 WRITE  (NOUT,1060) UWM
 1060 FORMAT (A25,' FROM MATGEN, OPTION 10. INPUT FILE MISSING')
      GO TO 1700
C
C     OPTION 11 - GENERATE A RECTANGULAR MATRIX, DRIVEN BY USET TABLE
C     =========   P2 = 1, GENERATE A NULL MATRIX
C                  .NE.1, GENERATE A NULL MATRIX WITH AN IDENTITY MATRIX
C                         STORED IN IT
C                 P3 = NUMBER OF COLUMNS OF OUTPUT MATRIX, IF P2 = 1
C                    = BIT POSITION OF SET THAT DEFINES NUMBER OF ROW,
C                      IF P2.NE.1. SEE SECTION 1.4.10 FOR BIT POSITION
C                      LIST. DEFAULT IS A-SET SIZE.
C                 P4 = NOT USED IF P2 = 1. THE OUTPUT MATRIX WILL BE
C                      NULL AND HAVE P3 COLUMNS AND A-SET SIZE ROWS
C                    = BIT POSITION OF SET THAT DEFINES NUMB OF COLUMNS
C                      IF P2.NE.1. DEFAULT IS L-SET SIZE
C
C                 IF P2.NE.1, AND ONE OR BOTH OF THE SETS REQUESTED IN
C                 P3 AND P4 DOES NOT EXIST, THEN MAT IS RETURNED PURGED,
C                 AND P5 IS RETURNED WITH THE VALUE OF -1. IF MAT DOES
C                 EXISTS, P5 IS RETURNED WITH THE VALUE 0
C
 1100 WRITE  (NOUT,1200) UWM,P1
 1200 FORMAT (A25,' FROM MATGEN MODULE, OPTION',I3,' IS NOT AVAILABLE')
      GO TO 1700
C
C     WRAP-UP AND RETURN TO EXECUTIVE SYSTEM
C
 1400 CALL CLOSE  (OUT,1)
      CALL WRTTRL (MCB)
      GO TO 1700
C
C     ERROR MESSAGES
C
 1500 CONTINUE
      LCOR = SYSBUF - LCOR
      CALL MESAGE (-8,LCOR,NAM)
      GO TO 1700
C
 1510 WRITE  (NOUT,1520) UFM,P1
 1520 FORMAT (A23,' IN MATGEN, ILLEGAL VALUE FOR OPTION PARAMETER =',I5)
      GO TO 1690
C
 1530 WRITE  (NOUT,1540) UFM,IPX,PX
 1540 FORMAT (A23,' IN MATGEN, ILLEGAL VALUE FOR PARAMETER ',I1,3H = ,
     1        I5)
C
 1550 J = -1
      GO TO 1570
 1560 J = -2
 1570 CALL MESAGE (J,T,NAM)
C
 1580 WRITE  (NOUT,1590) UFM,P1
 1590 FORMAT (A23,'. OPTION',I3,' OUTPUT DATA BLOCK IS MISSING')
      P1 = -1
      GO TO  1700
 1600 WRITE  (NOUT,1610) UFM,TMP(1),TMP(2)
 1610 FORMAT (A23,'. OPTION 9. INPUT FILE IS ',2A4,', NOT EQEXIN')
      GO TO  1690
 1620 WRITE  (NOUT,1630) UFM,L,NVAL
 1630 FORMAT (A23,'. EQEXIN RECORD LENGTH NOT MATCH TWICE TRAIL(2)',2I9)
      GO TO  1690
 1640 WRITE  (NOUT,1650) UFM,NUSET,TOT
 1650 FORMAT (A23,'. OPTION 9, LUSET OF',I9,' DOES NOT AGREE WITH SIZE',
     1       ' OF EQEXIN',I9)
 1690 CALL MESAGE (-61,0,NAM)
 1700 RETURN
      END


! RUN: bbc %s -o - | FileCheck %s

! CHECK-LABEL: func @_QPformatassign
subroutine formatAssign(flag1, flag2, flag3)
    real :: pi
    integer :: label
    logical :: flag1, flag2, flag3

    ! CHECK-DAG: %[[ONE:.*]] = arith.constant 100 : i32
    ! CHECK-DAG: %[[TWO:.*]] = arith.constant 200 : i32
    if (flag1) then
       assign 100 to label
    else
       assign 200 to label
    end if

    ! CHECK: cond_br %{{.*}}, ^bb[[BLK1:.*]], ^bb[[BLK2:.*]]
    ! CHECK: ^bb[[BLK1]]:
    ! CHECK: fir.store %[[ONE]]
    ! CHECK: br ^bb[[END_BLOCK:.*]]
    ! CHECK: ^bb[[BLK2]]:
    ! CHECK: fir.store %[[TWO]]
    ! CHECK: br ^bb[[END_BLOCK]]
    ! CHECK: ^bb[[END_BLOCK]]
    ! CHECK: fir.call @{{.*}}BeginExternalFormattedOutput
    ! CHECK: fir.call @{{.*}}OutputAscii
    ! CHECK: fir.call @{{.*}}OutputReal32
    ! CHECK: fir.call @{{.*}}EndIoStatement
    pi = 3.141592653589
    write(*, label) " PI=", pi
    ! CHECK: fir.call @{{.*}}BeginExternalFormattedOutput
    ! CHECK: fir.call @{{.*}}OutputAscii
    ! CHECK: fir.call @{{.*}}OutputReal32
    ! CHECK: fir.call @{{.*}}EndIoStatement
    if (flag2) write(*, label) "2PI=", 2*pi
    if (flag1 .and. flag2 .and. flag3) then
       assign 100 to label
    else
       assign 200 to label
    end if
    if (flag3) then
      ! CHECK: fir.call @{{.*}}BeginExternalFormattedOutput
      ! CHECK: fir.call @{{.*}}OutputAscii
      ! CHECK: fir.call @{{.*}}OutputReal32
      ! CHECK: fir.call @{{.*}}EndIoStatement
      write(*, label) "3PI=", 3*pi
    endif

100 format (A, F10.3)
200 format (A,E8.1)
300 format (A, E4.2)

end subroutine

! CHECK-LABEL: func @_QQmain
  call formatAssign(.true., .true., .true.)
  print*
  call formatAssign(.true., .false., .true.)
end


!==========================================================================
elemental function gsw_cabbeling (sa, ct, p)
!==========================================================================
!
!  Calculates the cabbeling coefficient of seawater with respect to
!  Conservative Temperature.  This function uses the computationally-
!  efficient expression for specific volume in terms of SA, CT and p
!  (Roquet et al., 2014).
!
!  SA  =  Absolute Salinity                                        [ g/kg ]
!  CT  =  Conservative Temperature (ITS-90)                       [ deg C ]
!  p   =  sea pressure                                             [ dbar ]
!         ( i.e. absolute pressure - 10.1325 dbar )
!
!  cabbeling  =  cabbeling coefficient with respect to            [ 1/K^2 ]
!                Conservative Temperature.
!--------------------------------------------------------------------------

use gsw_mod_toolbox, only : gsw_alpha_on_beta, gsw_rho
use gsw_mod_toolbox, only : gsw_specvol_first_derivatives
use gsw_mod_toolbox, only : gsw_specvol_second_derivatives

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p

real (r8) :: gsw_cabbeling

real (r8) :: alpha_ct, alpha_on_beta, alpha_sa, beta_sa, rho
real (r8) :: v_sa, v_ct, v_sa_sa, v_sa_ct, v_ct_ct

call gsw_specvol_first_derivatives(sa,ct,p,v_sa,v_ct)

call gsw_specvol_second_derivatives(sa,ct,p,v_sa_sa,v_sa_ct,v_ct_ct)

rho = gsw_rho(sa,ct,p)

alpha_ct = rho*(v_ct_ct - rho*v_ct*v_ct)

alpha_sa = rho*(v_sa_ct - rho*v_sa*v_ct)

beta_sa = -rho*(v_sa_sa - rho*v_sa*v_sa)

alpha_on_beta = gsw_alpha_on_beta(sa,ct,p)

gsw_cabbeling = alpha_ct + &
                alpha_on_beta*(2.0_r8*alpha_sa - alpha_on_beta*beta_sa)

return
end function

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


module init_data_module

contains

  subroutine init_data_3d(tlo,thi,lo,hi,cons,ng,dx,phlo,phhi) bind(c,name='init_data_3d')

    use variables_module, only : irho, imx,imy,imz,iene,iry1,ncons, iH2, iO2, iN2
    use chemistry_module, only : nspecies, patm

    implicit none

    integer,          intent(in   ) :: tlo(3),thi(3),lo(3),hi(3),ng
    double precision, intent(in   ) :: dx(3),phlo(3),phhi(3)
    double precision, intent(inout) :: cons(-ng+lo(1):hi(1)+ng,-ng+lo(2):hi(2)+ng,-ng+lo(3):hi(3)+ng,ncons)

    double precision, parameter :: Pi = 3.141592653589793238462643383279502884197d0
    double precision, parameter :: rfire = 0.01d0
    double precision, parameter :: Lperiodic = 0.1d0

    integer          :: i,j,k,n
    double precision :: x, y, z, r

    double precision Xt(nspecies), Yt(nspecies)
    double precision rhot,u1t,u2t,u3t,Tt,et,Pt
    integer :: iwrk
    double precision :: rwrk, expfac, kx, ky, kz

    kx = 2.d0*Pi/(phhi(1) - phlo(1))
    ky = 2.d0*Pi/(phhi(2) - phlo(2))
    kz = 2.d0*Pi/(phhi(3) - phlo(3))

    do k=tlo(3),thi(3)
       z = mod(dx(3)*(k+0.5d0), Lperiodic) - 0.5d0*Lperiodic
       do j=tlo(2),thi(2)
          y = mod(dx(2)*(j+0.5d0), Lperiodic) - 0.5d0*Lperiodic
          do i=tlo(1),thi(1)
             x = mod(dx(1)*(i+0.5d0), Lperiodic) - 0.5d0*Lperiodic

             r = sqrt(x**2+y**2+z**2)

             Pt = Patm
             Tt = 300.0d0

             Xt = 0.0d0
             Xt(iH2) = 0.10d0
             Xt(iO2) = 0.25d0

             expfac = exp(-(r / rfire)**2)
             Pt      = Pt      + 0.1d0*patm * expfac
             Tt      = Tt      + 1100.0d0   * expfac
             Xt(iH2) = Xt(iH2) + 0.025d0    * expfac
             Xt(iO2) = Xt(iO2) - 0.050d0    * expfac

             Xt(iN2) = 1.0d0 - Xt(iH2) - Xt(iO2)

             u1t =  sin(kx*x)*cos(ky*y)*cos(kz*z) * 300.d0
             u2t = -cos(kx*x)*sin(ky*y)*cos(kz*z) * 300.d0
             u3t = 0.d0

             CALL CKXTY (Xt, IWRK, RWRK, Yt)
             CALL CKRHOY(Pt,Tt,Yt,IWRK,RWRK,rhot)
             call CKUBMS(Tt,Yt,IWRK,RWRK,et)

             cons(i,j,k,irho) = rhot
             cons(i,j,k,imx)  = rhot*u1t
             cons(i,j,k,imy)  = rhot*u2t
             cons(i,j,k,imz)  = rhot*u3t
             cons(i,j,k,iene) = rhot*(et + 0.5d0*(u1t**2 + u2t**2 + u3t**2))

             do n=1,nspecies
                cons(i,j,k,iry1-1+n) = Yt(n)*rhot
             end do

          enddo
       enddo
    enddo

  end subroutine init_data_3d

end module init_data_module


!=============================================================================!
!
!  These routines generate the factored LHS for the Navier-Stokes Equations
!  using 4th order differencing.
!
!=============================================================================!
        subroutine lhs1f( mat, Ah, Dh, Vh11, dtl, v )
!
!  Form the LHS for the \xi direction
!
!=============================================================================!
        use global
        use buffer
        use stencil
        implicit none

        real :: mat(5,ndof,ndof,nx,ny), v(ndof,nx,ny)
        real :: Ah(ndof,ndof,nx,ny), Dh(ndof,ndof,nx,ny), Vh11(6,nx,ny)
        real :: dtl(nx,ny)

!.... first derivative operator

        real :: a1, a2, a3, a4, a5
        real :: b1, b2, b3, b4, b5

        integer :: i, j, idof, jdof
!=============================================================================!

!.... fourth-order stencil

        a1 = alfa * ga1  / dxi
        a2 = alfa * ga2  / dxi
        a3 = alfa * zero / dxi
        a4 = alfa * ga3  / dxi
        a5 = alfa * ga4  / dxi

        b1 =  alfa * da1 / dxi**2
        b2 =  alfa * da2 / dxi**2
        b3 =  alfa * da3 / dxi**2
        b4 =  alfa * da4 / dxi**2
        b5 =  alfa * da5 / dxi**2

        !$omp parallel do private (i,idof,jdof)
        loop_j: do j = 1, ny
        loop_i: do i = 1, nx

!.... \hat{A} term

        do idof = 1, ndof
          do jdof = 1, ndof
            mat(1,idof,jdof,i,j) = a1 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(2,idof,jdof,i,j) = a2 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(3,idof,jdof,i,j) = a3 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(4,idof,jdof,i,j) = a4 * dtl(i,j) * Ah(idof,jdof,i,j)
            mat(5,idof,jdof,i,j) = a5 * dtl(i,j) * Ah(idof,jdof,i,j)
          end do
        end do

!.... \hat{D} term

        do idof = 1, ndof
          do jdof = 1, ndof
            mat(3,idof,jdof,i,j) = mat(3,idof,jdof,i,j) + &
                                   alfa * dtl(i,j) * Dh(idof,jdof,i,j)
          end do
        end do

!.... \hat{V}_{\xi\xi} term

        mat(1,2,2,i,j) = mat(1,2,2,i,j) - b1 * dtl(i,j) * Vh11(1,i,j)
        mat(1,2,3,i,j) = mat(1,2,3,i,j) - b1 * dtl(i,j) * Vh11(5,i,j)
        mat(1,3,2,i,j) = mat(1,3,2,i,j) - b1 * dtl(i,j) * Vh11(6,i,j)
        mat(1,3,3,i,j) = mat(1,3,3,i,j) - b1 * dtl(i,j) * Vh11(2,i,j)
        mat(1,4,4,i,j) = mat(1,4,4,i,j) - b1 * dtl(i,j) * Vh11(3,i,j)
        mat(1,5,5,i,j) = mat(1,5,5,i,j) - b1 * dtl(i,j) * Vh11(4,i,j)

        mat(2,2,2,i,j) = mat(2,2,2,i,j) - b2 * dtl(i,j) * Vh11(1,i,j)
        mat(2,2,3,i,j) = mat(2,2,3,i,j) - b2 * dtl(i,j) * Vh11(5,i,j)
        mat(2,3,2,i,j) = mat(2,3,2,i,j) - b2 * dtl(i,j) * Vh11(6,i,j)
        mat(2,3,3,i,j) = mat(2,3,3,i,j) - b2 * dtl(i,j) * Vh11(2,i,j)
        mat(2,4,4,i,j) = mat(2,4,4,i,j) - b2 * dtl(i,j) * Vh11(3,i,j)
        mat(2,5,5,i,j) = mat(2,5,5,i,j) - b2 * dtl(i,j) * Vh11(4,i,j)

        mat(3,2,2,i,j) = mat(3,2,2,i,j) - b3 * dtl(i,j) * Vh11(1,i,j)
        mat(3,2,3,i,j) = mat(3,2,3,i,j) - b3 * dtl(i,j) * Vh11(5,i,j)
        mat(3,3,2,i,j) = mat(3,3,2,i,j) - b3 * dtl(i,j) * Vh11(6,i,j)
        mat(3,3,3,i,j) = mat(3,3,3,i,j) - b3 * dtl(i,j) * Vh11(2,i,j)
        mat(3,4,4,i,j) = mat(3,4,4,i,j) - b3 * dtl(i,j) * Vh11(3,i,j)
        mat(3,5,5,i,j) = mat(3,5,5,i,j) - b3 * dtl(i,j) * Vh11(4,i,j)

        mat(4,2,2,i,j) = mat(4,2,2,i,j) - b4 * dtl(i,j) * Vh11(1,i,j)
        mat(4,2,3,i,j) = mat(4,2,3,i,j) - b4 * dtl(i,j) * Vh11(5,i,j)
        mat(4,3,2,i,j) = mat(4,3,2,i,j) - b4 * dtl(i,j) * Vh11(6,i,j)
        mat(4,3,3,i,j) = mat(4,3,3,i,j) - b4 * dtl(i,j) * Vh11(2,i,j)
        mat(4,4,4,i,j) = mat(4,4,4,i,j) - b4 * dtl(i,j) * Vh11(3,i,j)
        mat(4,5,5,i,j) = mat(4,5,5,i,j) - b4 * dtl(i,j) * Vh11(4,i,j)

        mat(5,2,2,i,j) = mat(5,2,2,i,j) - b5 * dtl(i,j) * Vh11(1,i,j)
        mat(5,2,3,i,j) = mat(5,2,3,i,j) - b5 * dtl(i,j) * Vh11(5,i,j)
        mat(5,3,2,i,j) = mat(5,3,2,i,j) - b5 * dtl(i,j) * Vh11(6,i,j)
        mat(5,3,3,i,j) = mat(5,3,3,i,j) - b5 * dtl(i,j) * Vh11(2,i,j)
        mat(5,4,4,i,j) = mat(5,4,4,i,j) - b5 * dtl(i,j) * Vh11(3,i,j)
        mat(5,5,5,i,j) = mat(5,5,5,i,j) - b5 * dtl(i,j) * Vh11(4,i,j)

!.... I term

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + one
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + one
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + one
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + one
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + one

!.... implicit damping term updated to fourth order

        if (eps_e .ne. zero) then

        mat(1,1,1,i,j) = mat(1,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,2,2,i,j) = mat(1,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,3,3,i,j) = mat(1,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,4,4,i,j) = mat(1,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,5,5,i,j) = mat(1,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1

        mat(2,1,1,i,j) = mat(2,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,2,2,i,j) = mat(2,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,3,3,i,j) = mat(2,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,4,4,i,j) = mat(2,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,5,5,i,j) = mat(2,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3

        mat(4,1,1,i,j) = mat(4,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,2,2,i,j) = mat(4,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,3,3,i,j) = mat(4,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,4,4,i,j) = mat(4,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,5,5,i,j) = mat(4,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4

        mat(5,1,1,i,j) = mat(5,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,2,2,i,j) = mat(5,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,3,3,i,j) = mat(5,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,4,4,i,j) = mat(5,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,5,5,i,j) = mat(5,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5

        end if

        end do loop_i
        end do loop_j

!.... apply boundary treatment to the LHS

        call lhsbt1f( mat, Ah, Dh, Vh11, dtl )

!.... apply boundary conditions to the LHS

        call lhsbc1f( mat, v, vm )

        return
        end

!=============================================================================!
        subroutine lhs2f( mat, Bh, Dh, Vh22, dtl, v)
!
!  Form the LHS for the \eta direction
!
!=============================================================================!
        use global
        use buffer
        use stencil
        implicit none

        real :: mat(5,ndof,ndof,nx,ny), v(ndof,nx,ny)
        real :: Bh(ndof,ndof,nx,ny), Dh(ndof,ndof,nx,ny), Vh22(6,nx,ny)
        real :: dtl(nx,ny)

!.... first derivative operator

        real :: a1, a2, a3, a4, a5
        real :: b1, b2, b3, b4, b5

        integer :: i,j, idof, jdof
!=============================================================================!

!.... fourth-order stencil

        a1 = alfa * ga1 / deta
        a2 = alfa * ga2 / deta
        a3 = alfa * zero / deta
        a4 = alfa * ga3 / deta
        a5 = alfa * ga4 / deta

        b1 = alfa * da1 / deta**2
        b2 = alfa * da2 / deta**2
        b3 = alfa * da3 / deta**2
        b4 = alfa * da4 / deta**2
        b5 = alfa * da5 / deta**2

!$omp parallel do private (i,idof,jdof)
loop_j: do j = 1, ny
loop_i: do i = 1, nx

!.... \hat{B} term

        do idof = 1, ndof
          do jdof = 1, ndof
            mat(1,idof,jdof,i,j) = a1 * dtl(i,j) * Bh(idof,jdof,i,j)
            mat(2,idof,jdof,i,j) = a2 * dtl(i,j) * Bh(idof,jdof,i,j)
            mat(3,idof,jdof,i,j) = a3 * dtl(i,j) * Bh(idof,jdof,i,j)
            mat(4,idof,jdof,i,j) = a4 * dtl(i,j) * Bh(idof,jdof,i,j)
            mat(5,idof,jdof,i,j) = a5 * dtl(i,j) * Bh(idof,jdof,i,j)
          end do
        end do

!.... \hat{V}_{\eta\eta} term

        mat(1,2,2,i,j) = mat(1,2,2,i,j) - b1 * dtl(i,j) * Vh22(1,i,j)
        mat(1,2,3,i,j) = mat(1,2,3,i,j) - b1 * dtl(i,j) * Vh22(5,i,j)
        mat(1,3,2,i,j) = mat(1,3,2,i,j) - b1 * dtl(i,j) * Vh22(6,i,j)
        mat(1,3,3,i,j) = mat(1,3,3,i,j) - b1 * dtl(i,j) * Vh22(2,i,j)
        mat(1,4,4,i,j) = mat(1,4,4,i,j) - b1 * dtl(i,j) * Vh22(3,i,j)
        mat(1,5,5,i,j) = mat(1,5,5,i,j) - b1 * dtl(i,j) * Vh22(4,i,j)

        mat(2,2,2,i,j) = mat(2,2,2,i,j) - b2 * dtl(i,j) * Vh22(1,i,j)
        mat(2,2,3,i,j) = mat(2,2,3,i,j) - b2 * dtl(i,j) * Vh22(5,i,j)
        mat(2,3,2,i,j) = mat(2,3,2,i,j) - b2 * dtl(i,j) * Vh22(6,i,j)
        mat(2,3,3,i,j) = mat(2,3,3,i,j) - b2 * dtl(i,j) * Vh22(2,i,j)
        mat(2,4,4,i,j) = mat(2,4,4,i,j) - b2 * dtl(i,j) * Vh22(3,i,j)
        mat(2,5,5,i,j) = mat(2,5,5,i,j) - b2 * dtl(i,j) * Vh22(4,i,j)

        mat(3,2,2,i,j) = mat(3,2,2,i,j) - b3 * dtl(i,j) * Vh22(1,i,j)
        mat(3,2,3,i,j) = mat(3,2,3,i,j) - b3 * dtl(i,j) * Vh22(5,i,j)
        mat(3,3,2,i,j) = mat(3,3,2,i,j) - b3 * dtl(i,j) * Vh22(6,i,j)
        mat(3,3,3,i,j) = mat(3,3,3,i,j) - b3 * dtl(i,j) * Vh22(2,i,j)
        mat(3,4,4,i,j) = mat(3,4,4,i,j) - b3 * dtl(i,j) * Vh22(3,i,j)
        mat(3,5,5,i,j) = mat(3,5,5,i,j) - b3 * dtl(i,j) * Vh22(4,i,j)

        mat(4,2,2,i,j) = mat(4,2,2,i,j) - b4 * dtl(i,j) * Vh22(1,i,j)
        mat(4,2,3,i,j) = mat(4,2,3,i,j) - b4 * dtl(i,j) * Vh22(5,i,j)
        mat(4,3,2,i,j) = mat(4,3,2,i,j) - b4 * dtl(i,j) * Vh22(6,i,j)
        mat(4,3,3,i,j) = mat(4,3,3,i,j) - b4 * dtl(i,j) * Vh22(2,i,j)
        mat(4,4,4,i,j) = mat(4,4,4,i,j) - b4 * dtl(i,j) * Vh22(3,i,j)
        mat(4,5,5,i,j) = mat(4,5,5,i,j) - b4 * dtl(i,j) * Vh22(4,i,j)

        mat(5,2,2,i,j) = mat(5,2,2,i,j) - b5 * dtl(i,j) * Vh22(1,i,j)
        mat(5,2,3,i,j) = mat(5,2,3,i,j) - b5 * dtl(i,j) * Vh22(5,i,j)
        mat(5,3,2,i,j) = mat(5,3,2,i,j) - b5 * dtl(i,j) * Vh22(6,i,j)
        mat(5,3,3,i,j) = mat(5,3,3,i,j) - b5 * dtl(i,j) * Vh22(2,i,j)
        mat(5,4,4,i,j) = mat(5,4,4,i,j) - b5 * dtl(i,j) * Vh22(3,i,j)
        mat(5,5,5,i,j) = mat(5,5,5,i,j) - b5 * dtl(i,j) * Vh22(4,i,j)

!.... I term

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + one
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + one
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + one
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + one
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + one

!.... implicit damping term updated to fourth-order

        if (eps_e .ne. zero) then

        mat(1,1,1,i,j) = mat(1,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,2,2,i,j) = mat(1,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,3,3,i,j) = mat(1,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,4,4,i,j) = mat(1,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1
        mat(1,5,5,i,j) = mat(1,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb1

        mat(2,1,1,i,j) = mat(2,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,2,2,i,j) = mat(2,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,3,3,i,j) = mat(2,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,4,4,i,j) = mat(2,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2
        mat(2,5,5,i,j) = mat(2,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb2

        mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3
        mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb3

        mat(4,1,1,i,j) = mat(4,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,2,2,i,j) = mat(4,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,3,3,i,j) = mat(4,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,4,4,i,j) = mat(4,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4
        mat(4,5,5,i,j) = mat(4,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb4

        mat(5,1,1,i,j) = mat(5,1,1,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,2,2,i,j) = mat(5,2,2,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,3,3,i,j) = mat(5,3,3,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,4,4,i,j) = mat(5,4,4,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5
        mat(5,5,5,i,j) = mat(5,5,5,i,j) + alfa * dtl(i,j) * eps_e * buff(i,j) * fb5

        end if

!.... sponge

        if (ispg .eq. 1) then

          mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j) * spg(i,j)
          mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j) * spg(i,j)

        else if (ispg .ge. 2) then

          mat(3,1,1,i,j) = mat(3,1,1,i,j) + alfa * dtl(i,j) * ( spg(i,j) + spg2(i,j) )
          mat(3,2,2,i,j) = mat(3,2,2,i,j) + alfa * dtl(i,j) * ( spg(i,j) + spg2(i,j) )
          mat(3,3,3,i,j) = mat(3,3,3,i,j) + alfa * dtl(i,j) * ( spg(i,j) + spg2(i,j) )
          mat(3,4,4,i,j) = mat(3,4,4,i,j) + alfa * dtl(i,j) * ( spg(i,j) + spg2(i,j) )
          mat(3,5,5,i,j) = mat(3,5,5,i,j) + alfa * dtl(i,j) * ( spg(i,j) + spg2(i,j) )

        end if

        end do loop_i
        end do loop_j

!.... apply boundary treatment to the LHS

        call lhsbt2f( mat, Bh, Dh, Vh22, spg, spg2, dtl )

!.... apply boundary conditions to the LHS

        call lhsbc2f( mat, v )

        return
        end


      subroutine addafl (n, t, y, ml, mu, pa, m0)
c This subroutine computes the matrix A in full form, adds it to
c pa, and returns the sum in pa.
c It uses nm1 = n - 1 from Common.
c The matrix A is tridiagonal, of order n, with nonzero elements
c (reading across) of  1/6, 4/6, 1/6.
c
      integer i, n, m0, ml, mu, nm1
      double precision t, y, pa, r4d, eodsq, one, four, six,
     1   fact1, fact4
      dimension y(*), pa(m0,8)
      dimension n(1)
      common /test1/ r4d, eodsq, nm1
      data one/1.0d0/, four/4.0d0/, six/6.0d0/
c
c Compute the elements of A.
      fact1 = one/six
      fact4 = four/six
c
c Add the matrix A to the matrix pa (full).
c
      do 110  i = 2, nm1
         pa(i,i+1) = pa(i,i+1) + fact1
         pa(i,i) = pa(i,i) + fact4
         pa(i,i-1) = pa(i,i-1) + fact1
  110    continue
      pa(1,2) = pa(1,2) + fact1
      pa(1,1) = pa(1,1) + fact4
      pa(n(1),n(1)) = pa(n(1),n(1)) + fact4
      pa(n(1),nm1) = pa(n(1),nm1) + fact1
      return
c end of subroutine addafl for the DLSODI demonstration problem.
      end


      SUBROUTINE MATVC2 (Y,X,FILEA,BUF)
C
C     MATVC2 WILL FORM THE PRODUCT X = X + A*Y WHERE A IS A MATRIX
C     AND Y IS A VECTOR
C
C     THIS ROUTINE IS SUITABLE FOR DOUBLE PRECISION OPERATION
C
      INTEGER            FILEA(7)  ,SUB(2)   ,DIAG     ,RDP     ,EOL
      DOUBLE PRECISION   Y(1)      ,X(1)     ,A        ,DA
      DIMENSION          BUF(1)
      COMMON   /ZNTPKX/  A(2)      ,II       ,EOL
C     COMMON   /DESCRP/  LENGTH    ,MAJOR(1)
      COMMON   /NAMES /  RD        ,RDREW    ,WRT      ,WRTREW   ,
     1                   REW       ,NOREW    ,EOFNRW   ,RSP      ,
     2                   RDP       ,CSP      ,CDP      ,SQR      ,
     3                   RECT      ,DIAG     ,IWTRI    ,UPRTRI   ,
     4                   SYM       ,ROW      ,IDENTY
      COMMON   /TRDXX /  IDUM(27)  ,IOPEN
      EQUIVALENCE        (A(1),DA)
      DATA      SUB   /  4HMATV, 4HC2   /
C
      IF (FILEA(1) .EQ. 0) RETURN
      NCOL = FILEA(2)
      IF (FILEA(4) .EQ. IDENTY) GO TO 60
      IF (IOPEN .EQ. 1) GO TO 5
      CALL OPEN (*90,FILEA(1),BUF,RDREW)
    5 CALL FWDREC (*100,FILEA(1))
      IF (FILEA(4) .EQ. DIAG) GO TO 40
C
C     MATRIX IS FULL
C
      DO 30 I = 1,NCOL
      IF (Y(I) .EQ. 0.0D0) GO TO 20
      CALL INTPK (*30,FILEA(1),0,RDP,0)
   10 CALL ZNTPKI
      X(II) = DA*Y(I) + X(II)
      IF (EOL) 30,10,30
   20 CALL FWDREC (*100,FILEA(1))
   30 CONTINUE
      GO TO 80
C
C     MATRIX IS DIAGONAL
C
   40 CALL INTPK (*80,FILEA(1),0,RDP,0)
   50 CALL ZNTPKI
      X(II) = Y(II)*DA +X(II)
      IF (EOL) 80,50,80
C
C     MATRIX IS THE IDENTITY
C
   60 DO 70 I = 1,NCOL
   70 X(I) = Y(I) + X(I)
      RETURN
C
   80 CALL REWIND (FILEA(1))
      IF (IOPEN .EQ. 0) CALL CLOSE (FILEA(1),REW)
      RETURN
C
   90 NO = -1
      GO TO 110
  100 NO = -2
  110 CALL MESAGE (NO,FILEA(1),SUB(1))
      RETURN
      END


! { dg-do compile }
! { dg-options "-Winteger-division" }
program main
  print *,10**(-3) ! { dg-warning "Negative exponent of integer has zero result" }
end program main


use LinearSolverClass

type(LinearSolver_) :: solver

! 2 unknowns for 1st domain, 2 unknowns for 2nd domain
call solver%init(NumberOfNode=(/ 2, 2 /), DOF = 1 )
! ( 1,  1  1, 1 )(x1) = (0)
! ( 1,  1  1, -1)(x2) = (4)
! ( 1,  1  -1, 1)(x3) = (-4)
! ( 1,  -1  1, 1)(x4) = (2)

! ix (x1) = 1

call solver%set(low=1,column=1,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=1)
call solver%set(low=2,column=1,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=2)
call solver%set(low=2,column=2,entryvalue=-1.0d0,row_DomainID=2,column_DomainID=1)
call solver%set(low=1,column=2,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=1)
call solver%set(low=1,column=2,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=2)
call solver%set(low=2,column=2,entryvalue=-1.0d0,row_DomainID=1,column_DomainID=2)
call solver%set(low=2,column=1,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=1)
call solver%set(low=1,column=1,entryvalue=-1.0d0,row_DomainID=2,column_DomainID=2)
call solver%set(low=2,column=1,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=1)
call solver%set(low=2,column=2,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=1)
call solver%set(low=1,column=1,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=2)
call solver%set(low=2,column=1,entryvalue= 1.0d0,row_DomainID=1,column_DomainID=2)
call solver%set(low=1,column=1,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=1)
call solver%set(low=1,column=2,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=1)
call solver%set(low=1,column=2,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=2)
call solver%set(low=2,column=2,entryvalue= 1.0d0,row_DomainID=2,column_DomainID=2)

call solver%set(low=1,entryvalue= 0.0d0,row_DomainID=1)
call solver%set(low=2,entryvalue= 4.0d0,row_DomainID=1)
call solver%set(low=1,entryvalue=-4.0d0,row_DomainID=2)
call solver%set(low=2,entryvalue= 2.0d0,row_DomainID=2)

call solver%fix(nodeid=1,entryvalue= 1.0d0,row_DomainID=1)

call solver%solve("BiCGSTAB")

call print( reshape(solver%val(:),4,4) )

print *, solver%Index_I(:)
print *, solver%Index_J(:)
print *, solver%row_Domain_ID(:)
print *, solver%column_Domain_ID(:)

print *, solver%b(:)
print *, solver%b_Index_J(:)
print *, solver%b_Domain_ID(:)

! (x1) = (1)
! (x2) = (-1)
! (x3) = (2)
! (x4) = (-2)

print *, "ans      :",solver%x(:)
print *, "true ans :",1.0d0,-1.0d0,2.0d0,-2.0d0
print *, "L2 norm : ",dot_product( solver%x-(/1.0d0,-1.0d0,2.0d0,-2.0d0/), solver%x-(/1.0d0,-1.0d0,2.0d0,-2.0d0/)  )

end


      PROGRAM CCPCIR
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (M=30,N=30,LRWK=3500,LIWK=3500,LZDT=2000)
      PARAMETER (THETMN=25.,THETMX=125.,RHOMN=0.5,RHOMX=5.)

      REAL Z(M,N), RWRK(LRWK)
      INTEGER IWRK(LIWK)
C
C Generate some data to contour
C
      CALL MKDAT (2, Z, M, N)
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Turn off clipping.
C
      CALL GSCLIP (0)
C
C
C Tell CONPACK that the SET call has been done, force it to generate X
C coordinates that are longitudes and Y coordinates that are latitudes,
C turn on mapping to an EZMAP background. Define the out-of-range value
C (returned by MAPTRN for an unprojectable point).
C
      CALL SET (0.05,0.95,0.05,0.95,
     1     -RHOMX,RHOMX,-RHOMX,RHOMX,1)
      CALL CPSETI ('SET - DO SET-CALL FLAG',0)
      CALL CPSETR ('XC1 - X COORDINATE AT INDEX 1',RHOMN)
      CALL CPSETR ('XCM - X COORDINATE AT INDEX M',RHOMX)
      CALL CPSETR ('YC1 - Y COORDINATE AT INDEX 1',THETMN)
      CALL CPSETR ('YCN - Y COORDINATE AT INDEX N',THETMX)
      CALL CPSETI ('MAP - MAPPING FLAG',2)
C
C Initialize the drawing of the first contour plot.
C
      CALL CPRECT (Z,M,M,N,RWRK,LRWK,IWRK,LIWK)
C
C Draw Contours
C
      CALL CPCLDR(Z,RWRK,IWRK)
C
C Close frame
C
      CALL FRAME
C
C Deactivate and close workstation, close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
      STOP
      END

      SUBROUTINE MKDAT(NCTFR,ZDAT,M,N)
C
C Create some data to contour
C
      REAL ZDAT(M,N)
C
C NCTFR is used to generate a random number, ZDAT is the data array
C
      CALL GGDINI (0.,1.,NCTFR,.9)
      ZMIN= 1.E36
      ZMAX=-1.E36
      DO 10 I=1,M
         RLON=.017453292519943*(-180.+360.*REAL(I-1)/REAL(M-1))
         DO 20 J=1,N
            RLAT=.017453292519943*(-90.+180.*REAL(J-1)/REAL(N-1))
            ZDAT(I,J)=GGDPNT(RLAT,RLON)+.5*COS(4.*RLAT)
            ZMIN=MIN(ZMIN,ZDAT(I,J))
            ZMAX=MAX(ZMAX,ZDAT(I,J))
 20      CONTINUE
 10   CONTINUE
      DO 30 I=1,M
         DO 40 J=1,N
            ZDAT(I,J)=((ZDAT(I,J)-ZMIN)/(ZMAX-ZMIN))*130.-50.
 40      CONTINUE
 30   CONTINUE

      RETURN
      END


c*************************************************************************
c                        DRIFT_KEPU_GUESS.F
c*************************************************************************
c Initial guess for solving kepler's equation using universal variables.
c
c             Input:
c                 dt            ==>  time step (real scalor)
c                 r0            ==>  Distance between `Sun' and paritcle
c                                     (real scalor)
c                 mu            ==>  Reduced mass of system (real scalor)
c                 alpha         ==>  energy (real scalor)
c                 u             ==>  angular momentun  (real scalor)
c             Output:
c                 s             ==>  initial guess for the value of
c                                    universal variable
c
c Author:  Hal Levison & Martin Duncan
c Date:    3/12/93
c Last revision: April 6/93

      subroutine drift_kepu_guess(dt,r0,mu,alpha,u,s)

      include '../../swift.inc'

c...  Inputs:
      real*8 dt,r0,mu,alpha,u

c...  Inputs and Outputs:
      real*8 s

c...  Internals:
      integer iflg
      real*8 y,sy,cy,sigma,es
      real*8 x,a
      real*8 en,ec,e

c----
c...  Executable code

        if (alpha.gt.0.0) then
c...       find initial guess for elliptic motion

            if( dt/r0 .le. 0.4)  then
              s = dt/r0 - (dt*dt*u)/(2.0*r0*r0*r0)
	      return
            else
              a = mu/alpha
              en = sqrt(mu/(a*a*a))
              ec = 1.0 - r0/a
              es = u/(en*a*a)
              e = sqrt(ec*ec + es*es)
              y = en*dt - es
	      call orbel_scget(y,sy,cy)
              sigma = dsign(1.d0,(es*cy + ec*sy))
              x = y + sigma*.85*e
              s = x/sqrt(alpha)
	    endif

        else
c...       find initial guess for hyperbolic motion.
	   call drift_kepu_p3solve(dt,r0,mu,alpha,u,s,iflg)
	   if(iflg.ne.0) then
	      s = dt/r0
	   endif
        endif

        return
        end     !   drift_kepu_guess
c-------------------------------------------------------------------


      SUBROUTINE TETRA (TEMPS,PG,IOPT)
C
C     ELEMENT THERMAL LOAD GENERATOR FOR THE TETRAHEDRON SOLID ELEMENT
C
C     LOOKING DOWN ON THIS ELEMENT, GRIDS 1,2,3 ARE THE BASE AND MUST BE
C     LABELED COUNTERCLOCKWISE. GRID 4 MUST BE ABOVE THE PLANE FORMED BY
C     GRIDS 1,2,3 AND CLOSEST TO THIS OBSERVER.
C
C     ECPT FOR THE TETRAHEDRON SOLID ELEMENT
C
C     ECPT( 1) = ELEMENT ID
C     ECPT( 4) = SIL GRID POINT 3
C     ECPT( 5) = SIL GRID POINT 4
C     ECPT( 2) = MATERIAL ID (MAT1 MATERIAL TYPE)
C     ECPT( 3) = SIL GRID POINT 1
C     ECPT( 4) = SIL GRID POINT 2
C     ECPT( 5) = SIL GRID POINT 3
C     ECPT( 6) = SIL GRID POINT 4
C     ECPT( 7) = COORD SYS ID GRID PT 1
C     ECPT( 8) = X1
C     ECPT( 9) = Y1
C     ECPT(10) = Z1
C     ECPT(11) = COORD SYS ID GRID PT 2
C     ECPT(12) = X2
C     ECPT(13) = Y2
C     ECPT(14) = Z2
C     ECPT(15) = COORD SYS ID GRID PT 3
C     ECPT(16) = X3
C     ECPT(17) = Y3
C     ECPT(18) = Z3
C     ECPT(19) = COORD SYS ID GRID PT 4
C     ECPT(20) = X4
C     ECPT(21) = Y4
C     ECPT(22) = Z4
C     ECPT(23) = ELEMENT TEMPERATURE
C
      INTEGER         NECPT(2) ,OUT
      REAL            TEMPS(4) ,PG(6)   ,P(6)    ,C(72)    ,G(36)    ,
     1                H(16)    ,CTG(18) ,NU      ,ALFA(6)  ,TEMP(12)
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ SYSBUF   ,OUT
      COMMON /TRIMEX/ ECPT(23)
      COMMON /MATIN / MATID    ,INFLAG  ,ELTEMP
      COMMON /MATOUT/ E        ,GG      ,NU      ,RHO       ,ALPHA   ,
     1                TSUB0    ,GSUBE   ,SIGT    ,SIGC      ,SIGS
      EQUIVALENCE     (NECPT(1),ECPT(1))
C
C     FILL THE 4 X 4 H MATRIX.
C
      H( 1) = 1.0
      H( 2) = ECPT( 8)
      H( 3) = ECPT( 9)
      H( 4) = ECPT(10)
      H( 5) = 1.0
      H( 6) = ECPT(12)
      H( 7) = ECPT(13)
      H( 8) = ECPT(14)
      H( 9) = 1.0
      H(10) = ECPT(16)
      H(11) = ECPT(17)
      H(12) = ECPT(18)
      H(13) = 1.0
      H(14) = ECPT(20)
      H(15) = ECPT(21)
      H(16) = ECPT(22)
C
C     INVERT H AND GET THE DETERMINANT
C
      ISING = 0
C
      CALL INVERS (4,H(1),4,DUM,0,HDETER,ISING,TEMP(1))
C
C     IF THE MATRIX IS SINGULAR TETRAHEDRON IS BAD
C
      HDETER = ABS(HDETER)
      IF (ISING .NE. 2) GO TO 200
      WRITE  (OUT,150) UFM,NECPT(1)
  150 FORMAT (A23,' 4002, MODULE SSG1 DETECTS BAD OR REVERSE GEOMETRY ',
     1       'FOR ELEMENT ID =',I9)
      GO TO 900
C
C     GET THE MATERIAL DATA AND FILL THE 6X6 G MATERIAL STRESS-STRAIN
C     MATRIX.
C
  200 INFLAG = 1
      MATID  = NECPT(2)
      ELTEMP = ECPT(23)
      CALL MAT (NECPT(1))
      DO 210 I = 1,36
  210 G(I)  = 0.0
      TEMP1 = (1.0+NU)*(1.0-2.0*NU)
      IF (TEMP1 .NE. 0.0) GO TO 240
      WRITE  (OUT,230) UFM,MATID,ECPT(1)
  230 FORMAT (A23,' 4003, AN ILLEGAL VALUE OF -NU- HAS BEEN SPECIFIED ',
     1       'UNDER MATERIAL ID =',I9,' FOR ELEMENT ID =',I9)
      GO TO 900
  240 G( 1) = E*(1.0-NU)/TEMP1
      G( 8) = G(1)
      G(15) = G(1)
      G( 2) = E*NU/TEMP1
      G( 3) = G(2)
      G( 7) = G(2)
      G( 9) = G(2)
      G(13) = G(2)
      G(14) = G(2)
      G(22) = GG
      G(29) = GG
      G(36) = GG
C
C     FILL 4 C-MATRICES. (6X3) EACH.
C
      DO 400 I = 1,72
  400 C(I) = 0.0
      DO 500 I = 1,4
      J = 18*I - 18
      C(J+ 1) = H(I+ 4)
      C(J+ 5) = H(I+ 8)
      C(J+ 9) = H(I+12)
      C(J+11) = H(I+12)
      C(J+12) = H(I+ 8)
      C(J+13) = H(I+12)
      C(J+15) = H(I+ 4)
      C(J+16) = H(I+ 8)
      C(J+17) = H(I+ 4)
  500 CONTINUE
C
C     DIVIDE DETERMINANT BY 6.0, AND BY AN ADDITIONAL 2.0 IF A SUB-TETRA
C     FOR THE HEXA-10 ELEMENT.
C
      IF (IOPT) 602,601,602
  601 HDETER = HDETER/6.0
      GO TO 610
  602 HDETER = HDETER/12.0
C
C     INTRODUCE TBAR AND ALPHA
C
  610 HDETER = HDETER*(0.25*(TEMPS(1)+TEMPS(2)+TEMPS(3)+TEMPS(4))-TSUB0)
     1         *ALPHA
C
C     FILL ALPHA VECTOR
C
      ALFA(1) = HDETER
      ALFA(2) = HDETER
      ALFA(3) = HDETER
      ALFA(4) = 0.0
      ALFA(5) = 0.0
      ALFA(6) = 0.0
C
C     LOOP FOR THE FOUR GRID POINTS
C
      DO 800 I = 1,4
      CALL GMMATS (C(18*I-17),6,3,1, G(1),6,6,0, CTG(1))
      CALL GMMATS (CTG(1),3,6,0, ALFA(1),6,1,0, P(1))
C
C     TRANSFORM TO GLOBAL
C
      P(4) = 0.0
      P(5) = 0.0
      P(6) = 0.0
      K    = 4*I + 3
      IF (NECPT(K) .NE. 0) CALL BASGLB (P(1),P(1),NECPT(K+1),NECPT(K))
C
C     INSERT LOAD VECTOR FOR GRID POINT
C
      L = NECPT(I+2) - 1
      DO 790 J = 1,3
      L = L + 1
      PG(L) = PG(L) + P(J)
  790 CONTINUE
  800 CONTINUE
      RETURN
C
  900 CALL MESAGE (-61,0,0)
      RETURN
      END


!!
!> @brief fits a NN potential to scattering data
!!
!! Uses the Levenberg Marquardt algorithm to adjust the parameters of a NN interaction and
!! reproduce experimental data collected since 1954.
!!
!! @author Rodrigo Navarro Perez
!!
program nn_fit
use precisions, only : dp
use delta_shell, only : nn_model
use exp_data, only : nn_experiment!, read_database, init_ex_em_amplitudes
use optimization, only: lavenberg_marquardt, setup_optimization
use string_functions, only : mask_to_string
use read_write, only : write_optimization_results
implicit none

type(nn_model) :: model
type(nn_experiment), allocatable, dimension(:) :: database
real(dp), allocatable :: covariance(:,:)
real(dp), allocatable, dimension(:) :: parameters
real(dp), allocatable, dimension(:) :: initial_parameters
logical, allocatable, dimension(:) :: mask
logical :: save_results
character(len=1024) :: output_name
real(dp) :: chi2
integer :: n_points

call setup_optimization(model, parameters, mask, database, save_results, output_name)
allocate(initial_parameters, source=parameters) !make a copy of the initial parameters to later save them
call lavenberg_marquardt(database, mask, model, parameters, n_points, chi2, covariance)
if (save_results) then
    call write_optimization_results(model, initial_parameters, parameters, mask, chi2, n_points, &
        covariance, output_name)
endif
end program nn_fit