      SUBROUTINE BARSTW(A,NA,B,NB,C,NC,IOP,SYM,EPSA,EPSB,DUMMY)
C
C   PURPOSE:
C      Solve the matrix equation AX + XB = C, where A and B are real
C      constant matrices of dimension n x n and m x m.  The matrix C is
C      real constant and of dimension n x m.  Assumed that
C              A(i) + B(i) # 0  (i=1,2,...,n;  j=1,2,...,m)
C      where A(i) and B(i) are eigenvalues of A and B.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C. Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, pp. 820-826.
C
C   Subroutines employed by BARSTW: ATXPXA, AXPXB, EQUATE, JUXTR, LNCNT,
C      NULL, PRNT, TRANP
C   Subroutines employing BARSTW: CSTAB, DSTAB, EXMDFL, RICNWT, VARANC
C
      IMPLICIT REAL*8 (A-H,O-Z)
      DIMENSION A(1),B(1),C(1),DUMMY(1)
      DIMENSION NA(2),NB(2),NC(2),NDUM1(2),NDUM2(2),NDUM3(2),NDUM4(2)
      LOGICAL  SYM
C
      IF ( IOP .EQ. 0 )  GO TO 250
      IF(SYM) GO TO 100
      CALL LNCNT(3)
      WRITE(6,50)
   50 FORMAT(//' LINEAR EQUATION SOLVER     AX + XB = C ')
      CALL PRNT(A,NA,' A  ',1)
      CALL PRNT(B,NB,' B  ',1)
      GO TO 200
  100 CONTINUE
      CALL LNCNT(3)
      WRITE(6,150)
  150 FORMAT(//' LINEAR EQUATION SOLVER  ( B TRANSPOSE )X + XB = C')
      CALL TRANP(A,NA,DUMMY,NDUM1)
      CALL PRNT(DUMMY,NDUM1,' B  ',1)
  200 CONTINUE
      CALL PRNT(C,NC,' C  ',1)
C
  250 CONTINUE
      CALL EQUATE(A,NA,DUMMY,NDUM1)
      N1=(NA(1)**2)+1
      N2=N1+NA(1)-1
      DO 300I=N1,N2
      DUMMY(I)=0.0
  300 CONTINUE
C
      NDUM1(2)=NDUM1(2)+1
      NDUM2(1)=1
      NDUM2(2)=NDUM1(2)
      N1=NDUM1(1)*NDUM1(2)+1
      CALL NULL(DUMMY(N1),NDUM2)
      LU=(NA(1)+1)**2 + 1
      CALL JUXTR(DUMMY,NDUM1,DUMMY(N1),NDUM2,DUMMY(LU),NDUM3)
      CALL EQUATE(DUMMY(LU),NDUM3,DUMMY,NDUM1)
      N=NA(1)+1
C
      IF(SYM ) GO TO 500
C
      CALL EQUATE(B,NB,DUMMY(LU),NDUM2)
      M1=LU+NB(1)**2
      M2=M1+NB(1)-1
      DO400I=M1,M2
      DUMMY(I)=0.0
  400 CONTINUE
C
      NDUM2(2)=NDUM2(2)+1
      NDUM3(1)=1
      NDUM3(2)=NDUM2(2)
      M1=NDUM2(1)*NDUM2(2)+LU
      CALL NULL(DUMMY(M1),NDUM3)
      M2=LU+(NB(1)+1)**2
      CALL JUXTR(DUMMY(LU),NDUM2,DUMMY(M1),NDUM3,DUMMY(M2),NDUM4)
      CALL EQUATE(DUMMY(M2),NDUM4,DUMMY(LU),NDUM2)
      M=NB(1)+ 1
      LNB = LU
      LU = LU + (NB(1)+1)**2
      LV = LU +  NA(1)**2
      CALL AXPXB(DUMMY,DUMMY(LU),NA(1),N,NA(1),DUMMY(LNB),DUMMY(LV),NB(1
     1),M,NB(1),C,NC(1),EPSA,EPSB,NFAIL)
      GO TO 600
C
  500 CONTINUE
      CALL TRANP(DUMMY,NDUM1,DUMMY(LU),NDUM2)
      CALL EQUATE(DUMMY(LU),NDUM2,DUMMY,NDUM1)
      CALL ATXPXA(DUMMY,DUMMY(LU),C,NA(1),N,NA(1),NC(1),EPSA,NFAIL)
C
  600 CONTINUE
      IF(NFAIL .EQ. 0 ) GO TO 700
      CALL LNCNT(3)
      WRITE(6,650)
  650 FORMAT(//' IN BARSTW, EITHER THE SUBROUTINE AXPXB  OR  ATXPXA  WAS
     1 UNABLE TO REDUCE A OR B TO SCHUR FORM ')
      RETURN
C
  700 CONTINUE
C
      IF( IOP .NE. 0 )  CALL PRNT(C,NC,'  X ',1)
      RETURN
      END


       PROGRAM CALIBPDS1
C++:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
C Programs CALIBPDS1 and CALIBPDS2 to transform densities into
C intensities with a calibrated profile.
C This program computes a curve Log(Intensity) versus Log(Density) for PDS scans
C when 2 profiles of the same object are available : one from a calibrated plate
C or CCD picture, and the other from the scan. Then fits interactively
C a polynomial to this curve.
C
C Note : To avoid possible negative values in the raw profile
C give a negative value for the sky level of this file (Check this before
C running this program).
C
C JLP  Version of 15-12-86
C--:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
	PARAMETER (IDIM=2000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 RAD1(IDIM),RAD2(IDIM),YY1(IDIM),YY2(IDIM)
        REAL*8 PROF1(IDIM),PROF2(IDIM),WORK1(IDIM),WORK2(IDIM)
        REAL*8 K1(IDIM),SPLINE1(IDIM),K2(IDIM),SPLINE2(IDIM)
	CHARACTER ANS*1,IN_FILE*40,IN_COMMENTS*80

10	FORMAT(A)

C-------------------------------------------------------------------------
C  Reads the calibrated profile.
C
	PRINT *,' CALIBRATED PROFILE :'
	CALL DREADFILE(RAD1,PROF1,NPTS1,WORK1,WORK2,IWORK,IDIM,
     1                 IN_FILE,IN_COMMENTS,0)
	PRINT *,' CONSTANT YOU WANT TO SUBTRACT TO THE INPUT PROFILE',
     1	' (SKY LEVEL) :'
	READ(5,*) SKY1

	DO I=1,NPTS1
	PROF1(I)=PROF1(I)-SKY1
	PRINT *,RAD1(I),PROF1(I)
	END DO

	PRINT 112,NPTS1,RAD1(1),RAD1(NPTS1)
112	FORMAT(2X,I5,' POINTS RECEIVED',/,' PROFILE FROM ',
     1	F12.3,' ARCSECONDS TO ',F12.3,' ARCSECONDS',/)

C Either interpolation or fit :
C	CALL SPLINELOG_INTER(RAD1,PROF1,NPTS1,SPLINE1,NCAP71,K1)
	CALL SPLINELOGFIT(RAD1,PROF1,NPTS1,SPLINE1,NCAP71,K1)

C-------------------------------------------------------------------------
C  Reads the density profile.
C
	PRINT *,' DENSITY PROFILE :'
	CALL DREADFILE(RAD2,PROF2,NPTS2,WORK1,WORK2,IWORK,IDIM,
     1                 IN_FILE,IN_COMMENTS,0)
	PRINT *,' CONSTANT YOU WANT TO SUBTRACT TO THE INPUT PROFILE',
     1	' (SKY LEVEL) :'
	READ(5,*) SKY2

	DO I=1,NPTS2
	PROF2(I)=PROF2(I)-SKY2
	END DO

	PRINT 112,NPTS2,RAD2(1),RAD2(NPTS2)

C Either interpolation or fit :
C	CALL SPLINELOG_INTER(RAD2,PROF2,NPTS2,SPLINE2,NCAP72,K2)
	CALL SPLINELOGFIT(RAD2,PROF2,NPTS2,SPLINE2,NCAP72,K2)

C-------------------------------------------------------------------------
C Entering the boundaries :
	WRITE (6,339)
339	FORMAT(' Enter start radius and end radius for the fit: ')
	READ (5,*) RSTART,REND

C Entering the number of points for the calibration
	PRINT *,' NUMBER OF POINTS FOR THE CALIBRATION ? (MINI=20)'
	READ(5,*) NPOINT
	STEP=(REND-RSTART)/FLOAT(NPOINT)

	DO I=1,NPOINT
	RADIUS=RSTART+STEP*FLOAT(I)
	XX=DLOG10(RADIUS)
	IFAIL=1
	CALL E02BBF(NCAP71,K1,SPLINE1,XX,YY1(I),IFAIL)
	IF(IFAIL.NE.0)PRINT 576,IFAIL
576	FORMAT(' WARNING : IN E02BBF  IFAIL=',I3)
	IFAIL=1
	CALL E02BBF(NCAP72,K2,SPLINE2,XX,YY2(I),IFAIL)
	IF(IFAIL.NE.0)PRINT 576,IFAIL
	END DO

	CALL INTERACTIVE_FIT(YY2,YY1,NPOINT)

	STOP
	END
C---------------------------------------------------------------------
C************************************************************
C Subroutine INTERACTIVE_FIT
C to fit a polynomial to the curve (XX,YY)
C
	SUBROUTINE INTERACTIVE_FIT(XX,YY,NPOINT)

	PARAMETER (IDIM=2000)
	IMPLICIT DOUBLE PRECISION (A-H,O-Z)
	REAL*8 XXOUT(IDIM),YYOUT(IDIM),XX(IDIM),
     1	YY(IDIM)
	REAL*8 XCOEF(10),SDEV(10),ERR,VVY
	REAL*4 XOUT,YOUT
	REAL*4 XPLOT(IDIM),YPLOT(IDIM),YPLOT2(IDIM)
	CHARACTER ANS*1,TITLE*40,CHAR1*30,CHAR2*30,PLOTDEV*32

C Common block with NEWPLOT:
	COMMON /STR_OUTPUT/XOUT(200),YOUT(200),NOUT

10	FORMAT(A)

C DISPLAYING THE INPUT PROFILE AND FITTING A POLYNOMIAL
	PRINT *,' SET UP 4040/4010, TYPE "RETURN" WHEN READY'
	READ(5,10) ANS
C

C Conversion into real*4 for the display
	DO I=1,NPOINT
	XPLOT(I)=XX(I)
	YPLOT(I)=YY(I)
	END DO

	CHAR1='LOG10(DENSITY)'
	CHAR2='LOG10(INTENSITY)'
	PLOTDEV='TEKTRO'	!TEKTRONIX
	TITLE='Enter the points for the calibration'
	CALL DISPLAY1(XPLOT,YPLOT,1,NPOINT,
     1	CHAR1,CHAR2,TITLE,PLOTDEV)

C Conversion into real*8
	DO I=1,NOUT
	XXOUT(I)=XOUT(I)
	YYOUT(I)=YOUT(I)
	END DO

C Fitting a polynomial
205	PRINT *,' ENTER THE DEGREE OF THE POLYNOMIAL :'
	READ(5,*) KDEGREE
	CALL POLYFIT(XXOUT,YYOUT,NOUT,KDEGREE,XCOEF,SDEV,ERR)
	PRINT *,NOUT,' POINTS'

	DO I=1,NPOINT
	CALL CALPOLY(XX(I),VVY,XCOEF,KDEGREE)
	YPLOT2(I)=SNGL(VVY)
	END DO

C Displaying the fit
	PRINT *,'DISPLAYING THE BACKGROUND, NOW...'
	CHAR1='LOG10(DENSITY)'
	CHAR2='LOG10(INTENSITY)'
	PRINT *,' TITLE ?'
	READ(5,10) TITLE
	CALL DISPLAY2(XPLOT,YPLOT,1,NPOINT,XPLOT,YPLOT2,
     1	1,NPOINT,CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',' ',' ')

208	PRINT 209
209	FORMAT(' DO YOU WANT TO ',
     1	'CHANGE THE DEGREE OF THE POLYNOMIAL ? (N)')
	READ(5,10) ANS

	IF(ANS.EQ.'Y'.OR.ANS.EQ.'y')GO TO 205

	RETURN
	END
C-------------------------------------------------------------------
c	include 'jlpsub:project.for'
C In POLYFIT.FOR there is CALPOLY and POLYFIT
c	include 'jlpsub:polyfit.for'


! ****************************************************
!    setsval.f90 for smadrzmet
!  12  Feb. 2016    written by D.KAWATA
! ****************************************************

subroutine setsval(np,xp,yp,hm,nx,ny,xl,xh,yl,yh,fval)
      use gcdp_const
      use gcdp_system
      use gcdp_kernel

      implicit none
      include 'mpif.h'

      integer,intent(in) :: np,nx,ny
      double precision,intent(in) :: hm,xl,xh,yl,yh
      double precision,intent(in) :: xp(0:np-1),yp(0:np-1)
      double precision,intent(inout) :: fval(0:nx-1,0:ny-1)

      integer ierr
! parallerise along x-axis
      integer ixs,ixe
      double precision dx,dy,xmesh,ymesh
! for work
      integer i,j,pn
      integer is
      double precision xij,yij,rij,hsi,ihsi,s,wij,sdencgs
! mesh data point
      integer ixm0,ixm1,iym0,iym1
      double precision xsm,xem,ysm,yem
      double precision xpm,ypm,zpm
! for MPI work
      integer ntm,nc,nct
      double precision,allocatable :: tdvs(:),tdvr(:)

!     write(6,*) ' xl,xh,yl,yh=',xl,xh,yl,yh

! assign x,y position
      dx=(xh-xl)/dble(nx)
      dy=(yh-yl)/dble(ny)

! at the start and end point of mesh for x and y
      xsm=xl+0.5d0*dx
      xem=xh-0.5d0*dx
      ysm=yl+0.5d0*dy
      yem=yh-0.5d0*dy

      nc=0
      if(myrank.eq.0) then
        write(6,*) ' np in setsval=',np
      endif
!        write(6,*) myrank,hm,xl,xh,yl,yh
      do pn=0,np-1
! exclude particles obviously not contributing
        if(yp(pn).gt.ysm-hm.and.yp(pn).lt.yem+hm) then
          if(xp(pn).gt.xsm-hm.and.xp(pn).lt.xem+hm) then
            nc=nc+1
! output contributing particles
!            write(60,'(2(1pE13.5))') xp(pn),yp(pn)
! x
            ixm0=(xp(pn)-hm-xsm)/dx
            if(ixm0.lt.0) then
              ixm0=0
            else if(ixm0.gt.nx-1) then
              ixm0=nx-1
            endif
            ixm1=(xp(pn)+hm-xsm)/dx
            if(ixm1.lt.0) then
              ixm1=0
            else if(ixm1.gt.nx-1) then
              ixm1=nx-1
            endif
! y
            iym0=(yp(pn)-hm-ysm)/dy
            if(iym0.lt.0) then
              iym0=0
            else if(iym1.gt.ny-1) then
              iym0=ny-1
            endif
            iym1=(yp(pn)+hm-ysm)/dy
            if(iym1.lt.0) then
              iym1=0
            else if(iym1.gt.ny-1) then
              iym1=ny-1
            endif
            do j=iym0,iym1
              ypm=yl+0.5d0*dy+dble(j)*dy
              do i=ixm0,ixm1
                xpm=xl+0.5d0*dx+dble(i)*dx
! *** smooth the values ***
                xij = xp(pn)-xpm
                yij = yp(pn)-ypm
                rij=dsqrt(xij**2+yij**2)
                hsi=hm
                if(rij.lt.hsi) then
                  ihsi=1.0d0/hsi
                  s=rij*ihsi
                  is=int(s*dnktab)
                  if(is.lt.0) then
                    is=0
                  else if(is.ge.NKTAB) then
                    is=NKTAB-1
                  endif
                  wij=w_tb(is)+(w_tb(is+1)-w_tb(is))*(s-s_tb(is))*dnktab
! 2D
                  wij=wij*(ihsi**2)
                  fval(i,j)=fval(i,j)+wij
                endif
              enddo
            enddo
          endif
        endif
      enddo
      nct=0
      call MPI_ALLREDUCE(nc,nct,1,MPI_INTEGER,MPI_SUM,MPI_COMM_WORLD,ierr)
      if(myrank.eq.0) then
        write(6,*) ' # of contributing particles=',nct
      endif
!      close(60)

! sum up
      if(nprocs.gt.1) then
        ntm=nx*ny
        allocate(tdvs(0:ntm-1))
        allocate(tdvr(0:ntm-1))

        nc=0
        do j=0,ny-1
          do i=0,nx-1
            tdvs(nc)=fval(i,j)
            tdvr(nc)=0.0d0
            nc=nc+1
          enddo
        enddo
        call MPI_ALLREDUCE(tdvs,tdvr,ntm,MPI_DOUBLE_PRECISION &
         ,MPI_SUM,MPI_COMM_WORLD,ierr)
        nc=0
        do j=0,ny-1
          do i=0,nx-1
            fval(i,j)=tdvr(nc)
            nc=nc+1
          enddo
        enddo

        deallocate(tdvr)
        deallocate(tdvs)

      endif

end subroutine


      SUBROUTINE TB01WD( N, M, P, A, LDA, B, LDB, C, LDC, U, LDU,
     $                   WR, WI, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the system state matrix A to an upper real Schur form
C     by using an orthogonal similarity transformation A <-- U'*A*U and
C     to apply the transformation to the matrices B and C: B <-- U'*B
C     and C <-- C*U.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e. the order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs, or of columns of B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix U' * A * U in real Schur form. The elements
C             below the first subdiagonal are set to zero.
C             Note:  A matrix is in real Schur form if it is upper
C                    quasi-triangular with 1-by-1 and 2-by-2 blocks.
C                    2-by-2 blocks are standardized in the form
C                             [  a  b  ]
C                             [  c  a  ]
C                    where b*c < 0. The eigenvalues of such a block
C                    are a +- sqrt(bc).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix U' * B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * U.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     U       (output) DOUBLE PRECISION array, dimension (LDU,N)
C             The leading N-by-N part of this array contains the
C             orthogonal transformation matrix used to reduce A to the
C             real Schur form. The columns of U are the Schur vectors of
C             matrix A.
C
C     LDU     INTEGER
C             The leading dimension of array U.  LDU >= max(1,N).
C
C     WR, WI  (output) DOUBLE PRECISION arrays, dimension (N)
C             WR and WI contain the real and imaginary parts,
C             respectively, of the computed eigenvalues of A. The
C             eigenvalues will be in the same order that they appear on
C             the diagonal of the output real Schur form of A. Complex
C             conjugate pairs of eigenvalues will appear consecutively
C             with the eigenvalue having the positive imaginary part
C             first.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.  LWORK >= 3*N.
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, the QR algorithm failed to compute
C                   all the eigenvalues; elements i+1:N of WR and WI
C                   contain those eigenvalues which have converged;
C                   U contains the matrix which reduces A to its
C                   partially converged Schur form.
C
C     METHOD
C
C     Matrix A is reduced to a real Schur form using an orthogonal
C     similarity transformation A <- U'*A*U. Then, the transformation
C     is applied to the matrices B and C: B <-- U'*B and C <-- C*U.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 10N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, March 1998.
C     Based on the RASP routine SRSFDC.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Orthogonal transformation, real Schur form, similarity
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDU, LDWORK, M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), U(LDU,*),
     $                 WI(*), WR(*)
C     .. Local Scalars ..
      INTEGER          I, LDWP, SDIM
      DOUBLE PRECISION WRKOPT
C     .. Local Arrays ..
      LOGICAL          BWORK( 1 )
C     .. External Functions ..
      LOGICAL          LSAME, SELECT
      EXTERNAL         LSAME, SELECT
C     .. External Subroutines ..
      EXTERNAL         DCOPY, DGEES, DGEMM, DGEMV, DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        DBLE, MAX
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check input parameters.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -9
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -11
      ELSE IF( LDWORK.LT.3*N ) THEN
         INFO = -15
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Reduce A to real Schur form using an orthogonal similarity
C     transformation A <- U'*A*U, accumulate the transformation in U
C     and compute the eigenvalues of A in (WR,WI).
C
C     Workspace:  need   3*N;
C                 prefer larger.
C
      CALL DGEES( 'Vectors', 'Not ordered', SELECT, N, A, LDA, SDIM,
     $            WR, WI, U, LDU, DWORK, LDWORK, BWORK, INFO )
      WRKOPT = DWORK( 1 )
      IF( INFO.NE.0 )
     $    RETURN
C
C     Apply the transformation: B <-- U'*B.
C
      IF( LDWORK.LT.N*M ) THEN
C
C        Not enough working space for using DGEMM.
C
         DO 10 I = 1, M
            CALL DCOPY( N, B(1,I), 1, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO,
     $                  B(1,I), 1 )
   10    CONTINUE
C
      ELSE
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
         CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, U, LDU,
     $               DWORK, N, ZERO, B, LDB )
         WRKOPT = MAX( WRKOPT, DBLE( N*M ) )
      END IF
C
C     Apply the transformation: C <-- C*U.
C
      IF( LDWORK.LT.N*P ) THEN
C
C        Not enough working space for using DGEMM.
C
         DO 20 I = 1, P
            CALL DCOPY( N, C(I,1), LDC, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, U, LDU, DWORK, 1, ZERO,
     $                  C(I,1), LDC )
   20    CONTINUE
C
      ELSE
         LDWP = MAX( 1, P )
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK, LDWP )
         CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE,
     $               DWORK, LDWP, U, LDU, ZERO, C, LDC )
         WRKOPT = MAX( WRKOPT, DBLE( N*P ) )
      END IF
C
      DWORK( 1 ) = WRKOPT
C
      RETURN
C *** Last line of TB01WD ***
      END


! ======================================================================
! PROGRAM MOMENTUMCOLLECT
! ----------------------------------------------------------------------
      PROGRAM MOMENTUMCOLLECT
      IMPLICIT NONE

      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: NUMBER_OF_TIME_STEPS
      INTEGER :: NUMBER_OF_TIME_STEPS_BEFORE_WRITE
      INTEGER :: START_FILE
      INTEGER :: END_FILE
      INTEGER :: OUTPUT_FILE
      INTEGER :: START_MOMENTUM
      INTEGER :: END_MOMENTUM

      REAL :: RADIUS
      REAL :: GAMMA_FACTOR

      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_FILE
      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_MOMENTUM
      INTEGER :: MOMENTUM
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE
      REAL :: TIME_STEP_SIZE
      REAL :: TIME
      REAL :: ABSFC
      REAL :: REALFC
      REAL :: IMAGFC

      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_TIME_STEPS_BEFORE_WRITE

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_FILE

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_FILE

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) OUTPUT_FILE

      CALL GET_COMMAND_ARGUMENT(7,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(8,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(9,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

      CALL GET_COMMAND_ARGUMENT(10,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) GAMMA_FACTOR

      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)
      TIME_STEP_SIZE = (RADIUS*ANGULAR_GRID_SPACING_SIZE)**2/(2.0E0*GAMMA_FACTOR)
      OPEN(UNIT=OUTPUT_FILE,ACTION='WRITE',FORM='FORMATTED',STATUS='NEW')
      DO CURRENT_FILE = START_FILE, END_FILE
         TIME = FLOAT(CURRENT_FILE-START_FILE)*FLOAT(NUMBER_OF_TIME_STEPS_BEFORE_WRITE)*TIME_STEP_SIZE
         OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='FORMATTED',STATUS='OLD')
         DO CURRENT_MOMENTUM = START_MOMENTUM, END_MOMENTUM
            READ(CURRENT_FILE,*) MOMENTUM, ABSFC, REALFC, IMAGFC
            WRITE(OUTPUT_FILE,*) TIME, MOMENTUM, ABSFC
         ENDDO
         CLOSE(UNIT=CURRENT_FILE,STATUS='KEEP')
         WRITE(OUTPUT_FILE,*) ' '
      ENDDO
      CLOSE(UNIT=OUTPUT_FILE,STATUS='SAVE')

      STOP
      ENDPROGRAM MOMENTUMCOLLECT
! =========================================================================


      subroutine solarza(I,IM,sind,cosd,sinl,cosl,tofday,day,rotper,
     *                   ndt,dt,acosz)

!     Legacy Mars GCM v24
!     Mars Climate Modeling Center
!     NASA Ames Research Center

!     Compute the cosine of the solar zenith angle.  Take into account
!     if the sun rises or sets during the time period under
!     consideration.

      use constants_h, only: PI

      implicit none

      integer :: i, im
      real*8  :: x3, x6, sind, sinl, cosd, cosl, tofday, day, rotper
      real*8  :: dt, t1, t2, cosz1, cosz2, ndt, x4, x5, acosz, tr1, trr

!======================================================================!

      X5 = 2.0*PI/DAY
      X3 = SIND*SINL
      X6 = 2.0*PI*FLOAT(I-1)/FLOAT(IM)

C     COSINE OF THE SOLAR ZENITH ANGLE ARE DETERMINED ACCORDING TO THE
C     TYPE OF 'PI' POINT.

C     FOR ALL GRID POINTS (WE NO LONGER HAVE POLE POINTS)

      X4    = COSD*COSL
      T1    = (TOFDAY*DAY/ROTPER)-0.5*DT
      T2    = T1 + NDT
      COSZ1 = X3 + X4*COS(X5*T1+X6)
      COSZ2 = X3 + X4*COS(X5*T2+X6)

      IF(COSZ1.GE.0.0.AND.COSZ2.GE.0.0) THEN

C       SUN ABOVE THE HORIZON FOR THE ENTIRE PERIOD.

        ACOSZ = X3+X4*(SIN(X5*T2+X6)-SIN(X5*T1+X6))/(NDT*X5)

      ELSE IF(COSZ1.LE.0.0.AND.COSZ2.LE.0.0) THEN

C       SUN BELOW THE HORIZON FOR THE ENTIRE PERIOD.

        ACOSZ = 0.0

      ELSE

C       SUN RISES OR SETS DURING THE TIME INTERVAL.

        TR1 = ACOS(-X3/X4)
        TRR = (TR1-X6)/X5

C       GET 'TRR' THAT IS BETWEEN T1 AND T2.

        IF(TRR.GE.T1.AND.TRR.LE.T2) GOTO 999
        IF(TRR.GT.T2) GOTO 998
        TRR = TRR+DAY
        IF(TRR.GE.T1.AND.TRR.LE.T2) GOTO 999
        TRR = TRR+DAY
        IF(TRR.GE.T1.AND.TRR.LE.T2) GOTO 999

  998 CONTINUE

        TR1 = 2.0*PI-TR1
        TRR = (TR1-X6)/X5

        IF(TRR.GE.T1.AND.TRR.LE.T2) GOTO 999
        IF(TRR.LT.T1) TRR = TRR+DAY
        IF(TRR.GT.T2) TRR = TRR-DAY

  999 CONTINUE

        IF(COSZ1.LT.0.0.AND.COSZ2.GT.0.0) THEN

C         SUN RISES AFTER TIME T1.

          IF(TRR.LT.T1.OR.TRR.GT.T2) THEN
            TRR = T2
          END IF

          ACOSZ = (X3*(T2-TRR)+X4*(SIN(X5*T2+X6)-
     *                        SIN(X5*TRR+X6))/X5)/NDT

        ELSE

C         SUN SETS BEFORE TIME T2.

          IF(TRR.LT.T1.OR.TRR.GT.T2) THEN
            TRR = T1
          END IF

          ACOSZ=(X3*(TRR-T1)+X4*(SIN(X5*TRR+X6)-SIN(X5*T1+X6))/X5)/NDT

        END IF

      END IF

      return
      end


module volc
  implicit none

  double precision, parameter :: A1 = -0.4200250000201988d0
  double precision, parameter :: A2 = -2.59560737813789d0
  double precision, parameter :: M_H2O = 18.01528d0
  double precision, parameter :: M_CO2 = 44.01d0
  double precision, parameter :: C_CO2 = 0.14d0
  double precision, parameter :: C_H2O = 0.02d0
  double precision, parameter :: x = 0.01550152865954013d0
  double precision, parameter :: a_H2O = 0.54d0
  double precision, parameter :: a_CO2 = 1.d0
  double precision, parameter :: d_H2O = 2.3d0

  double precision, parameter :: e = dexp(1.d0)

  double precision :: P
  double precision :: C1, C2, C3
  double precision F1, F2, xCO2tot, xH2Otot

  contains
    subroutine solve_gases(T,PP,f_O2,mCO2tot,mH2Otot, &
                         & P_H2O, P_H2, P_CO2, P_CO, &
                         & P_CH4, alphaG, x_CO2, x_H2O)

      implicit none
      ! Inputs
      double precision, intent(in) :: T, PP, f_O2, mCO2tot, mH2Otot

      ! Outputs
      double precision, intent(out) :: P_H2O, P_H2, P_CO2, P_CO, P_CH4
      double precision, intent(out) :: alphaG, x_CO2, x_H2O

      ! other variables
      double precision K1, K2, K3
      double precision, dimension(1000) :: find1, find2
      double precision found_high, found_low, error
      integer i,j,k

      ! for optimizations
      double precision :: out(1), fvec1(1)
      double precision, dimension(1) :: diag_s
      integer iflag,n,m,info
      integer nfev
      double precision, dimension(1,1) :: fjac
      double precision, dimension(1) :: ipvt, qtf, wa1, wa2 ,wa3, wa4, xx
      double precision, dimension(8) :: init_cond, fvec2
      double precision, dimension(8,8) :: fjac2
      double precision, dimension(8) :: diag
      double precision, dimension(8) :: ipvt2, qtf2, wa12, wa22 ,wa32, wa42
      integer njev

      P = PP

      F1 = dlog(1.d0/(M_CO2*x*1.d6))+C_CO2*P/T+A1
      F2 = dlog(1.d0/(M_H2O*x*100.d0))+C_H2O*P/T+A2

      ! calculate mol fraction of CO2 and H2O in the magma
      xCO2tot=(mCO2tot/M_CO2)/x
      xH2Otot=(mH2Otot/M_H2O)/x

      ! equilibrium constants
      ! made with Nasa thermodynamic database (Burcat database)
      K1 = dexp(-29755.11319228574d0/T+6.652127716162998d0)
      K2 = dexp(-33979.12369002451d0/T+10.418882755464773d0)
      K3 = dexp(-96444.47151911151d0/T+0.22260815074146403d0)

      ! constants
      C1 = K1/f_O2**0.5d0
      C2 = K2/f_O2**0.5d0
      C3 = K3/f_O2**2.d0

      ! now solve simple system
      call linspace(dlog10(PP), -15.d0, find1)
      find1 = 10.d0**find1
      call linspace(-15.d0, dlog10(PP), find2)
      find2 = 10.d0**find2
      do i=1,1000
        call fnc_s(1,1,(/find1(i)/),out,iflag)
        if (out(1).eq.out(1)) then
          found_high = find1(i)
          exit
        endif
      enddo

      do i=1,1000
        call fnc_s(1,1,(/find2(i)/),out,iflag)
        if (out(1).eq.out(1)) then
          found_low = find2(i)
          exit
        endif
      enddo

      ! root solves
     !  subroutine lmdif(fnc_s,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfnc_s,
     ! *                 diag,mode,factor,nprint,info,nfev,fjac,ldfjac,
     ! *                 ipvt,qtf,wa1,wa2,wa3,wa4)
      n = 1
      m = 1
      fvec1(1) = 0.d0
      xx(1) = found_high
      call lmdif(fnc_s,m,n,xx,fvec1,1.49012d-8,1.49012d-8,0.0d0,10000,0.d0, &
                 diag_s,1,100.d0,-1,info,nfev,fjac,m, &
                 ipvt,qtf,wa1,wa2,wa3,wa4)

      if ((info.ne.1) .and. (info.ne.2) .and. (info.ne.3) .and. (info.ne.4)) then
        xx(1) = found_low
        call lmdif(fnc_s,m,n,xx,fvec1,1.49012d-8,1.49012d-8,0.0d0,10000,0.d0, &
                   diag_s,1,100.d0,-1,info,nfev,fjac,m, &
                   ipvt,qtf,wa1,wa2,wa3,wa4)
        if ((info.ne.1) .and. (info.ne.2) .and. (info.ne.3) .and. (info.ne.4)) then
          print*,'Convergence issues! First optimization.'
          stop
        endif
      endif

      !
      P_CO2 = xx(1)
      P_CO = C2*P_CO2
      x_CO2 = dexp(F1+a_CO2*dlog(P_CO2))
      alphaG = P*(x_CO2-xCO2tot)/(-P_CO2+P*x_CO2)
      P_H2O = (P-P_CO2-C2*P_CO2)/(1.d0+C1+C3*P_CO2)
      P_H2 = C1*P_H2O
      P_CH4 = C3*P_CO2*P_H2O**2.d0
      x_H2O = dexp(F2+a_H2O*dlog(P_H2O))
      ! use different alphaG as inital guess
      alphaG = 0.1d0

      init_cond = (/dlog(x_H2O),dlog(x_CO2),dlog(P_H2O),dlog(P_CO2) &
                    ,alphaG,dlog(P_H2),dlog(P_CH4),dlog(P_CO)/)

      ! call fcn(8,8,init_cond,fvec2,fjac2,8,2)

      ! subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,
      ! *                 maxfev,diag,mode,factor,nprint,info,nfev,njev,
      ! *                 ipvt,qtf,wa1,wa2,wa3,wa4)

      call lmder(fcn,8,8,init_cond,fvec2,fjac2,8,1.49012d-8,1.49012d-8,0.0d0, &
                 10000,diag,1,100.d0,-1,info,nfev,njev, &
                 ipvt2,qtf2,wa12,wa22,wa32,wa42)

      if ((((info.ne.1) .and. (info.ne.2) .and. (info.ne.3) .and. (info.ne.4)) .or. (init_cond(5).le.0.d0))) then
        init_cond = (/dlog(x_H2O),dlog(x_CO2),dlog(P_H2O),dlog(P_CO2) &
                      ,dlog(alphaG),dlog(P_H2),dlog(P_CH4),dlog(P_CO)/)

        call lmder1(fcn1,8,8,init_cond,fvec2,fjac2,8,1.49012d-8,1.49012d-8,0.0d0, &
                   10000,diag,1,100.d0,-1,info,nfev,njev, &
                   ipvt2,qtf2,wa12,wa22,wa32,wa42)

        call fcn1(8,8,init_cond,fvec2,fjac2,8,1)
        do i=1,8
          error = error + dabs(fvec2(i))
        enddo

        if ((((info.ne.1) .and. (info.ne.2) .and. (info.ne.3) .and. (info.ne.4)) .or.(error.ge.1d-7))) then
          x_H2O = xH2Otot
          x_CO2 = xCO2tot
          P_H2O = 0.d0
          P_CO2 = 0.d0
          alphaG = 0.d0
          P_H2 = 0.d0
          P_CH4 = 0.d0
          P_CO = 0.d0
        else
          x_H2O = dexp(init_cond(1))
          x_CO2 = dexp(init_cond(2))
          P_H2O = dexp(init_cond(3))
          P_CO2 = dexp(init_cond(4))
          alphaG = dexp(init_cond(5))
          P_H2 = dexp(init_cond(6))
          P_CH4 = dexp(init_cond(7))
          P_CO = dexp(init_cond(8))
        endif

      else
        x_H2O = dexp(init_cond(1))
        x_CO2 = dexp(init_cond(2))
        P_H2O = dexp(init_cond(3))
        P_CO2 = dexp(init_cond(4))
        alphaG = init_cond(5)
        P_H2 = dexp(init_cond(6))
        P_CH4 = dexp(init_cond(7))
        P_CO = dexp(init_cond(8))
      endif

    end subroutine

    subroutine fcn(m,n,y,out,fjac,ldfjac,iflag)
      implicit none
      integer, intent(in) :: iflag, m, n
      double precision, dimension(n), intent(in) :: y
      double precision, dimension(m), intent(out) :: out
      double precision, dimension(n,m), intent(out) :: fjac
      integer,intent(in) :: ldfjac
      double precision ln_x_H2O, ln_x_CO2, ln_H2O, ln_CO2
      double precision alphaG, ln_H2, ln_CH4, ln_CO
      double precision lnxH2O, lnxCO2, lnPH2O, lnPCO2
      double precision lnPH2, lnPCH4, lnPCO

      if (iflag.eq.1) then
        ln_x_H2O = y(1)
        ln_x_CO2 = y(2)
        ln_H2O = y(3)
        ln_CO2 = y(4)
        alphaG = y(5)
        ln_H2 = y(6)
        ln_CH4 = y(7)
        ln_CO = y(8)

        out(1) = dexp(ln_H2O)+dexp(ln_CO2)+dexp(ln_H2)+dexp(ln_CH4)+dexp(ln_CO)-P
        out(2) = -ln_x_CO2+dexp(ln_x_H2O)*d_H2O+a_CO2*ln_CO2+F1
        out(3) = -ln_x_H2O+a_H2O*ln_H2O+F2
        out(4) = -xH2Otot*P + (dexp(ln_H2O)+dexp(ln_H2) &
               +2.d0*dexp(ln_CH4))*alphaG+(1.d0-alphaG)*dexp(ln_x_H2O)*P
        out(5) = -xCO2tot*P + (dexp(ln_CO2)+dexp(ln_CO) &
               +dexp(ln_CH4))*alphaG+(1-alphaG)*dexp(ln_x_CO2)*P
        out(6) = dlog(C1)+ln_H2O-ln_H2
        out(7) = dlog(C2)+ln_CO2-ln_CO
        out(8) = dlog(C3)+ln_CO2+2.d0*ln_H2O-ln_CH4
      else if (iflag.eq.2) then
        lnxH2O = y(1)
        lnxCO2 = y(2)
        lnPH2O = y(3)
        lnPCO2 = y(4)
        alphaG = y(5)
        lnPH2 = y(6)
        lnPCH4 = y(7)
        lnPCO = y(8)

        fjac(1,:)=(/ 0.d0,0.d0,E**lnPH2O,E**lnPCO2,0.d0,E**lnPH2,E**lnPCH4,E**lnPCO /)
        fjac(2,:)=(/ d_H2O*E**lnxH2O,-1.d0,0.d0,a_CO2,0.d0,0.d0,0.d0,0.d0 /)
        fjac(3,:)=(/ -1.d0,0.d0,a_H2O,0.d0,0.d0,0.d0,0.d0,0.d0 /)

        fjac(4,:)=(/ (1.d0-alphaG)*E**lnxH2O*P,0.d0,alphaG*E**lnPH2O,0.d0,2.d0*E**lnPCH4 &
                    + E**lnPH2 + E**lnPH2O - E**lnxH2O*P, &
                    - alphaG*E**lnPH2,2.d0*alphaG*E**lnPCH4,0.d0 /)

        fjac(5,:)=(/ 0.d0,(1.d0 - alphaG)*E**lnxCO2*P,0.d0,alphaG*E**lnPCO2,E**lnPCH4 &
                    + E**lnPCO + E**lnPCO2 - E**lnxCO2*P,0.d0, &
                    - alphaG*E**lnPCH4,alphaG*E**lnPCO /)
        fjac(6,:)=(/0.d0,0.d0,1.d0,0.d0,0.d0,-1.d0,0.d0,0.d0/)
        fjac(7,:)=(/0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,-1.d0/)
        fjac(8,:)=(/0.d0,0.d0,2.d0,1.d0,0.d0,0.d0,-1.d0,0.d0/)

      else
        print*,'iflag must be 1 or 2. iflag =',iflag
        stop
      endif
    end subroutine

    subroutine fcn1(m,n,y,out,fjac,ldfjac,iflag)
      implicit none
      integer, intent(in) :: iflag, m, n
      double precision, dimension(n), intent(in) :: y
      double precision, dimension(m), intent(out) :: out
      double precision, dimension(n,m), intent(out) :: fjac
      integer,intent(in) :: ldfjac
      double precision ln_x_H2O, ln_x_CO2, ln_H2O, ln_CO2
      double precision lnalphaG, ln_H2, ln_CH4, ln_CO
      double precision lnxH2O, lnxCO2, lnPH2O, lnPCO2
      double precision lnPH2, lnPCH4, lnPCO

      if (iflag.eq.1) then
        ln_x_H2O = y(1)
        ln_x_CO2 = y(2)
        ln_H2O = y(3)
        ln_CO2 = y(4)
        lnalphaG = y(5)
        ln_H2 = y(6)
        ln_CH4 = y(7)
        ln_CO = y(8)

        out(1) = dexp(ln_H2O)+dexp(ln_CO2)+dexp(ln_H2)+dexp(ln_CH4)+dexp(ln_CO)-P
        out(2) = -ln_x_CO2+dexp(ln_x_H2O)*d_H2O+a_CO2*ln_CO2+F1
        out(1) = -ln_x_H2O+a_H2O*ln_H2O+F2
        out(4) = -xH2Otot*P + (dexp(ln_H2O)+dexp(ln_H2)+2*dexp(ln_CH4))*dexp(lnalphaG)+(1-dexp(lnalphaG))*dexp(ln_x_H2O)*P
        out(5) = -xCO2tot*P + (dexp(ln_CO2)+dexp(ln_CO)+dexp(ln_CH4))*dexp(lnalphaG)+(1-dexp(lnalphaG))*dexp(ln_x_CO2)*P
        out(6) = dlog(C1)+ln_H2O-ln_H2
        out(7) = dlog(C2)+ln_CO2-ln_CO
        out(8) = dlog(C3)+ln_CO2+2*ln_H2O-ln_CH4
      else if (iflag.eq.2) then
        lnxH2O = y(1)
        lnxCO2 = y(2)
        lnPH2O = y(3)
        lnPCO2 = y(4)
        lnalphaG = y(5)
        lnPH2 = y(6)
        lnPCH4 = y(7)
        lnPCO = y(8)

        fjac(1,:)=(/ 0.d0,0.d0,E**lnPH2O,E**lnPCO2,0.d0,E**lnPH2,E**lnPCH4,E**lnPCO /)
        fjac(2,:)=(/ d_H2O*E**lnxH2O,-1.d0,0.d0,a_CO2,0.d0,0.d0,0.d0,0.d0/)
        fjac(3,:)=(/ -1.d0,0.d0,a_H2O,0.d0,0.d0,0.d0,0.d0,0.d0 /)

        fjac(4,:)=(/ E**lnxH2O*(1.d0 - E**lnalphaG)*P,0.d0,E**(lnalphaG + lnPH2O),0.d0, &
                    - E**lnalphaG*(2.d0*E**lnPCH4 + E**lnPH2 + E**lnPH2O) - &
                    E**(lnalphaG + lnxH2O)*P,E**(lnalphaG + lnPH2), &
                    - 2.d0*E**(lnalphaG + lnPCH4),0.d0 /)

        fjac(5,:)=(/ 0.d0,E**lnxCO2*(1.d0 - E**lnalphaG)*P,0.d0,E**(lnalphaG + lnPCO2), &
                    - E**lnalphaG*(E**lnPCH4 + E**lnPCO + E**lnPCO2) &
                    - E**(lnalphaG + lnxCO2)*P,0.d0,E**(lnalphaG + lnPCH4), &
                    - E**(lnalphaG + lnPCO) /)
        fjac(6,:)=(/0.d0,0.d0,1.d0,0.d0,0.d0,-1.d0,0.d0,0.d0/)
        fjac(7,:)=(/0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,-1.d0/)
        fjac(8,:)=(/0.d0,0.d0,2.d0,1.d0,0.d0,0.d0,-1.d0,0.d0/)

      else
        print*,'iflag must be 1 or 2. iflag =',iflag
        stop
      endif
    end subroutine

    subroutine fnc_s(m,n,PCO21,out,iflag)
      implicit none
      integer, intent(in) :: m,n,iflag
      double precision, intent(in) :: PCO21(n)
      double precision, intent(out) :: out(m)
      double precision PCO2
      PCO2 = PCO21(1)
      out(1) = ( -1 * ( e )**( ( F1 + a_CO2 * dlog( PCO2 ) ) ) * ( P )**( -1 ) &
                * ( P + ( -1 * PCO2 + -1 * C2 * PCO2 ) ) * ( ( 1 + ( C1 + C3 * PCO2 ) &
                ) )**( -1 ) + ( ( P )**( -1 ) * ( P + ( -1 * PCO2 + -1 * C2 * PCO2 ) &
                ) * ( ( 1 + ( C1 + C3 * PCO2 ) ) )**( -1 ) * xCO2tot + ( -1 * ( e &
                )**( ( F2 + a_H2O * dlog( (P-PCO2-C2*PCO2)/(1+C1+C3*PCO2) ) ) ) * ( -1 * ( P )**( -1 ) * PCO2 + &
                xCO2tot ) + ( ( e )**( ( F1 + a_CO2 * dlog( PCO2 ) ) ) * xH2Otot &
                + -1 * ( P )**( -1 ) * PCO2 * xH2Otot ) ) ) )
    end subroutine

    subroutine linspace(from, to, array)
      real(8), intent(in) :: from, to
      real(8), intent(out) :: array(:)
      real(8) :: range
      integer :: n, i
      n = size(array)
      range = to - from

      if (n == 0) return

      if (n == 1) then
        array(1) = from
        return
      end if

      do i=1, n
        array(i) = from + range * (i - 1) / (n - 1)
      end do
    end subroutine

end module

program test
  use volc
  implicit none

  double precision :: T, PP, f_O2, mCO2tot, mH2Otot

  ! Outputs
  double precision :: P_H2O, P_H2, P_CO2, P_CO, P_CH4
  double precision :: alphaG, x_CO2, x_H2O
  double precision A, B, C

  double precision from, to
  double precision, dimension(10) :: array

  T = 1473.d0
  PP = 1.d0
  mCO2tot = 1000d-6
  mH2Otot = 1000d-6

  A = 25738.d0
  B = 9.d0
  C = 0.092d0

  f_O2 = 10.d0**((-A/T+B+C*(P-1.d0)/T))

  call solve_gases(T,PP,f_O2,mCO2tot,mH2Otot, &
                 & P_H2O, P_H2, P_CO2, P_CO, &
                 & P_CH4, alphaG, x_CO2, x_H2O)

  print*,P_H2O, P_H2, P_CO2, P_CO, &
  & P_CH4, alphaG, x_CO2, x_H2O
end program


! *****************************************************
!    kernel.f for 3dgrid
!  14  Aug. 2014   written by D. Kawata
! *****************************************************

subroutine setkernel()
      use gcdp_const
      use gcdp_kernel
      use gcdp_system

      implicit none

      integer i,j
      double precision f,cv,s,ds_tb

      dnktab=dble(NKTAB)
      ds_tb=1.0d0/dnktab

! *** W: SPH kernel ***
! *** for 2D constant ***
      cv=(40.0d0/(7.0d0*M_PI))

      do i=0,NKTAB
        s_tb(i)=ds_tb*dble(i)
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=(1.0d0-6.0d0*(s**2)+6.0d0*(s**3))
        else if(s.le.1.0d0) then
          f=(2.0d0*((1.0d0-s)**3))
        else
          f=0.0d0
        endif
        w_tb(i)=cv*f
      enddo

! *** dW(s)/ds/s: SPH kernel ***
      do i=0,NKTAB
        s=s_tb(i)
        if(s.le.0.5d0) then
          f=-12.0d0+18.0d0*s
        else if(s.le.1.0d0) then
          f=-6.0d0*((1.0d0-s)**2)/s
        else
          f=0.0d0
        endif
        dwds_s_tb(i)=cv*f
      enddo

end subroutine


      double precision function DSQUAD(K, N, T, BCOEF, X1, X2)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 DSQUAD Krogh  Added external statement.
c>> 1994-10-20 DSQUAD Krogh  Changes to use M77CON
c>> 1992-11-12 DSQUAD C. L. Lawson, JPL Saving IL1 & IL2.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1988-04-01 C. L. Lawson, JPL
C
C   This subprogram computes the integral over [X1,X2] of a K-th order
C      B-spline using the B-representation (T,BCOEF,N,K).  Orders
C      K as high as 20 are permitted.  Permits X1 .le. X2 or X1 gt. X2.
C      The "proper interpolation interval" is from T(K) to T(N+1).
c      For most reliable results, X1 and X2 should lie in this
c      interval, however this subr will give a result even if this
c      is not the case by use of extrapolation.
C      This subr applies a 2, 6, or 10 point Gauss formula on
c      subintervals of [X1,X2] which are formed by the included
c      (distinct) knots.

C     DESCRIPTION OF ARGUMENTS
C         INPUT
C           K       - ORDER OF B-SPLINE, 2 .le. K .le. 20
c                     Note that the polynomial degree of the segments of
c                     the spline are one less than the order.
C           N       - LENGTH OF COEFFICIENT ARRAY
C           T()     - KNOT ARRAY OF LENGTH N+K
C           BCOEF() - B-SPLINE COEFFICIENT ARRAY OF LENGTH N
C           X1,X2   - END POINTS OF QUADRATURE INTERVAL.
C                     Permit X1 .le. X2 or X1 .gt. X2.
C         OUTPUT
C           DSQUAD  - INTEGRAL OF THE B-SPLINE OVER [X1,X2].
C
C     ERROR CONDITIONS: None
c     ------------------------------------------------------------------
C     Original code was called BQUAD or BSQUAD.  Written by D. E. Amos,
c     Sandia, June, 1979.  Documented in SAND79-1825.
c     Uses the (T, BCOEF, N, K) representation of a B-spline as
c     presented in A PRACTICAL GUIDE TO SPLINES by Carl De Boor,
c     Springer-Verlag, 1978.
c     Current version by C. L. Lawson, JPL, March 1988.
c     ------------------------------------------------------------------
c--D replaces "?": ?SQUAD, ?SFIND, ?SVAL
c     ------------------------------------------------------------------
c     GPTS(), GWTS()  Index 1 selects 2-point Gaussian formula.
c                     Indices 2-4 select 6-point Gaussian formula.
c                     Indices 5-9 select 10-point Gaussian formula.
c     ------------------------------------------------------------------
      external DSVAL
      integer I, IL1, IL2, JF, K, LEFT, M, MF, MODE, N
      double precision DSVAL
      double precision A, AA, B, BB, BCOEF(N), BMA, BPA, C1
      double precision GPTS(9), GWTS(9), HALF
      double precision Q, SUM(5), T(N+K), TA, TB, X1, X2, ZERO
      parameter(HALF = 0.50D0, ZERO = 0.0D0)
      save IL1, IL2
      data IL1, IL2 / 1,1/
C
*     DATA GPTS            / 5.77350269189626D-01, 2.38619186083197D-01,
*    1 6.61209386466265D-01, 9.32469514203152D-01, 1.48874338981631D-01,
*    2 4.33395394129247D-01, 6.79409568299024D-01, 8.65063366688985D-01,
*    3 9.73906528517172D-01/
C
*     DATA GWTS            / 1.00000000000000D+00, 4.67913934572691D-01,
*    1 3.60761573048139D-01, 1.71324492379170D-01, 2.95524224714753D-01,
*    2 2.69266719309996D-01, 2.19086362515982D-01, 1.49451349150581D-01,
*    3 6.66713443086880D-02/
c
c     Gaussian quadrature abcissae and weights to 40 decimal digits.
      data GPTS / 0.5773502691896257645091487805019574556476d0,
     2            0.2386191860831969086305017216807119354186d0,
     3            0.6612093864662645136613995950199053470064d0,
     4            0.9324695142031520278123015544939946091348d0,
     5            0.1488743389816312108848260011297199846176d0,
     6            0.4333953941292471907992659431657841622001d0,
     7            0.6794095682990244062343273651148735757693d0,
     8            0.8650633666889845107320966884234930485275d0,
     9            0.9739065285171717200779640120844520534283d0/
c
      data GWTS / 1.0d0,
     2            0.4679139345726910473898703439895509948120d0,
     3            0.3607615730481386075698335138377161116612d0,
     4            0.1713244923791703450402961421727328935273d0,
     5            0.2955242247147528701738929946513383294210d0,
     6            0.2692667193099963550912269215694693528586d0,
     7            0.2190863625159820439955349342281631924634d0,
     8            0.1494513491505805931457763396576973323908d0,
     9            0.06667134430868813759356880989333179285686d0/
c     ------------------------------------------------------------------
C
      AA= min(X1,X2)
      BB= max(X1,X2)
      if(AA .eq. BB) then
         Q = ZERO
         go to 90
      endif
C                  Selection of Gaussian quadrature formula:
c                  KORDER .le. 4          =>   2 point formula
c                  5 .le. KORDER .le. 12  =>  6 point formula
c                  KORDER .ge. 13         =>  10 point formula
c
      if(K .le. 4) then
         JF=0
         MF=1
      elseif(K .le. 12) then
         JF=1
         MF=3
      else
         JF=4
         MF=5
      endif
C
      do 15 I=1,MF
         SUM(I)= ZERO
   15 continue
      call DSFIND(T,K, N+1,AA,IL1,MODE)
      call DSFIND(T,K, N+1,BB,IL2,MODE)
      do 20 LEFT=IL1,IL2
         TA=T(LEFT)
         TB=T(LEFT+1)
         if(TA .ne. TB) then
            if(LEFT .eq. K) then
               A = AA
            else
               A= max(AA,TA)
            endif
            if(LEFT .eq. N) then
               B = BB
            else
               B= min(BB,TB)
            endif
            BMA= HALF *(B-A)
            BPA= HALF *(B+A)
            DO 25 M=1,MF
               C1=BMA*GPTS(JF+M)
               SUM(M)=SUM(M) + BMA * (DSVAL(K, N, T, BCOEF, BPA+C1, 0)+
     *                                DSVAL(K, N, T, BCOEF, BPA-C1, 0))
   25       continue
         endif
   20 continue
      Q= ZERO
      DO 30 M=1,MF
         Q=Q+GWTS(JF+M)*SUM(M)
   30 continue
      if(X1 .gt. X2) Q=-Q
   90 continue
      DSQUAD = Q
      return
      end


      SUBROUTINE TPTEST(DATA1,DATA2,N,T,PROB)
      DIMENSION DATA1(N),DATA2(N)
      CALL AVEVAR(DATA1,N,AVE1,VAR1)
      CALL AVEVAR(DATA2,N,AVE2,VAR2)
      COV=0.
      DO 11 J=1,N
        COV=COV+(DATA1(J)-AVE1)*(DATA2(J)-AVE2)
11    CONTINUE
      DF=N-1
      COV=COV/DF
      SD=SQRT((VAR1+VAR2-2.*COV)/N)
      T=(AVE1-AVE2)/SD
      PROB=BETAI(0.5*DF,0.5,DF/(DF+T**2))
      RETURN
      END


      PROGRAM main
      IMPLICIT none
      REAL*8 mag,mom,total
      total = 0.0d0
  101 read (*,*,end=102) mag
          mom = 10**(1.5d0*(mag+10.7d0))/1d7
          total = total + mom
          write(*,1001) mom
          goto 101
  102 continue
      write (*,1002) total
 1001 format('Moment: ',G14.6,' Nm')
 1002 format('Total Moment: ',G14.6,' Nm')
      END


! { dg-do run }
! { dg-options "-fdec" }
!
! Runtime tests to verify logical-to-bitwise operations perform as expected
! with -fdec.
!

subroutine assert(expected, actual, str)
  implicit none
  character(*), intent(in) :: str
  integer, intent(in)      :: expected, actual
  if (actual .ne. expected) then
    write (*, '(A,I4,I4)') str, expected, actual
    call abort()
  endif
end subroutine

implicit none

integer expected, expected_expr
integer output_vars, output_const, output_expr
integer op1, op2, mult

mult = 3
op1 = 3
op2 = 5

!!!! AND -> IAND

expected      = IAND(op1, op2)
expected_expr = mult*expected

output_const  = 3 .AND. 5
output_vars   = op1 .AND. op2
output_expr   = mult * (op1 .AND. op2)

call assert(expected, output_vars,      "( ) and")
call assert(expected, output_const,     "(c) and")
call assert(expected_expr, output_expr, "(x) and")

!!!! EQV -> NOT IEOR

expected   = NOT(IEOR(op1, op2))
expected_expr = mult*expected

output_const    = 3 .EQV. 5
output_vars     = op1 .EQV. op2
output_expr     = mult * (op1 .EQV. op2)

call assert(expected, output_vars,       "( ) EQV")
call assert(expected, output_const,      "(c) EQV")
call assert(expected_expr, output_expr,  "(x) EQV")

!!!! NEQV -> IEOR

expected   = IEOR(op1, op2)
expected_expr = mult*expected

output_const    = 3 .NEQV. 5
output_vars     = op1 .NEQV. op2
output_expr     = mult * (op1 .NEQV. op2)

call assert(expected, output_vars,       "( ) NEQV")
call assert(expected, output_const,      "(c) NEQV")
call assert(expected_expr, output_expr,  "(x) NEQV")

!!!! NOT -> NOT

expected   = NOT(op2)
expected_expr = mult*expected

output_const    = .NOT. 5
output_vars     = .NOT. op2
output_expr     = mult * (.NOT. op2)

call assert(expected, output_vars,       "( ) NOT")
call assert(expected, output_const,      "(c) NOT")
call assert(expected_expr, output_expr,  "(x) NOT")

!!!! OR -> IOR

expected   = IOR(op1, op2)
expected_expr = mult*expected

output_const    = 3 .OR. 5
output_vars     = op1 .OR. op2
output_expr     = mult * (op1 .OR. op2)

call assert(expected, output_vars,       "( ) OR")
call assert(expected, output_const,      "(c) OR")
call assert(expected_expr, output_expr,  "(x) OR")

!!!! XOR -> IEOR, not to be confused with .XOR.

expected  = IEOR(op1, op2)
expected_expr = mult*expected

output_const    = 3 .XOR. 5
output_vars     = op1 .XOR. op2
output_expr     = mult * (op1 .XOR. op2)

call assert(expected, output_vars,       "( ) XOR")
call assert(expected, output_const,      "(c) XOR")
call assert(expected_expr, output_expr,  "(x) XOR")

end


    Subroutine nagf_sort_realvec_rank(rv, m1, m2, order, irank, ifail)

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     NAGF_SORT_REALVEC_RANK ranks a vector of real numbers in ascending
!     or descending order.
!
!     NAGF_SORT_REALVEC_RANK uses a variant of list-merging, as described
!     by Knuth. The routine takes advantage of natural
!     ordering in the data, and uses a simple list insertion
!     in a preparatory pass to generate ordered lists of
!     length at least 10. The ranking is stable: equal elements
!     preserve their ordering in the input data.
!
!     The minimum length of the lists at the end of the
!     preparatory pass is defined by the variable MAXINS.
!
!     Written by N.M.Maclaren, University of Cambridge.
!     Revised by NAG Central Office.

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: maxins = 10
      Character (6), Parameter :: srname = 'M01DAF'
!     .. Scalar Arguments ..
      Integer :: ifail, m1, m2
      Character (1) :: order
!     .. Array Arguments ..
      Real (Kind=dp) :: rv(m2)
      Integer :: irank(m2)
!     .. Local Scalars ..
      Real (Kind=dp) :: a, b, c
      Integer :: i, i1, i2, ierr, ilist, j, j1, j2, k, k1, k2, l, list1, &
        list2, nlast, nprev, nrec
!     .. Local Arrays ..
      Character (80) :: p01rec(2)
!     .. External Procedures ..
      Integer, External :: p01abf
!     .. Executable Statements ..
!
!     Check the arguments and deal with the trivial case.
!
      If (m2<1 .Or. m1<1 .Or. m1>m2) Then
        ierr = 1
        Write (p01rec, Fmt=260) m1, m2
        nrec = 2
      Else If (order/='A' .And. order/='a' .And. order/='D' .And. order/='d') &
          Then
        ierr = 2
        Write (p01rec, Fmt=270) order
        nrec = 1
      Else If (m1==m2) Then
        irank(m2) = m2
        ierr = 0
      Else
        ierr = 0
!
!       Initialise, using natural runs in both directions and
!       straight list insertion for small lists.
!
!       I  points to the smallest element in the current list
!       J  points to the largest  element in the current list
!       B  is the value of the smallest element in current list
!       C  is the value of the largest  element in current list
!
        ilist = -1
        k = m1
        i = k
        j = k
        l = k + maxins
        b = rv(k)
        c = b
        Do k = m1 + 1, m2
!
!         Deal with additions at either end.
!
          a = rv(k)
          If (a>=c) Then
            irank(j) = k
            j = k
            c = a
          Else If (a<b) Then
            irank(k) = i
            i = k
            b = a
          Else
!
!           Do an ascending list insertion.
!
            If (k<l) Then
              i2 = i
100           i1 = i2
              i2 = irank(i1)
              If (a>=rv(i2)) Go To 100
              irank(i1) = k
              irank(k) = i2
            Else
!
!             Add the current list on to the others.
!
              If (ilist<0) Then
                list1 = -i
                ilist = 0
              Else If (ilist==0) Then
                list2 = -i
                ilist = 1
                nprev = nlast
              Else
                irank(nprev) = -i
                nprev = nlast
              End If
!
              nlast = j
              i = k
              j = k
              l = k + maxins
              b = rv(k)
              c = b
            End If
          End If
        End Do
!
!       Tidy up at the end.
!
        irank(j) = 0
        If (ilist<0) Then
          list1 = -i
          Go To 220
        Else If (ilist==0) Then
          list2 = -i
        Else
          irank(nprev) = -i
        End If
        irank(nlast) = 0
!
!       At this point:
!       LIST1 = - (index of least element in the first list)
!       LIST2 = - (index of least element in the second list)
!       For each K, IRANK(K) is the index of the next element in the
!       current list, except that, if there is no such element,
!       IRANK(K) is - (index of the least element in the next list
!       but 1)  or 0 if there is no such list.
!
!       Start merging lists by pairs.
!
110     ilist = -1
        i = -list1
        j = -list2
120     k = i
        If (rv(i)>rv(j)) k = j
        If (ilist<0) Then
          list1 = -k
          ilist = 0
        Else If (ilist==0) Then
          list2 = -k
          ilist = 1
          nlast = l
        Else
          irank(nlast) = -k
          nlast = l
        End If
!
!       Move along the lists until one finishes.
!
!       New variables I2, J2 and K2 are used instead of I, J and K
!       within the innermost block to encourage optimising compilers to
!       store them in registers.
!        I2 points to the current element in the first list
!        J2 points to the current element in the second list
!        K2 points to the current element in the merged list
!
        i2 = i
        j2 = j
        If (k/=i2) Go To 150
130     a = rv(j2)
        k2 = i2
140     i2 = k2
        k2 = irank(i2)
        If (k2<=0) Go To 170
        If (a>=rv(k2)) Go To 140
        irank(i2) = j2
        i2 = k2
150     a = rv(i2)
        k2 = j2
160     j2 = k2
        k2 = irank(j2)
        If (k2<=0) Go To 180
        If (a>rv(k2)) Go To 160
        irank(j2) = i2
        j2 = k2
        Go To 130
!
!       Add the remains of one list to the other.
!
170     k = 1
        i1 = k2
        Go To 190
180     k = 2
        j1 = k2
190     i = i2
        j = j2
        If (k==1) Then
!
!         First list is exhausted
!
          irank(i) = j
          i = -i1
          j1 = j
200       j = j1
          j1 = irank(j)
          If (j1>0) Go To 200
          l = j
          j = -j1
        Else
!
!         Second list is exhausted
!
          irank(j) = i
          j = -j1
          i1 = i
210       i = i1
          i1 = irank(i)
          If (i1>0) Go To 210
          l = i
          i = -i1
        End If
!
!       Tidy up and carry on if not finished.
!
        If ((i/=0) .And. (j/=0)) Go To 120
        irank(l) = 0
        k = i + j
        If (ilist>0) Then
          irank(nlast) = -k
          Go To 110
        Else If (k/=0) Then
          list2 = -k
          Go To 110
        End If
!
!       If descending, reverse all pointers between equality
!       blocks.
!
220     If ((order=='D') .Or. (order=='d')) Then
          i = 0
          j = -list1
230       k = j
          k1 = k
          a = rv(k)
240       k = k1
          k1 = irank(k)
          If (k1/=0) Then
            If (a==rv(k1)) Go To 240
          End If
          irank(k) = i
          i = j
          j = k1
          If (j/=0) Go To 230
          list1 = -i
        End If
!
!       Convert the list form to ranks and return.
!
        k = m1
        i = -list1
250     i1 = irank(i)
        irank(i) = k
        k = k + 1
        i = i1
        If (i>0) Go To 250
!
      End If
!
      If (ierr/=0) Then
        ifail = p01abf(ifail, ierr, srname, nrec, p01rec)
      Else
        ifail = 0
      End If
      Return
!
260   Format (' ** On entry, one or more of the following parameter va', &
        'lues is illegal', /, '    M1 =', I16, '  M2 =', I16)
270   Format (' ** On entry, ORDER has an illegal value: ORDER = ', A1)
    End Subroutine


subroutine sup_templaw_WLF(e, gptemp, ReferenceTemp,c1_WLF, c2_WLF, LawViParam, acvis, lambda)
   use typre
   use Mod_Element
   implicit none
   class(FiniteElement) :: e
   real(rp),    intent(in)  :: gptemp,ReferenceTemp,c1_WLF,c2_WLF, LawViParam(*)
   real(rp),    intent(out) :: acvis, lambda
   real(rp) :: lambda0, visc0,tempe0, c1, c2, func,diftemp,func2

   tempe0=ReferenceTemp
   c1=c1_WLF
   c2=c2_WLF

   visc0=LawViParam(1)
   lambda0=LawViParam(3)

   diftemp=gptemp-tempe0

   if (diftemp>-4) then
      func= exp(-c1*(diftemp)/(c2+diftemp))
   else
      func= exp(-c1*(-4)/(c2-4))
   end if

   acvis=visc0*func
   lambda=lambda0*func

end subroutine

subroutine sup_templaw_Arrhenius(e, gptemp, tempe0, alpha, LawViParam, acvis, lambda)
   use typre
   use Mod_Element
   implicit none
   class(FiniteElement) :: e
   real(rp),    intent(in)  :: gptemp,tempe0,alpha, LawViParam(*)
   real(rp),    intent(out) :: acvis, lambda
   real(rp)                 :: lambda_ini, visc0, func, diftemp, diftemp0

   visc0=LawViParam(1)
   lambda_ini=LawViParam(3)

   !Warning!! Temperature solution in ºC, not ºK.
   diftemp =gptemp+273.15 !=> to pass to Kelvin grades
   diftemp0=tempe0+273.15 !=> to pass to Kelvin grades

   if (diftemp==0 .or. diftemp0==0) then
      func= exp(alpha*(1.0_rp/(diftemp+0.00000001) -1.0_rp/(diftemp0+0.00000001)))
   else
      func= exp(alpha*(1.0_rp/diftemp -1.0_rp/diftemp0))
   end if

   acvis=visc0*func
   lambda=lambda_ini*func

end subroutine


module multiparameter_normal_h2
  !> Normal-hydrogen multiparameter fundamental equation for Helmholtz energy.
  !> See Leachman et al. (2009), doi:10.1063/1.3160306.
  use multiparameter_base, only: meos
  implicit none
  save
  public :: meos_normal_h2
  private

  ! Parameters for the ideal gas part alpha^0
  real, parameter, dimension(1:2) :: a = (/  -1.4579856475,  1.888076782 /)
  real, parameter, dimension(3:7) :: b = (/ -16.0205159149,&
       -22.6580178006,&
       -60.0090511389,&
       -74.9434303817,&
       -206.9392065168/)

  real, parameter, dimension(3:7) :: v = (/ 1.616,&
       -0.4117,&
       -0.792,&
       0.758,&
       1.217/)

  ! upPol is the upper index for polynomial terms, upExp the same for
  ! single-expontential terms, upExpExp for double-exponential terms.
  integer, parameter :: upPol = 7
  integer, parameter :: upExp = 9
  integer, parameter :: upExpExp = 14

  real, parameter, dimension(1:upPol) :: N_pol = (/&
       -6.93643,&
       0.01,&
       2.1101,&
       4.52059,&
       0.732564,&
       -1.34086,&
       0.130985 /)

  real, parameter, dimension(upPol+1:upExp) :: N_exp =(/ -0.777414,  0.351944 /)

  real, parameter, dimension(upExp+1:upExpExp) :: N_expexp = (/ -0.0211716,&
       0.0226312,&
       0.032187,&
       -0.0231752,&
       0.0557346 /)

  real, parameter, dimension(1:upPol) :: t_pol = (/&
       0.6844,&
       1.0,&
       0.989,&
       0.489,&
       0.803,&
       1.1444,&
       1.409&
       /)

  real, parameter, dimension(upPol+1:upExp) :: t_exp = (/  1.754,1.311  /)

  real, parameter, dimension(upExp+1:upExpExp) :: t_expexp = (/  4.187,&
       5.646,&
       0.791,&
       7.249,&
       2.986&
       /)

  integer, parameter, dimension(1:upPol) :: d_pol = (/ 1, 4, 1, 1, 2, 2, 3 /)
  integer, parameter, dimension(upPol+1:upExp) :: d_exp = (/1,3/)
  integer, parameter, dimension(upExp+1:upExpExp) :: d_expexp = (/ 2, 1, 3, 1, 1 /)

  integer, parameter, dimension(upPol+1:upExp) :: l_exp = (/1,1/)

  real, parameter, dimension(upExp+1:upExpExp) :: eta_expexp = (/&
       1.685,&
       0.489,&
       0.103,&
       2.506,&
       1.607/)

  real, parameter, dimension(upExp+1:upExpExp) :: beta_expexp = (/&
       0.171,&
       0.2245,&
       0.1304,&
       0.2785,&
       0.3967  /)

  real, parameter, dimension(upExp+1:upExpExp) :: gam_expexp = (/&
       0.7164,&
       1.3444,&
       1.4517,&
       0.7204,&
       1.5445 /)

  real, parameter, dimension(upExp+1:upExpExp) :: eps_expexp = (/&
       1.506,&
       0.156,&
       1.736,&
       0.67,&
       1.662 /)

  type, extends(meos) :: meos_normal_h2
     private
     ! Cache the expensive temperature-dependent quantities.
     real :: tau_cache
     real :: deltaSatLiq_cache
     real :: deltaSatVap_cache
     real :: prefactors_pol_cache(1:upPol)
     real :: prefactors_exp_cache(upPol+1:upExp)
     real :: prefactors_expexp_cache(upExp+1:upExpExp)

   contains

     procedure, public :: alpha0Derivs_taudelta => alpha0Derivs_NORMAL_H2
     procedure, public :: alphaResDerivs_taudelta => alphaResDerivs_NORMAL_H2
     procedure, public :: satDeltaEstimate => satDeltaEstimate_NORMAL_H2
     procedure, public :: init => init_NORMAL_H2

     procedure, private :: alphaResPrefactors => alphaResPrefactors_NORMAL_H2

     ! Assignment operator
     procedure, pass(This), public :: assign_meos => assign_meos_normal_h2

  end type meos_normal_h2

contains

  subroutine init_NORMAL_H2 (this, use_Rgas_fit)
    class(meos_normal_h2) :: this
    logical, optional, intent(in) :: use_Rgas_fit

    this%compName = "normal_h2"
    this%tau_cache = 0.0

    this%molarMass = 2.01588e-3 !< (kg/mol) (Not stated in paper. From Coolprop.)
    this%Rgas_fit = 8.314472 !< (J/(mol*K))

    this%maxT = 1000.0 ! (T)
    this%maxP = 2000e6 ! (Pa)

    this%tc = 33.145     !< (K)
    this%pc = 1.2964e6 !< (Pa)
    this%rc = 15.508e3  !< (mol/m^3)

    this%t_triple = 13.957      !< (K)
    this%p_triple = 7360.0      !< (Pa)
    this%rhoLiq_triple = 38.2e3 !< (mol/m^3)
    this%rhoVap_triple = 0.12985/this%molarMass !< (mol/m^3)

    if (present(use_Rgas_fit)) then
       if (use_Rgas_fit) then
          this%Rgas_meos = this%Rgas_fit
       end if
    end if

  end subroutine init_NORMAL_H2

  ! The functional form of the ideal gas function varies among multiparameter EoS,
  ! which explains why this routine may seem a bit hard-coded.
  subroutine alpha0Derivs_NORMAL_H2(this, delta, tau, alp0)
    class(meos_normal_h2) :: this
    real, intent(in) :: delta, tau
    real, intent(out) :: alp0(0:2,0:2) !< alp0(i,j) = [(d_delta)^i(d_tau)^j alpha0]*delta^i*tau^j
    ! Internals
    real, dimension(3:7) :: exps

    exps = exp(b*tau)

    alp0 = 0.0
    alp0(0,0) = log(delta) + 1.5*log(tau) + a(1) + a(2)*tau + dot_product(v, log(1-exps))
    alp0(1,0) = 1.0
    alp0(2,0) = -1.0
    alp0(0,1) = 1.5 + a(2)*tau + tau*dot_product(v*b, exps/(exps-1))
    alp0(0,2) = -1.5 - tau*tau*dot_product(v*b**2, exps/(exps-1)**2)

  end subroutine alpha0Derivs_NORMAL_H2

  ! Supplies all prefactors that do not depend on delta. Prefactors are cached.
  subroutine alphaResPrefactors_NORMAL_H2 (this, tau, prefactors_pol, prefactors_exp, prefactors_expexp)
    class(meos_normal_h2) :: this
    real, intent(in) :: tau
    real, intent(out) :: prefactors_pol(1:upPol)
    real, intent(out) :: prefactors_exp(upPol+1:upExp)
    real, intent(out) :: prefactors_expexp(upExp+1:upExpExp)

    if ( tau /= this%tau_cache ) then
       this%tau_cache = tau
       this%prefactors_pol_cache = N_pol * tau**t_pol
       this%prefactors_exp_cache = N_exp * tau**t_exp
       this%prefactors_expexp_cache = N_expexp * tau**t_expexp
    end if

    prefactors_pol = this%prefactors_pol_cache
    prefactors_exp = this%prefactors_exp_cache
    prefactors_expexp = this%prefactors_expexp_cache

  end subroutine alphaResPrefactors_NORMAL_H2

  subroutine alphaResDerivs_NORMAL_H2 (this, delta, tau, alpr)
    class(meos_normal_h2) :: this
    real, intent(in) :: delta, tau
    real, intent(out) :: alpr(0:2,0:2) !< alpr(i,j) = (d_delta)^i(d_tau)^j alphaRes
    ! Internal
    real :: deltaL(upPol+1:upExp)
    real :: prefactors_pol(1:upPol)
    real :: prefactors_exp(upPol+1:upExp)
    real :: prefactors_expexp(upExp+1:upExpExp)
    real :: polTerms(1:upPol), expTerms(upPol+1:upExp), expExpTerms(upExp+1:upExpExp)
    call this%alphaResPrefactors(tau, prefactors_pol, prefactors_exp, prefactors_expexp)

    ! Precalculate polynomial terms
    polTerms(1:upPol) = prefactors_pol*delta**d_pol

    ! Precalculate single-exponential terms
    deltaL(upPol+1:upExp) = delta**l_exp
    expTerms(upPol+1:upExp) = prefactors_exp * delta**d_exp * exp(-deltaL)

    ! Precalculate double-exponential terms
    expExpTerms(upExp+1:upExpExp) = prefactors_expexp * delta**d_expexp &
         * exp(-eta_expexp*(delta-eps_expexp)**2 - beta_expexp*(tau-gam_expexp)**2)

    ! alpha
    alpr(0,0) = sum(polTerms) + sum(expTerms) + sum(expExpTerms)

    ! delta*alpha_delta
    alpr(1,0) = dot_product(polTerms, d_pol) + dot_product(expTerms, d_exp - l_exp*deltaL) &
         + dot_product(expExpTerms, d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))

    ! delta**2 * alpha_deltadelta
    alpr(2,0) = dot_product(polTerms, d_pol*(d_pol-1)) + &
         dot_product(expTerms, (d_exp - l_exp*deltaL)*(d_exp-1-l_exp*deltaL) - l_exp*l_exp*deltaL ) + &
         dot_product(expExpTerms, (d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))**2 - d_expexp - 2*eta_expexp*delta**2 )

    ! tau*alpha_tau
    alpr(0,1) = dot_product(polTerms, t_pol) + dot_product(expTerms, t_exp) &
         + dot_product(expExpTerms, t_expexp - 2*beta_expexp*tau*(tau-gam_expexp))

    ! tau**2 * alpha_tautau
    alpr(0,2) = dot_product(polTerms, t_pol*(t_pol-1)) + dot_product(expTerms, t_exp*(t_exp-1)) &
         + dot_product(expExpTerms, (t_expexp - 2*beta_expexp*tau*(tau-gam_expexp))**2 - t_expexp - 2*beta_expexp*tau**2 )

    ! delta*tau*alpha_deltatau
    alpr(1,1) = dot_product(polTerms, d_pol*t_pol) + dot_product(expTerms, (d_exp - l_exp*deltaL)*t_exp ) &
         + dot_product(expExpTerms, &
         (d_expexp - 2*eta_expexp*delta*(delta-eps_expexp))*(t_expexp - 2*beta_expexp*tau*(tau-gam_expexp)))

  end subroutine alphaResDerivs_NORMAL_H2

  function satDeltaEstimate_NORMAL_H2 (this,tau,phase) result(deltaSat)
    use thermopack_constants, only: LIQPH, VAPPH, SINGLEPH
    class(meos_normal_h2) :: this
    real, intent(in) :: tau
    integer, intent(in) :: phase
    real :: deltaSat

    if ( phase == LIQPH .or. phase == SINGLEPH) then
       deltaSat = this%rhoLiq_triple/this%rc
    else if ( phase == VAPPH ) then
       deltaSat = this%rhoVap_triple/this%rc
    else
       call stoperror("satDeltaEstimate_ortho_h2: only LIQPH,VAPPH,SINGLEPH allowed!")
    end if

  end function satDeltaEstimate_NORMAL_H2

  subroutine assign_meos_normal_h2(this,other)
    class(meos_normal_h2), intent(inout) :: this
    class(*), intent(in) :: other
    !
    select type (other)
    class is (meos_normal_h2)
      call this%assign_meos_base(other)

      this%tau_cache = other%tau_cache
      this%deltaSatLiq_cache = other%deltaSatLiq_cache
      this%deltaSatVap_cache = other%deltaSatVap_cache
      this%prefactors_pol_cache = other%prefactors_pol_cache
      this%prefactors_exp_cache = other%prefactors_exp_cache
      this%prefactors_expexp_cache = other%prefactors_expexp_cache

    class default
      call stoperror("assign_meos_normal_h2: Should not be here....")
    end select
  end subroutine assign_meos_normal_h2

end module multiparameter_NORMAL_H2


      SUBROUTINE MB02VD( TRANS, M, N, A, LDA, IPIV, B, LDB, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the solution to a real system of linear equations
C        X * op(A) = B,
C     where op(A) is either A or its transpose, A is an N-by-N matrix,
C     and X and B are M-by-N matrices.
C     The LU decomposition with partial pivoting and row interchanges,
C     A = P * L * U, is used, where P is a permutation matrix, L is unit
C     lower triangular, and U is upper triangular.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     TRANS   CHARACTER*1
C             Specifies the form of op(A) to be used as follows:
C             = 'N':  op(A) = A;
C             = 'T':  op(A) = A';
C             = 'C':  op(A) = A'.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix B, and the order of
C             the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the coefficient matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the factors L and U from the factorization A = P*L*U;
C             the unit diagonal elements of L are not stored.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     IPIV    (output) INTEGER array, dimension (N)
C             The pivot indices that define the permutation matrix P;
C             row i of the matrix was interchanged with row IPIV(i).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the right hand side matrix B.
C             On exit, if INFO = 0, the leading M-by-N part of this
C             array contains the solution matrix X.
C
C     LDB     (input) INTEGER
C             The leading dimension of the array B.  LDB >= max(1,M).
C
C     INFO    (output) INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, U(i,i) is exactly zero.  The
C                   factorization has been completed, but the factor U
C                   is exactly singular, so the solution could not be
C                   computed.
C
C     METHOD
C
C     The LU decomposition with partial pivoting and row interchanges is
C     used to factor A as
C        A = P * L * U,
C     where P is a permutation matrix, L is unit lower triangular, and
C     U is upper triangular.  The factored form of A is then used to
C     solve the system of equations X * A = B or X * A' = B.
C
C     FURTHER COMMENTS
C
C     This routine enables to solve the system X * A = B or X * A' = B
C     as easily and efficiently as possible; it is similar to the LAPACK
C     Library routine DGESV, which solves A * X = B.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, linear algebra.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            TRAN
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGETRF, DTRSM, MA02GD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the scalar input parameters.
C
      INFO = 0
      TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
C
      IF( .NOT.TRAN .AND. .NOT.LSAME( TRANS, 'N' ) ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02VD', -INFO )
         RETURN
      END IF
C
C     Compute the LU factorization of A.
C
      CALL DGETRF( N, N, A, LDA, IPIV, INFO )
C
      IF( INFO.EQ.0 ) THEN
         IF( TRAN ) THEN
C
C           Compute X = B * A**(-T).
C
            CALL MA02GD( M, B, LDB, 1, N, IPIV, 1 )
            CALL DTRSM(  'Right', 'Lower', 'Transpose', 'Unit', M, N,
     $                   ONE, A, LDA, B, LDB )
            CALL DTRSM(  'Right', 'Upper', 'Transpose', 'NonUnit', M,
     $                   N, ONE, A, LDA, B, LDB )
         ELSE
C
C           Compute X = B * A**(-1).
C
            CALL DTRSM(  'Right', 'Upper', 'NoTranspose', 'NonUnit', M,
     $                   N, ONE, A, LDA, B, LDB )
            CALL DTRSM(  'Right', 'Lower', 'NoTranspose', 'Unit', M, N,
     $                   ONE, A, LDA, B, LDB )
            CALL MA02GD( M, B, LDB, 1, N, IPIV, -1 )
         END IF
      END IF
      RETURN
C
C *** Last line of MB02VD ***
      END


      subroutine uspinor0(q,i,f)
!-----subroutine for massless spinor
!     Majorana representation
      implicit none
      include 'constants.f'
      include 'swapxz.f'
      integer i
      double complex p(4),q(4),f(4),fc
      double precision  Ep,px,py,pz,phase,rtEon2
      logical,save::first
      data first/.true./

      if (first) then
      write(6,*) 'uspinor0:swapxz=',swapxz
      first=.false.
      endif

C     Translate from MCFM notation (E=q(4)),
      if (swapxz) then
C performing the swap (x<->z),(y->-y)
      p(1)=q(4)
      p(2)=q(3)
      p(3)=-q(2)
      p(4)=q(1)
      else
      p(1)=q(4)
      p(2)=q(1)
      p(3)=q(2)
      p(4)=q(3)
      endif
      Ep=dreal(p(1))
      px=+dreal(p(2))
      py=+dreal(p(3))
      pz=dreal(p(4))

      fc=sqrt(p(1)+p(4))
      if (dble(p(1)+p(4)) .gt. 0) then
        phase=1d0
      else
        phase=-1d0
      endif

      if (abs(fc).gt.1D-8) then

      if (i.eq.+1) then
        f(1)=dcmplx(pz+py+Ep,-px)/(2d0*fc)
        f(2)=+im*f(1)
        f(3)=-dcmplx(pz-py+Ep,+px)/(2d0*fc)
        f(4)=-im*f(3)
      elseif (i.eq.-1) then
        f(1)=-dcmplx(-px,pz+py+Ep)/(2d0*fc)
        f(2)=-im*f(1)
        f(3)=+dcmplx(px,pz-py+Ep)/(2d0*fc)
        f(4)=+im*f(3)
      endif
      else
      rtEon2=sqrt(Ep/2d0)
      if (i.eq.+1) then
        f(1)=dcmplx(0d0,-rtEon2)
        f(2)=+im*f(1)
        f(3)=dcmplx(0d0,-rtEon2)
        f(4)=-im*f(3)
      elseif (i.eq.-1) then
        f(1)=dcmplx(rtEon2,0d0)
        f(2)=-im*f(1)
        f(3)=dcmplx(rtEon2,0d0)
        f(4)=+im*f(3)
      endif
      endif

      return
      end


!>
program p_h2_dissociate

  use m_io
  use m_parameters , only : PI
  use m_schrodinger , only : count_nodes

  implicit none

  double precision , parameter :: eV = 27.21136d0

  double precision , parameter :: mu = 918.07635
  ! integer , parameter :: n_mu = 6
  ! double precision , parameter :: mu(n_mu) = &
  !     (/918.07635, 1223.89925, 1376.39236, 1835.24151, 2200.87999, 2748.46079/)

  integer :: n_r
  double precision :: r_max
  double precision :: d_r

  integer , parameter :: n_wf = 600
  double precision , allocatable :: wf(:, :, :)
  double precision :: ek_grid(n_wf)
  double precision :: D(2)
  double precision :: asym_amp, k

  double precision , allocatable :: r_grid(:)
  double precision , allocatable :: v_grid(:, :)

  double precision :: dcs(n_wf, 10)

  integer :: status = 0
  integer :: ii, jj, nn

  integer :: fileunit = 10

  write (*, *) "h2_dissociate"

  ! set n_r and d_r
  r_max = 100.0d0
  d_r = 0.01d0
  n_r = ceiling(r_max / d_r) + 1

  ! allocate grids and wavefunctions
  allocate(r_grid(n_r))
  allocate(v_grid(n_r, 2))
  allocate(wf(n_r, n_wf, 2))

  ! initialise r_grid
  do ii = 1, n_r
    r_grid(ii) = d_r * dble(ii-1)
  end do

  ! initialise v_grid (for 1ssg/2psu)
  call interpolate_potential(n_r, r_grid, "PECS/PEC.1ssg", &
      v_grid(:, 1), status)

  call interpolate_potential(n_r, r_grid, "PECS/PEC.2psu", &
      v_grid(:, 2), status)

  ! initialise ek_grid (0 to 30ev)
  do nn = 1, n_wf
    ek_grid(nn) = 0.1d0 + (30.0d0 * (dble(nn - 1) / dble(n_wf - 1)))
  end do

  ! scale to Ha
  ek_grid(:) = ek_grid(:) / eV

  ! initialise dissociative energy
  D(:) = v_grid(n_r, :)

  ! initialise default wf
  wf(:, :, :) = 0.0d0

  ! calculate wavefunctions using numerov method
  do nn = 1, n_wf
    k = sqrt(2.0d0 * mu * ek_grid(nn))
    asym_amp = sqrt((2.0d0 * mu) / (k * PI))

    ! 1ssg
    call solve_h2_numerov(n_r, d_r, r_grid, v_grid(:, 1), &
        ek_grid(nn) + D(1), mu, wf(:, nn, 1), status)

    ! normalise (scale by asymptotic amplitude)
    wf(:, nn, 1) = (wf(:, nn, 1) / maxval(abs(wf(n_r/2:, nn, 1)))) * asym_amp

    ! terminate subroutine if numerov_cooley failed
    if (status /= 0) then
      write (*, *) "numerov_cooley() failed"
      write (*, *) "exiting h2_dissociate"
      call exit(status)
    end if

    ! 2psu
    call solve_h2_numerov(n_r, d_r, r_grid, v_grid(:, 2), &
        ek_grid(nn) + D(2),  mu, wf(:, nn, 2), status)

    ! normalise (scale by asymptotic amplitude)
    wf(:, nn, 2) = (wf(:, nn, 2) / maxval(abs(wf(n_r/2:, nn, 2)))) * asym_amp

    ! terminate subroutine if numerov_cooley failed
    if (status /= 0) then
      write (*, *) "numerov_cooley() failed"
      write (*, *) "exiting h2_dissociate"
      call exit(status)
    end if
  end do

  ! ! display
  ! write (*, *) "wavefunctions:"

  ! write (*, *) "1ssg:"
  ! call display_graph(n_r, r_grid, v_grid(:, 1))
  ! do nn = 1, min(n_wf, 10)
  !   write (*, *) "n  = ", int_trim(nn)
  !   write (*, *) "en = ", dp_trim(ek_grid(nn) + D(1))
  !   call display_graph(n_r, r_grid, wf(:, nn, 1))
  !   write (*, *)
  ! end do

  ! write (*, *) "2psu:"
  ! call display_graph(n_r, r_grid, v_grid(:, 2))
  ! do nn = 1, min(n_wf, 10)
  !   write (*, *) "n = ", int_trim(nn)
  !   write (*, *) "en = ", dp_trim(ek_grid(nn) + D(2))
  !   call display_graph(n_r, r_grid, wf(:, nn, 2))
  !   write (*, *)
  ! end do

  ! franck cordon-approx (using values from assignment 2)
  call franck_condon(n_r, r_grid, n_wf, wf, dcs, status)

  ! write functions to file
  open (unit=fileunit, file="output/vib/1ssg.txt")
  do ii = 1, n_r
    write (fileunit, *) r_grid(ii), &
        (0.002d0 * wf(ii,:,1)) + ek_grid(:) + D(1)
  end do
  close (fileunit)

  open (unit=fileunit, file="output/vib/2psu.txt")
  do ii = 1, n_r
    write (fileunit, *) r_grid(ii), &
        (0.002d0 * wf(ii,:,2)) + ek_grid(:) + D(2)
  end do
  close (fileunit)

  ! write franck-condon dcs to file
  open (unit=fileunit, file="output/vib/fc_1ssg.txt")
  do ii = 1, n_wf
    write (fileunit, *) ek_grid(ii) * eV, dcs(ii, :)
  end do
  close (fileunit)

  write (*, *) "end h2_dissociate"

end program p_h2_dissociate

! interpolate_potential
!
! For given <n_r>, <r_grid>, <filename>, read the potential from
! "<filename>" and interpolate the potential onto <r_grid>.
subroutine interpolate_potential (n_r, r_grid, filename, v_grid, status)
  implicit none

  integer , intent(in) :: n_r
  double precision , intent(in) :: r_grid(n_r)
  character(len=*) , intent(in) :: filename
  double precision , intent(out) :: v_grid(n_r)
  integer , intent(out) :: status
  double precision , allocatable :: r_grid_raw(:), v_grid_raw(:)
  double precision :: r, v
  integer :: n_r_raw
  integer :: fileunit
  integer :: ii
  integer :: io_status

  ! open file
  fileunit = 10

  open (unit=fileunit, file=trim(adjustl(filename)), action="read")

  n_r_raw = 0
  io_status = 0
  do while (io_status == 0)
    read (fileunit, *, iostat=io_status) r, v
    if (io_status == 0) then
      n_r_raw = n_r_raw + 1
    end if
  end do

  ! handle invalid file read
  if (n_r_raw == 0) then
    status = 1
  end if

  ! handle invalid file read
  if (status /= 0) then
    status = 1
    return
  end if

  ! re-open file at beginning
  close (fileunit)
  open (unit=fileunit, file=trim(adjustl(filename)), action="read")

  ! allocate <r_grid_raw>, <v_grid_raw>
  allocate(r_grid_raw(n_r_raw))
  allocate(v_grid_raw(n_r_raw))

  ! read potential file
  ii = 1
  io_status = 0
  do while ((ii <= n_r_raw) .and. (io_status == 0))
    read (fileunit, *, iostat=io_status) r_grid_raw(ii), v_grid_raw(ii)
    if (io_status == 0) then
      ii = ii + 1
    end if
  end do

  ! handle invalid file read
  if (ii <= n_r_raw) then
    status = 1
  end if

  ! handle invalid file read
  if (status /= 0) then
    status = 1
    return
  end if

  ! close file
  close (fileunit)

  ! interpolate <v_grid> on <r_grid> from <v_grid_raw> on <r_grid_raw>
  call INTRPL(n_r_raw-1, r_grid_raw, v_grid_raw, n_r, r_grid, v_grid)

end subroutine interpolate_potential

! solve_h2_numerov
subroutine solve_h2_numerov (n_r, step_size, r_grid, v_grid, energy, mu, &
    wf, status)
  use m_parameters
  use m_diffeq
  use m_integrate

  implicit none

  integer , intent(in) :: n_r
  double precision , intent(in) :: step_size
  double precision , intent(in) :: r_grid(n_r)
  double precision , intent(in) :: v_grid(n_r)
  double precision , intent(in) :: energy
  double precision , intent(in) :: mu
  double precision , intent(out) :: wf(n_r)
  integer , intent(out) :: status
  double precision :: g_grid(n_r), s_grid(n_r)

  ! debug
  write (*, *) "solve_h2_numerov()"

  ! check if arguments are valid
  status = 0

  if (n_r < 1) then
    ! no grid points
    status = 1
  end if

  if (step_size < 0.0d0) then
    ! non-positive step_size
    status = 2
  end if

  ! terminate subroutine if arguments are invalid, otherwise proceed
  if (status /= 0) then
    wf(:) = 0.0d0
    return
  end if

  ! set up g(x), s(x) for calls to numerov
  g_grid(:) = 2.0d0*mu*(energy - v_grid(:))
  s_grid(:) = 0.0d0

  ! set up boundary conditions
  wf(1) = 0.0d0
  ! wf(2) = 0.0d0
  wf(2) = 1.0d-6

  ! solve forwards numerov
  call numerov_f(n_r, step_size, s_grid, g_grid, wf, status)

  ! terminate subroutine if numerov_f failed
  if (status /= 0) then
    wf(:) = 0.0d0
    write (*, *) "numerov_f() failed"
    write (*, *) "exiting solve_h2_numerov()"
    return
  end if

  ! debug
  write (*, *) "end solve_h2_numerov()"

end subroutine solve_h2_numerov

! franck_condon
! Read vibrational wavefunctions from file for 1ssg
subroutine franck_condon (n_r, r_grid, n_wf, wf, dcs, status)
  use m_integrate

  implicit none

  integer , intent(in) :: n_r
  double precision , intent(in) :: r_grid(n_r)
  integer , intent(in) :: n_wf
  double precision , intent(in) :: wf(n_r, n_wf, 2)
  double precision , intent(out) :: dcs(n_wf, 10)
  integer , intent(out) :: status
  character(len=*) , parameter :: filename = "VIB/vibrational_wf_128.txt"
  double precision :: vib_wf(n_r, 128)
  double precision :: r
  integer :: fileunit
  integer :: ii, jj, nn
  integer :: io_status

  ! open file
  fileunit = 10

  open (unit=fileunit, file=trim(adjustl(filename)), action="read")

  ! read vibrational wavefunctions file
  ii = 1
  io_status = 0
  do while ((ii <= n_r) .and. (io_status == 0))
    read (fileunit, *, iostat=io_status) r, vib_wf(ii, :)
    if (io_status == 0) then
      ii = ii + 1
    end if
  end do

  ! handle invalid file read
  if (status /= 0) then
    status = 1
    return
  end if

  ! close file
  close (fileunit)

  ! calculate franck_condon factors (1ssg)
  dcs(:, :) = 0.0d0
  do jj = 1, 10
    do nn = 1, n_wf
      dcs(nn, jj) = &
          abs(integrate_trapezoid(n_r, r_grid, vib_wf(:, jj) * wf(:, nn, 1)))**2
    end do
  end do

end subroutine franck_condon


SUBROUTINE stiff4(km,coord,ym,pr)
!
! This subroutine generates the "analytical" stiffness matrix
! for a four node quadrilateral in plane strain based on nip=4.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::coord(:,:),ym,pr
 REAL(iwp),INTENT(OUT)::km(:,:)
 REAL(iwp)::e1,e2,g,x1,x2,x3,x4,y1,y2,y3,y4,a2,a2st3,alph,beta,c11,c21,   &
   c31,c41,c51,c61,c71,c81,c22,c32,c42,c52,c62,c72,c82,c33,c43,c53,c63,   &
   c73,c83,c44,c54,c64,c74,c84,c55,c65,c75,c85,c66,c76,c86,c77,c87,c88,   &
   f1,f2,s1,s2,s3,s4,t1,t2,t3,t4,pt5=0.5_iwp,one=1.0_iwp,two=2.0_iwp,     &
   d3=3.0_iwp,zero=0.0_iwp
 INTEGER::i,j
 e1=ym*(one-pr)/(one+pr)/(1-two*pr)
 e2=pr*e1/(one-pr)
 g=ym/two/(one+pr)
!
 x1=coord(1,1)
 x2=coord(2,1)
 x3=coord(3,1)
 x4=coord(4,1)
 y1=coord(1,2)
 y2=coord(2,2)
 y3=coord(3,2)
 y4=coord(4,2)
!
 a2=(x4-x2)*(y3-y1)-(x3-x1)*(y4-y2)
 a2st3=d3*a2*a2
!
 CALL groupa(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c11=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(1,1)=c11
!
 CALL groupa(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c33=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,3)=c33
!
 CALL groupa(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c55=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,5)=c55
!
 CALL groupa(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c77=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,7)=c77
!
 CALL groupa(y4,y3,y2,y1,x4,x3,x2,x1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c88=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,8)=c88
!
 CALL groupa(y1,y4,y3,y2,x1,x4,x3,x2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c22=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(2,2)=c22
!
 CALL groupa(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c44=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,4)=c44
!
 CALL groupa(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c66=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,6)=c66
!
 CALL groupb(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c21=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(2,1)=c21
!
 CALL groupb(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c43=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,3)=c43
!
 CALL groupb(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c65=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,5)=c65
!
 CALL groupb(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c87=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,7)=c87
!
 CALL groupc(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c31=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,1)=c31
!
 CALL groupc(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c53=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,3)=c53
!
 CALL groupc(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c75=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,5)=c75
!
 CALL groupc(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c71=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,1)=c71
!
 CALL groupc(y4,y3,y2,y1,x4,x3,x2,x1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c86=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,6)=c86
!
 CALL groupc(y1,y4,y3,y2,x1,x4,x3,x2,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c82=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,2)=c82
!
 CALL groupc(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c42=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,2)=c42
!
 CALL groupc(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c64=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,4)=c64
!
 CALL groupd(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c41=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(4,1)=c41
!
 CALL groupd(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c63=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,3)=c63
!
 CALL groupd(x3,x4,x1,x2,y3,y4,y1,y2,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x3,x4,x1,x2,y3,y4,y1,y2,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c85=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,5)=c85
!
 CALL groupd(x4,x1,x2,x3,y4,y1,y2,y3,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x4,x1,x2,x3,y4,y1,y2,y3,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c72=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,2)=c72
!
 CALL groupd(y1,y2,y3,y4,x1,x2,x3,x4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c32=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(3,2)=c32
!
 CALL groupd(y2,y3,y4,y1,x2,x3,x4,x1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c54=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,4)=c54
!
 CALL groupd(y3,y4,y1,y2,x3,x4,x1,x2,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x3,x4,x1,x2,y3,y4,y1,y2,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c76=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,6)=c76
!
 CALL groupd(y4,y1,y2,y3,x4,x1,x2,x3,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x4,x1,x2,x3,y4,y1,y2,y3,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c81=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,1)=c81
!
 CALL groupe(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c51=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,1)=c51
!
 CALL groupe(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c73=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,3)=c73
!
 CALL groupe(y2,y1,y4,y3,x2,x1,x4,x3,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c84=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,4)=c84
!
 CALL groupe(y3,y2,y1,y4,x3,x2,x1,x4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 alph=a2*(s1*e1+s2*g)+f1*(s3*e1+s4*g)
 beta=a2*(t1*e1+t2*g)+f2*(t3*e1+t4*g)
 c62=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,2)=c62
!
 CALL groupf(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c61=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(6,1)=c61
!
 CALL groupf(x2,x3,x4,x1,y2,y3,y4,y1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c83=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(8,3)=c83
!
 CALL groupf(y1,y2,y3,y4,x1,x2,x3,x4,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c52=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(5,2)=c52
!
 CALL groupf(y2,y3,y4,y1,x2,x3,x4,x1,s1,s2,s3,s4,t1,t2,t3,t4)
 CALL f1f2(x2,x3,x4,x1,y2,y3,y4,y1,f1,f2)
 alph=a2*(s1*e2+s2*g)+f1*(s3*e2+s4*g)
 beta=a2*(t1*e2+t2*g)+f2*(t3*e2+t4*g)
 c74=(alph/(a2st3-f1**2)+beta/(a2st3-f2**2))*pt5
 km(7,4)=c74
!
 DO i=1,8
   DO j=i+1,8
     km(i,j)=km(j,i)
   END DO
 END DO
!
RETURN
CONTAINS
SUBROUTINE groupa(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=two*(y4-y2)**2
 s2=two*(x4-x2)**2
 s3=-s1/two
 s4=-s2/two
 t1=(y2-y3)**2+(y3-y4)**2+(y4-y2)**2
 t2=(x2-x3)**2+(x3-x4)**2+(x4-x2)**2
 t3=(y4-y3)**2-(y3-y2)**2
 t4=(x4-x3)**2-(x3-x2)**2
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupa
SUBROUTINE groupb(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=two*(x2-x4)*(y4-y2)
 s2=s1
 s3=-s1/2
 s4=s3
 t1=x2*(y4-two*y2+y3)+x3*(y2-two*y3+y4)+x4*(y2-two*y4+y3)
 t2=t1
 t3=x2*(y2-y3)+x3*(y4-y2)+x4*(y3-y4)
 t4=t3
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupb
SUBROUTINE groupc(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=(y4-y2)*(two*y1-y3-y4)
 s2=(x4-x2)*(two*x1-x3-x4)
 s3=(y4-y2)*(y4-y1)
 s4=(x4-x2)*(x4-x1)
 t1=(y3-y1)*(two*y2-y3-y4)
 t2=(x3-x1)*(two*x2-x3-x4)
 t3=(y3-y1)*(y3-y2)
 t4=(x3-x1)*(x3-x2)
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupc
SUBROUTINE groupd(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4
 s1=(x3-x1)*(y4-y2)+(x4-x1)*(y4-y2)
 s2=(y3-y1)*(x4-x2)+(y4-y1)*(x4-x2)
 s3=(x4-x1)*(y2-y4)
 s4=(y4-y1)*(x2-x4)
 t1=(x3-x1)*(y4-y2)+(x3-x1)*(y3-y2)
 t2=(y3-y1)*(x4-x2)+(y3-y1)*(x3-x2)
 t3=(x3-x1)*(y2-y3)
 t4=(y3-y1)*(x2-x3)
RETURN
END SUBROUTINE groupd
SUBROUTINE groupe(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4,f1,f2
 s1=-(y4-y2)**2
 s2=-(x4-x2)**2
 s3=zero
 s4=zero
 t1=(y3+y1)*(y4+y2)-two*(y4-y2)**2-two*(y1*y3+y2*y4)
 t2=(x3+x1)*(x4+x2)-two*(x4-x2)**2-two*(x1*x3+x2*x4)
 t3=(y4-y2)*(y1-y2+y3-y4)
 t4=(x4-x2)*(x1-x2+x3-x4)
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE groupe
SUBROUTINE groupf(x1,x2,x3,x4,y1,y2,y3,y4,s1,s2,s3,s4,t1,t2,t3,t4)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::s1,s2,s3,s4,t1,t2,t3,t4
 s1=(x4-x2)*(y4-y2)
 s2=s1
 s3=zero
 s4=zero
 t1=(x4-x2)*(y4-y2)+(x2-x1)*(y2-y3)+(x4-x1)*(y4-y3)
 t2=(y4-y2)*(x4-x2)+(y2-y1)*(x2-x3)+(y4-y1)*(x4-x3)
 t3=(x2-x1)*(y3-y2)+(x4-x1)*(y4-y3)
 t4=(y2-y1)*(x3-x2)+(y4-y1)*(x4-x3)
RETURN
END SUBROUTINE groupf
SUBROUTINE f1f2(x1,x2,x3,x4,y1,y2,y3,y4,f1,f2)
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::x1,x2,x3,x4,y1,y2,y3,y4
 REAL(iwp),INTENT(OUT)::f1,f2
 f1=(x1+x3)*(y4-y2)-(y1+y3)*(x4-x2)-two*(x2*y4-x4*y2)
 f2=(y2+y4)*(x3-x1)-(x2+x4)*(y3-y1)-two*(x3*y1-x1*y3)
RETURN
END SUBROUTINE f1f2
END SUBROUTINE stiff4


program FizzBuzz
implicit none
integer :: i = 1

do i = 1, 100
    if (Mod(i,3) == 0)write(*,"(A)",advance='no')  "Fizz"
    if (Mod(i,5) == 0)write(*,"(A)",advance='no') "Buzz"
    if (Mod(i,3) /= 0 .and. Mod(i,5) /=0 )write(*,"(I3)",advance='no') i
    print *, ""
end do
end program FizzBuzz