SUBROUTINE d_com_light
!======================================
! d^2 COM light version
!======================================
! Calculates the squared distance of the Centre of Mass.
! No derivatives!
!=====================
   USE PARACLUSTER
   USE CLUSTER
   USE POTENTIAL
   USE ENFORCE
   USE DISTANCE
   USE META

   IMPLICIT NONE

   integer :: i
   REAL(8) :: cxa, cya, cza, cxb, cyb, czb
   REAL(8) :: d_com_x, d_com_y, d_com_z

   if (ipas.eq.1) write(*,*) 'd_com_light> first calculation of d_com'

   cxa = 0.d0
   cya = 0.d0
   cza = 0.d0
   cxb = 0.d0
   cyb = 0.d0
   czb = 0.d0
   DO i = 1, natom
      IF(itype(i).EQ.1) THEN
         cxa = cxa + u(i) +x(i)
         cya = cya + v(i) +y(i)
         cza = cza + w(i) +z(i)
      ELSE
         cxb = cxb + u(i) +x(i)
         cyb = cyb + v(i) +y(i)
         czb = czb + w(i) +z(i)
      ENDIF
   ENDDO
   cxa = cxa/natoma
   cya = cya/natoma
   cza = cza/natoma
   cxb = cxb/natomb
   cyb = cyb/natomb
   czb = czb/natomb

   d_com_x = cxa - cxb
   d_com_y = cya - cyb
   d_com_z = cza - czb

   d_com_cv = d_com_x*d_com_x +d_com_y*d_com_y +d_com_z*d_com_z

END SUBROUTINE d_com_light


C PROGRAM ORBE ver 3
C TABARE GALLARDO September 2016
C BASED ON EVORB (BRUNINI AND GALLARDO)
C www.astronomia.edu.uy/orbe
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 MPLA
      CHARACTER*50 FILEIN,FILEOU,ACOMM
      PARAMETER (NTT=100)
      DIMENSION XPLA(NTT,3),VPLA(NTT,3)
      DIMENSION APLA(NTT),EPLA(NTT)
      DIMENSION MPLA(NTT),RPLA(NTT)
      DIMENSION POS(3),VEL(3)
      COMMON/CTE/GM,GM0
C DATA INPUT
      FILEIN='orbeini.dat'
C OUTPUT
      FILEOU='orbeout.dat'
C UNIT TIME = JULIAN YEAR
C UNIT MASS = SOLAR MASS
C UNIT DISTANCE = AU
      PI=4.D0*DATAN(1.D0)
      DOSPI=2.D0*PI
      GAU=0.01720209895D0
      ANIO=365.25D0
      GM=(GAU*ANIO)**2
      GAR=PI/180.D0
C T INITIAL = 0
      CTIEMPO=0.D0
C      TINIC=0.D0
      T=0.D0
      WRITE(*,*)'O---------------------------------------------------O'
      WRITE(*,*)'|                       ORBE 3                      |'
      WRITE(*,*)'|              version September 2016               |'
      WRITE(*,*)'|            www.astronomia.edu.uy/orbe             |'
      WRITE(*,*)'O---------------------------------------------------O'
C READ DATA
      OPEN(2,FILE=FILEIN)
      READ(2,1004) ACOMM
      READ(2,*) CMASS    ! CENTRAL MASS
      READ(2,1004)ACOMM
      READ(2,*) TMAX         ! FINAL TIME IN YEARS
      READ(2,1004)ACOMM
      READ(2,*) TSAL         ! OUTPUT SNAPSHOTS
      GM0=GM*CMASS
      PEORBMIN=100000.0D0
      NPLA=0
      READ(2,1004)ACOMM               ! ORBITAL ELEMENTS
      DO 101 IU=1,100
            READ(2,*,END=500)A0,E0,XI0,XN0,W0,EME0,VAMA
	      NPLA=NPLA+1
	      XI0=XI0*GAR
	      I=NPLA
            EME0=EME0*GAR
	      XN0=XN0*GAR
	      W0=W0*GAR
C MEAN MOTION
	      ENE=DSQRT(GM*(CMASS+VAMA)/A0**3)
C MINIMUM ORBITAL PERIOD
            PEORB=DOSPI/ENE
            IF (PEORB.LT.PEORBMIN) THEN
                  PEORBMIN=PEORB
            ENDIF
C PERIHELION PASSAGE IN DAYS
            MPLA(I)=GM*VAMA
C INITIAL POTITION AND VELOCITY
            // SUBROUTINE POVE(a0,E0,XI0,  XN0,  W0, eme0, ene,POS,VEL)
            // SUBROUTINE POVE( A, E,  I,ANODE,PERI,    M,   N,  X, XP)
	      CALL POVE(a0,E0,XI0,XN0,W0,eme0,ene,POS,VEL)
            RPLA(I)=0.D0
	      DO J=1,3
	            RPLA(I)=RPLA(I)+POS(J)**2
	            XPLA(I,J)=POS(J)
	            VPLA(I,J)=VEL(J)
            ENDDO
	      RPLA(I)=DSQRT(RPLA(I))
101   CONTINUE
500   CLOSE(2)
C SAVE ORBITAL ELEMENTS FOR T=0
      OPEN(1,FILE=FILEOU,STATUS='UNKNOWN',ACCESS='APPEND')
      DO KK=1,NPLA
	      CALL PLANO(XPLA,VPLA,KK,CLINA,DOSPI,GM0,MPLA,ON,W,AMED,SE,SA)
	      WRITE(1,1001)T,KK,SA,SE,CLINA,ON,W,AMED
      ENDDO
      CLOSE(1)
C TIME STEP PEORBMIN/40 APROX
      PASO=PEORBMIN/40.D0
      PAS1=0.00001D0
      DO IU=1,7
            IF (PASO.GT.PAS1) THEN
                  H=PAS1
            ENDIF
            IF (PASO.GT.PAS1*2.D0) THEN
                  H=PAS1*2.D0
            ENDIF
            IF (PASO.GT.PAS1*5.D0) THEN
                  H=PAS1*5.D0
            ENDIF
            PAS1=PAS1*10.D0
      ENDDO
C TSAL MUST BE AN INTEGER NUMBER OF STEPS H
      TSAL=DNINT(TSAL/H)*H
      WRITE(*,*)'BODIES: ',NPLA
      WRITE(*,*)'FINAL TIME: ',TMAX
      WRITE(*,*)'TIMESTEP: ',H
C TMAX NEGATIVE INTEGRATE BACKWARDS
      IF(TMAX.LT.0.) H=-H

      HK = 0.5D0*H
200   TGRID=0.D0
210   TGRID=TGRID+H
      CTIEMPO=CTIEMPO+1.D0
      T=CTIEMPO*H
      CALL MOVIKEP(NPLA,HK,XPLA,VPLA,RPLA,APLA,EPLA,MPLA)
      CALL PERTURB(XPLA,VPLA,RPLA,NPLA,MPLA,H)
      CALL MOVIKEP(NPLA,HK,XPLA,VPLA,RPLA,APLA,EPLA,MPLA)
      IF (DABS(TGRID-DSIGN(TSAL,H)).LT.1.D-05) THEN
	      OPEN(1,FILE=FILEOU,STATUS='UNKNOWN',ACCESS='APPEND')
	      NSURVIVORS=NPLA

	      DO 50 KK=1,NPLA
C                 IF KK WAS ELIMINATED
	            IF(MPLA(KK).EQ.1.2345D-30) THEN
                        NSURVIVORS=NSURVIVORS-1
                        GOTO 50
	            ENDIF
	            CALL PLANO(XPLA,VPLA,KK,CLINA,DOSPI,GM0,MPLA,ON,W,AMED,SE,SA)
	            WRITE(1,1001)T,KK,SA,SE,CLINA,ON,W,AMED
50          CONTINUE

            CLOSE(1)
            WRITE(*,1012)T,NSURVIVORS
            GOTO 200
      ENDIF
      IF((TMAX-T)*DSIGN(1.D0,H).GT.0.) GOTO 210

1001  FORMAT(1P,E13.6,0P,I4,F13.6,F9.6,4F7.2)
1004  FORMAT(A50)
1012  FORMAT(F14.1,I8)
      STOP
      END
C ========================================================================
C ========================================================================
C ADVANCE KEPLERIAN MOTION HALF STEP
      SUBROUTINE MOVIKEP(NPLA,H,XPLA,VPLA,RPLA,APLA,EPLA,MPLA)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 MPLA
      PARAMETER (NTT=100)
      DIMENSION XPLA(NTT,3),VPLA(NTT,3)
      DIMENSION APLA(NTT),EPLA(NTT)
      DIMENSION RPLA(NTT),MPLA(NTT)
      DIMENSION POS(3),VEL(3)
      COMMON/CTE/GM,GM0
      DO 410 I=1,NPLA
C IF I WAS ELIMINATED
       	IF(MPLA(I).EQ.1.2345D-30) THEN
           GOTO 410
        ENDIF
	R0=RPLA(I)
	V02=VPLA(I,1)*VPLA(I,1)+VPLA(I,2)*VPLA(I,2)+VPLA(I,3)*VPLA(I,3)
        UA0=2.D0/R0-V02/(GM0+MPLA(I))
        A0=1.D0/UA0
        IF(A0.GT.99999.0.OR.A0.LT.0.0) THEN
C WE ELIMINATE THE BODY PUTTING AN ABSURDE MASS
          MPLA(I)=1.2345D-30
          APLA(I)=90000.D0
          WRITE(*,*) "BODY ELIMINATED: ",I
          GOTO 410
        ENDIF
	DO L=1,3
	  POS(L)=XPLA(I,L)
	  VEL(L)=VPLA(I,L)
	ENDDO
	ALPM=MPLA(I)
	CALL MOVREL(GM0,H,POS,VEL,R0,E0,ALPM)
	RPLA(I)=R0
	APLA(I)=A0
	EPLA(I)=E0
	DO L=1,3
	  XPLA(I,L)=POS(L)
	  VPLA(I,L)=VEL(L)
	ENDDO
410   CONTINUE
      RETURN
      END
C ========================================================================
C ========================================================================
C COMPUTE MUTUAL PERTURBATIONS IN ONE STEP
      SUBROUTINE PERTURB(XPLA,VPLA,RPLA,NPLA,MPLA,H)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 MPLA
      PARAMETER (NTT=100)
      DIMENSION XPLA(NTT,3),VPLA(NTT,3),RPLA(NTT)
      DIMENSION MPLA(NTT)
      DIMENSION FINDX(NTT),FINDY(NTT),FINDZ(NTT)
      DO 10 I=1,NPLA
C IF I WAS ELIMINATED
       	IF(MPLA(I).EQ.1.2345D-30) THEN
           GOTO 10
        ENDIF
	XGM=MPLA(I)
	RP3=XGM/RPLA(I)**3
	FINDX(I)=XPLA(I,1)*RP3
	FINDY(I)=XPLA(I,2)*RP3
	FINDZ(I)=XPLA(I,3)*RP3
 10   continue
      DO 20 I=1,NPLA
C IF I WAS ELIMINATED
       	IF(MPLA(I).EQ.1.2345D-30) THEN
           GOTO 20
        ENDIF
        DO 30 J=I+1,NPLA
C IF J WAS ELIMINATED
          IF(MPLA(J).EQ.1.2345D-30) THEN
            GOTO 30
          ENDIF
	  DX=XPLA(I,1)-XPLA(J,1)
	  DY=XPLA(I,2)-XPLA(J,2)
	  DZ=XPLA(I,3)-XPLA(J,3)
	  DRQ=DX*DX+DY*DY+DZ*DZ
	  DIJ3=DSQRT(DRQ)**3
	  DX=DX/DIJ3
	  DY=DY/DIJ3
	  DZ=DZ/DIJ3
	  PIJX=MPLA(I)*DX-FINDX(I)
	  PIJY=MPLA(I)*DY-FINDY(I)
	  PIJZ=MPLA(I)*DZ-FINDZ(I)
	  VPLA(J,1)=VPLA(J,1)+H*PIJX
	  VPLA(J,2)=VPLA(J,2)+H*PIJY
	  VPLA(J,3)=VPLA(J,3)+H*PIJZ
	  PJIX=-MPLA(J)*DX-FINDX(J)
	  PJIY=-MPLA(J)*DY-FINDY(J)
	  PJIZ=-MPLA(J)*DZ-FINDZ(J)
	  VPLA(I,1)=VPLA(I,1)+H*PJIX
	  VPLA(I,2)=VPLA(I,2)+H*PJIY
	  VPLA(I,3)=VPLA(I,3)+H*PJIZ
 30     continue
 20   continue
      RETURN
      END
C ========================================================================
C ========================================================================
C SOLVING KEPLER EQUATION
      SUBROUTINE SOLKEP(EX,M,E)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 M,MK
      TOLE=1.D-14
      DOSPI=8.D0*DATAN(1.D0)
      M=DMOD(M,DOSPI)
      E=M
 100  E0=E
      SE=DSIN(E0)
      CE=DCOS(E0)
      ES=EX*SE
      EC=1.D0-EX*CE
      MK=E0-ES
      U=(MK-M)/EC
      XPRI=E0-U
      XSEG=E0-U/(1.D0-U*ES)
      E=(XPRI+XSEG)/2.D0
      DEX=DABS(E-E0)
      IF(DEX.GT.TOLE)GOTO 100
	RETURN
      END
C ========================================================================
C ========================================================================
C CALCULATING ORBITAL ELEMENTS
      SUBROUTINE PLANO(XPLA,VPLA,I,INCLI,DOSPI,GM0,MPLA,ON,W,AMED,SE,SA)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 INCLI,MPLA
      PARAMETER (NTT=100)
      DIMENSION XPLA(NTT,3),VPLA(NTT,3),MPLA(NTT)
      ERR=1.D-12
      XX=XPLA(I,1)
      YY=XPLA(I,2)
      ZZ=XPLA(I,3)
      R=DSQRT(XX*XX+YY*YY+ZZ*ZZ)
      VX=VPLA(I,1)
      VY=VPLA(I,2)
      VZ=VPLA(I,3)
      V2=VX*VX+VY*VY+VZ*VZ
      HX=YY*VZ-ZZ*VY
      HY=ZZ*VX-XX*VZ
      HZ=XX*VY-YY*VX
      HHXY=DSQRT(HX*HX+HY*HY)
      YN=DATAN2(HHXY,hz)
      INCLI=YN
      ON=DATAN2(HX,-HY)
      IF(ON.LT.0D0) THEN
        ON=ON+DOSPI
      END IF
      CMU=GM0+MPLA(I)
      EX=(VY*HZ-VZ*HY)/CMU-XX/R
      EY=(VZ*HX-VX*HZ)/CMU-YY/R
      EZ=(VX*HY-VY*HX)/CMU-ZZ/R
      EE=DSQRT(EX*EX+EY*EY+EZ*EZ)
      SE=EE
C IF INCLINATION IS 0 OR 180
C IN THIS CASE W IS THE LONGITUDE OF PERIHELION
      IF (SIN(YN).LT.ERR) THEN
        ON=0.D0
        W=DATAN2(EY,EX)
        ELSE
        SEW=EZ/DSIN(YN)
        COW=EX*DCOS(ON)+EY*DSIN(ON)
        W=DATAN2(SEW,COW)
      ENDIF
      IF (W.LT.0D0) THEN
        W=W+DOSPI
      END IF
      A=1.D0/(2.D0/R-V2/CMU)
      IF (A.GT.99999.0.OR.A.LT.0.0) THEN
C WE ELIMINATE THE BODY PUTTING AN ABSURDE MASS
          MPLA(I)=1.2345D-30
          SA=90000.D0
          WRITE(*,*) "BODY ELIMINATED: ",I
          RETURN
      ENDIF
      SA=A
      AE=0D0
      IF (A.GT.0.D0) THEN
        SEE=(XX*VX+YY*VY+ZZ*VZ)/DSQRT(A*CMU)
        COE=1.D0-R/A
        AE=DATAN2(SEE,COE)
        IF (AE.LT.0D0) THEN
          AE=AE+DOSPI
        END IF
        AMED=AE-EE*DSIN(AE)
        AMED=DMOD(AMED,DOSPI)
        IF (AMED.LT.0D0) THEN
          AMED=AMED+DOSPI
        END IF
      END IF
      INCLI=INCLI/DOSPI*36.D1
      ON=ON/DOSPI*36.D1
      W=W/DOSPI*36.D1
      AMED=AMED/DOSPI*36.D1
      RETURN
      END
C ========================================================================
C ========================================================================
C COMPUTE INITIAL POSITION AND VELOCITY
SUBROUTINE POVE(A,E,I,ANODE,PERI,M,N,X,XP)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 I,M,N
      DIMENSION X(3),XP(3)
      D2=2.D0
      CALL SOLKEP(E,M,EX)
      V=D2*DATAN(DSQRT((1.D0+E)/(1.D0-E))*(DSIN(EX/D2)/DCOS(EX/D2)))
      R=A*(1.D0-E*DCOS(EX))
      BETA=N*A/DSQRT(1.D0-E*E)
      X1=R*DCOS(V)
      X2=R*DSIN(V)
      XP1=-BETA*DSIN(V)
      XP2= BETA*(E+DCOS(V))
      CK=DCOS(ANODE)
      SK=DSIN(ANODE)
      CI=DCOS(I)
      SI=DSIN(I)
      CO=DCOS(PERI)
      SO=DSIN(PERI)
C VECTORS P AND Q
      P1=CK*CO-SK*CI*SO
      P2=SK*CO+CK*CI*SO
      P3=SI*SO
      Q1=-CK*SO-SK*CI*CO
      Q2=-SK*SO+CK*CI*CO
      Q3= SI*CO
C POSITION AND VELOCITY
      X(1)=P1*X1+Q1*X2
      X(2)=P2*X1+Q2*X2
      X(3)=P3*X1+Q3*X2
      XP(1)=P1*XP1+Q1*XP2
      XP(2)=P2*XP1+Q2*XP2
      XP(3)=P3*XP1+Q3*XP2
      RETURN
END
C ========================================================================
C ========================================================================
      SUBROUTINE MOVREL(GM0,DT,X,V,R,E,ALPM)
      IMPLICIT REAL*8(A-H,O-Z)
      DIMENSION X(3),V(3)
      GGM=GM0+ALPM
      VQ=V(1)*V(1)+V(2)*V(2)+V(3)*V(3)
      A=1.D0/((2.D0/R)-VQ/GGM)
      EC=1.D0-R/A
      U=X(1)*V(1)+X(2)*V(2)+X(3)*V(3)
      EN=SQRT(GGM/(A*A*A))
      ES=U/(EN*A*A)
      E=DSQRT(EC*EC+ES*ES)
      CALL KEPREL(ES,EC,EN,DT,DX,C,S,FP)
      F=(A/R)*(C-1.D0)+1.D0
      G=DT+(S-DX)/EN
      FDOT=-A*EN*S/(R*FP)
      GDOT=1.D0+(C-1.D0)/FP
      X1=X(1)*F+V(1)*G
      X2=X(2)*F+V(2)*G
      X3=X(3)*F+V(3)*G
      V1=X(1)*FDOT+V(1)*GDOT
      V2=X(2)*FDOT+V(2)*GDOT
      V3=X(3)*FDOT+V(3)*GDOT
      X(1)=X1
      X(2)=X2
      X(3)=X3
      V(1)=V1
      V(2)=V2
      V(3)=V3
      R=DSQRT(X(1)*X(1)+X(2)*X(2)+X(3)*X(3))
      RETURN
      END
C ========================================================================
C ========================================================================
C SOLVING KEPLER EQUATION FOR DT
      SUBROUTINE KEPREL(ES,EC,EN,DT,X,C,S,FP)
      IMPLICIT REAL*8(A-H,O-Z)
      TOL=1.D-13
      ENDT=EN*DT
      X=ENDT
100   S=DSIN(X)
      C=DCOS(X)
      F=X-EC*S+ES*(1.D0-C)-ENDT
      FP=1.D0-EC*C+ES*S
      FPP=EC*S+ES*C
      FPPP=EC*C-ES*S
      DX=-F/FP
      DX=-F/(FP+DX*FPP/2.D0)
      DX=-F/(FP+DX*FPP/2.D0+DX*DX*FPPP/6.D0)
      X=X+DX
      IF(DABS(DX).GT.TOL)GOTO 100
      RETURN
      END
C ========================================================================
C ========================================================================


c     ============================================
      subroutine setaux(maxmx,maxmy,mbc,mx,my,xlower,ylower,dxc,dyc,
     &                  maux,aux)
c     ============================================
c
c
c     #    aux(i,j,1)  = ax
c     #    aux(i,j,2)  = ay   where (ax,ay) is unit normal to left face
c     #    aux(i,j,3)  = ratio of length of left face to dyc
c
c     #    aux(i,j,4)  = bx
c     #    aux(i,j,5)  = by   where (bx,by) is unit normal to bottom face
c     #    aux(i,j,6)  = ratio of length of bottom face to dxc
c
c     #    aux(i,j,7)  = ratio of cell area to dxc*dyc
c     #                  (approximately Jacobian of mapping function)
c
c     #    aux(i,j,8)  = impedance Z in cell (i,j)
c     #    aux(i,j,9)  = sound speed c in cell (i,j)
c
c
      implicit double precision (a-h,o-z)
      dimension aux(1-mbc:maxmx+mbc,1-mbc:maxmy+mbc, 9)
      dimension xccorn(5),yccorn(5),xpcorn(5),ypcorn(5)
      common /cparam/ rho,bulk,cc,zz
c

      dx2 = dxc/2.d0
      dy2 = dyc/2.d0
c
      do 20 j=1-mbc,my+mbc
         do 20 i=1-mbc,mx+mbc
c
c           # computational points (xc,yc) are mapped to physical
c           # coordinates (xp,yp) by mapc2p:
c
c           # lower left corner:
            xccorn(1) = xlower + (i-1)*dxc
            yccorn(1) = ylower + (j-1)*dyc
            call mapc2p(xccorn(1),yccorn(1),xpcorn(1),ypcorn(1))

c           # upper left corner:
            xccorn(2) = xccorn(1)
            yccorn(2) = yccorn(1) + dyc
            call mapc2p(xccorn(2),yccorn(2),xpcorn(2),ypcorn(2))
c
c           # upper right corner:
            xccorn(3) = xccorn(1) + dxc
            yccorn(3) = yccorn(1) + dyc
            call mapc2p(xccorn(3),yccorn(3),xpcorn(3),ypcorn(3))
c
c           # lower right corner:
            xccorn(4) = xccorn(1) + dxc
            yccorn(4) = yccorn(1)
            call mapc2p(xccorn(4),yccorn(4),xpcorn(4),ypcorn(4))
c
c           # compute normals to left and bottom side:
c
            ax =  (ypcorn(2) - ypcorn(1))
            ay = -(xpcorn(2) - xpcorn(1))
            anorm = dsqrt(ax*ax + ay*ay)
            aux(i,j,1) = ax/anorm
            aux(i,j,2) = ay/anorm
            aux(i,j,3) = anorm/dyc
c
            bx = -(ypcorn(4) - ypcorn(1))
            by =  (xpcorn(4) - xpcorn(1))
            bnorm = dsqrt(bx*bx + by*by)
            aux(i,j,4) = bx/bnorm
            aux(i,j,5) = by/bnorm
            aux(i,j,6) = bnorm/dxc
c
c           # compute area of physical cell from four corners:

            xpcorn(5) = xpcorn(1)
            ypcorn(5) = ypcorn(1)
            area = 0.d0
            do ic=1,4
              area = area + 0.5d0 * (ypcorn(ic)+ypcorn(ic+1)) *
     &               (xpcorn(ic+1)-xpcorn(ic))
              enddo
            aux(i,j,7) = area / (dxc*dyc)
c
            aux(i,j,8) = zz
            aux(i,j,9) = cc

   20       continue
c
       return

       end


      SUBROUTINE DJACOBI(A,N,NP,D,V,NROT)
      implicit double precision(a-h,o-z)
      PARAMETER (NMAX=510)
      DIMENSION A(NP,NP),D(NP),V(NP,NP),B(NMAX),Z(NMAX)
      DO 12 IP=1,N
        DO 11 IQ=1,N
          V(IP,IQ)=0.d0
11      CONTINUE
        V(IP,IP)=1.d0
12    CONTINUE
      DO 13 IP=1,N
        B(IP)=A(IP,IP)
        D(IP)=B(IP)
        Z(IP)=0.d0
13    CONTINUE
      NROT=0
      DO 24 I=1,50
        SM=0.d0
        DO 15 IP=1,N-1
          DO 14 IQ=IP+1,N
            SM=SM+dABS(A(IP,IQ))
14        CONTINUE
15      CONTINUE
        IF(SM.EQ.0.d0)RETURN
        IF(I.LT.4)THEN
          TRESH=0.2d0*SM/N**2
        ELSE
          TRESH=0.d0
        ENDIF
        DO 22 IP=1,N-1
          DO 21 IQ=IP+1,N
            G=100.d0*dABS(A(IP,IQ))
            IF((I.GT.4).AND.(dABS(D(IP))+G.EQ.dABS(D(IP)))
     *         .AND.(dABS(D(IQ))+G.EQ.dABS(D(IQ))))THEN
              A(IP,IQ)=0.d0
            ELSE IF(dABS(A(IP,IQ)).GT.TRESH)THEN
              H=D(IQ)-D(IP)
              IF(dABS(H)+G.EQ.dABS(H))THEN
                T=A(IP,IQ)/H
              ELSE
                THETA=0.5d0*H/A(IP,IQ)
                T=1.d0/(dABS(THETA)+dSQRT(1.d0+THETA**2))
                IF(THETA.LT.0.)T=-T
              ENDIF
              C=1.d0/dSQRT(1+T**2)
              S=T*C
              TAU=S/(1.d0+C)
              H=T*A(IP,IQ)
              Z(IP)=Z(IP)-H
              Z(IQ)=Z(IQ)+H
              D(IP)=D(IP)-H
              D(IQ)=D(IQ)+H
              A(IP,IQ)=0.d0
              DO 16 J=1,IP-1
                G=A(J,IP)
                H=A(J,IQ)
                A(J,IP)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
16            CONTINUE
              DO 17 J=IP+1,IQ-1
                G=A(IP,J)
                H=A(J,IQ)
                A(IP,J)=G-S*(H+G*TAU)
                A(J,IQ)=H+S*(G-H*TAU)
17            CONTINUE
              DO 18 J=IQ+1,N
                G=A(IP,J)
                H=A(IQ,J)
                A(IP,J)=G-S*(H+G*TAU)
                A(IQ,J)=H+S*(G-H*TAU)
18            CONTINUE
              DO 19 J=1,N
                G=V(J,IP)
                H=V(J,IQ)
                V(J,IP)=G-S*(H+G*TAU)
                V(J,IQ)=H+S*(G-H*TAU)
19            CONTINUE
              NROT=NROT+1
            ENDIF
21        CONTINUE
22      CONTINUE
        DO 23 IP=1,N
          B(IP)=B(IP)+Z(IP)
          D(IP)=B(IP)
          Z(IP)=0.d0
23      CONTINUE
24    CONTINUE
      PAUSE '50 iterations should never happen'
      RETURN
      END


!  *********************************************************************
!  *                                                                   *
!  *                S U B R O U T I N E   L E A F N O                  *
!  *                                                      de   2/05/08 *
!  *                                                                   *
!  *                                                                   *
!  *********************************************************************
!  The LEAFNO subroutine calculates the number of leaves per day.
!  Variable definitions:
!     daynum = the integer version of day of year
!     gdde = the accumulated growing degree-days since emergence
!     lnarray = an array to hold the leaf number calculated for each day
!     lncntr = counter for the leafno subroutine
!     lnpout = an array to hold the leaf number when it changes to the
!       next whole number, i.e. the interger version of the real leaf number
!     pchron = the number of growing degree-days required to produce another leaf
!     rowcntr = a counter for the rows in an array
!     todayln = the value of the current day's leaf number
!     yestln = the value of yesterday's leaf number

      subroutine leafno(daynum, gdde, lnarray, lncntr, lnpout, pchron,
     c  rowcntr, todayln, yestln)

      implicit none

      integer daynum, lncntr, rowcntr

      real gdde, lnarray(600,2), lnpout(100,2), pchron, todayln,
     c yestln

! Local variables
      integer  col, nextcol
      real doy, ln

! Initialize variables
      doy = daynum ! day of year.  doy is real and daynum is integer
      ln = 0.0     ! leaf number
      col = 1      ! column number one
      nextcol = 2  ! column number two

! Fill arrays
        ln = gdde/pchron  ! Calculate leaf number for current day
        lncntr = lncntr + 1 ! increment counter
        lnarray (lncntr,col) = daynum ! Fill leaf number array
        lnarray (lncntr,nextcol) = ln

 !Set todayln to the value in the lnarray for today.
        todayln = lnarray(lncntr, nextcol)

      ! fill leaf output array when the integer version of yesterday's
      ! leaf number is less than the integer version of today's leaf
      ! number
        if ((int(yestln)) .lt. (int(todayln))) then
              rowcntr = rowcntr + 1 ! increment the row counter
              lnpout(rowcntr,col) = doy
              lnpout(rowcntr, nextcol) = ln
        end if
        yestln = lnarray(lncntr, nextcol)

      return
      end


Function subcr3(t, u)
  Implicit Double Precision (A-H, O-Z)
  subcr3 = 4.D0/9.D0*(t**2+u**2+(1.D0+u**2)/t**2-2.D0*u**2/3.D0/t)
  Return
End Function subcr3


*###[ ffbndc:
	DOUBLE PRECISION function ffbndc(n1,n2,carray)
*************************************************************************
*									*
*	calculate bound = (precc*|a(n1)/a(n1+n2)|^(1/n2) which is the	*
*	maximum value of x in a series expansion sum_(i=n1)^(n1+n2)	*
*	a(i)*x(i) to give a result of accuracy precc (actually of |next	*
*	term| < prec							*
*									*
*************************************************************************
	implicit none
	integer n1,n2
	DOUBLE COMPLEX carray(n1+n2)
	include 'ff.h'
	if ( carray(n1+n2) .eq. 0 ) then
	   print *,'ffbnd: fatal: array not intialized; did you call ',
     +		'ffini?'
	   stop
	endif
	ffbndc = (precc*abs(carray(n1)/carray(n1+n2)))**(1/DBLE(n2))
*###] ffbndc:
	end


      function gaunt(l1,m1,l2,m2,l3,m3,lmax,ngauss,
     >              wg,plmg,clm)
c     ****************************************************************
c
c               4pi  _  m1 _     m2* _     m3 _
c       gaunt = int do Y  (o) * Y   (o) * Y  (o)
c                0      l1       l2        l3
c
c                L3
c             = C
c                L1,L2
c
c     ****************************************************************
c
c  Inputs: l1,m1,l2,m2,l3,m3   integer scalars, (l,m) indices of the gaunt
c                              number
c          lmax     integer scalar, max l values allowed, lmax >= max(l1,l2,l3)
c                   lmax also determines the array dimensions of plmg and clm
c          ngauss   integer scaler, Number of gaussian points for integration
c          wg       real*8 array of (ngauss), weights for mesh points
c                   wg are the Gauss-Legendre integration weights
c          plmg     real*8 array of ((lmax+1)*(lmax+2)/2,ngauss), where
c                   l=max(l1,l2,l3), the values of the associate Legendre
c                   function at the mesh points
c                   plmg is output of plglmax
c          clm      real*8 array of ((lmax+1)*(lmax+2)/2), prefactors for the
c                   spherical harmonics
c                   clm is output of getclm
c
      implicit  none
c
      integer   l1
      integer   l2
      integer   l3
      integer   m1
      integer   m2
      integer   m3
      integer   lmax,ngauss
      integer   ng
      integer   ifac1
      integer   jl1
      integer   ifac2
      integer   jl2
      integer   ifac3
      integer   jl3
c
      real*8    wg(ngauss)
      real*8    plmg((lmax+1)*(lmax+2)/2,ngauss)
      real*8    clm((lmax+1)*(lmax+2)/2)
      real*8    gaunt,gaunt_val
      real*8    zero
      real*8    four
c
      parameter (zero=0.d0)
      parameter (four=4.d0)
      real*8    pi,fourpi
      parameter (pi=3.141592653589793d0)
      parameter (fourpi=four*pi)
c
      if(l1.gt.lmax .or. l2.gt.lmax .or. l3.gt.lmax ) then
         write(6,'(''gaunt:: bad parameters: l1,l2,l3,lmax'',4i5)')
     >                                       l1,l2,l3,lmax
         stop'gaunt'
      endif
      gaunt_val=zero
      if(mod(l1+l2+l3,2).ne.0) then
         return
      else
         if(m1-m2+m3 .ne. 0) then
            return
         else
            if(l1+l2.lt.l3 .or. l2+l3.lt.l1 .or. l3+l1.lt.l2) then
               return
            else
c              -------------------------------------------------------
               call defac(l1, m1,ifac1,jl1)
               call defac(l2,-m2,ifac2,jl2)
               call defac(l3, m3,ifac3,jl3)
c              -------------------------------------------------------
               do ng=1,ngauss
                  gaunt_val=gaunt_val+wg(ng)*plmg(jl1,ng)*
     >                 plmg(jl2,ng)*
     >                 plmg(jl3,ng)
               enddo
	       if(abs(gaunt_val).lt.1.d-14) then
		 gaunt_val=0.d0
	       else
               gaunt_val=fourpi*gaunt_val*ifac1*clm(jl1)*
     &              (1-2*mod(abs(m2),2))*ifac2*clm(jl2)*ifac3*clm(jl3)
	       endif
            endif
         endif
      endif

      gaunt=gaunt_val
      return
      end
c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine defac(l,m,ifac,jl)
c     ================================================================
c
      implicit   none
c
      integer    l,m
      integer    jl
      integer    ifac
c
c     ================================================================
      if (m.ge.0) then
         ifac= 1
         jl = (l+1)*(l+2)/2-l+m
      else
         ifac= (1-2*mod(abs(m),2))
         jl = (l+1)*(l+2)/2-l-m
      end if
c
      return
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM EXMPL3
C     Example 3: Bound states in a one-dimensional potential
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company, Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT           !display header screen, setup parameters
5     CONTINUE            !main loop; execute once for each set of param
         CALL PARAM       !get input parameters
         CALL ARCHON      !solve time-independent Schroedinger equation
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C solves the time-independent Schroedinger equation for 1-dimensional
C potential; allows for more than one eigenvalue search
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
C Local variables:
      REAL ENERGY(MAXLEV)            !array of eigenvalues
      INTEGER LEFTTP(MAXLEV),RGHTTP(MAXLEV)   !array of turning points
      INTEGER NFOUND                 !number of levels found
      REAL PSI(MAXLAT)               !wave function
      INTEGER ITER                   !continue finding levels?
      INTEGER NODES                  !number of nodes
      REAL E                         !trial eigenenergy
      INTEGER LTP,RTP                !classical turning points (lattice)
      REAL DE,DESAVE                 !step in energy search
      INTEGER NSTP                   !number of steps taken in search
      INTEGER SCREEN                 !send to terminal
      INTEGER PAPER                  !make a hardcopy
      INTEGER FILE                   !send to a file
C Functions:
      REAL GETFLT                    !obtain real input
      INTEGER YESNO                  !obtain yes or no input
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT)
      IF (TFILE) CALL PRMOUT(TUNIT)
      IF (GFILE) CALL PRMOUT(GUNIT)
C
      ITER=1                          !initialize searching variables
      NFOUND=0
      E=EBOTTM                        !reasonable starting values
      DE=DEBOT
C
5     IF (ITER .EQ . 1) THEN          !loop over energy levels
C
          E=GETFLT(E,EMIN,EMAX,'Enter energy')     !get starting values
          DE=GETFLT(DE,DEMIN,DEMAX,'Enter step in energy search')
          DESAVE=DE                   !save for next level
C
          IF (TTERM) CALL CTITL(OUNIT)!output titles
          IF (TFILE) CALL CTITL(TUNIT)
C
          CALL SEARCH(E,DE,LTP,RTP,NODES,NSTP,PSI) !search for energy
C
C         prompt for new E and DE if too many steps taken in search
          IF (NSTP .GE. MAXSTP) THEN
              WRITE (OUNIT,*) ' '
              WRITE (OUNIT,*) ' Eigenstate not yet found'
              ITER=YESNO(1,
     +          'Do you want to try again with new E or DE?')
          ELSE
C         or output eigenvalue information
            IF (TTERM) CALL EOUT(E,LTP,RTP,NODES,OUNIT)
            IF (TFILE) CALL EOUT(E,LTP,RTP,NODES,TUNIT)
            IF (GFILE) CALL EOUT(E,LTP,RTP,NODES,GUNIT)
C           save energy and turning points
            IF (NFOUND .EQ. MAXLEV) THEN
               NFOUND=0
               WRITE (OUNIT,*) ' Storage capacity for levels exceeded'
               WRITE (OUNIT,*) ' Old information will be overwritten'
            END IF
            NFOUND=NFOUND+1
            ENERGY(NFOUND)=E
            LEFTTP(NFOUND)=LTP
            RGHTTP(NFOUND)=RTP
C
            IF (TTERM) CALL PAUSE('to continue...',1)
            IF (TTERM) CALL CLEAR
C
            IF (GTERM) THEN             !graphics output
               CALL GRFOUT(SCREEN,ENERGY,LEFTTP,RGHTTP,NFOUND,PSI)
               CALL CLEAR
            END IF
            IF (GFILE) CALL GRFOUT(FILE,ENERGY,LEFTTP,RGHTTP,NFOUND,PSI)
            IF (GHRDCP)
     +          CALL GRFOUT(PAPER,ENERGY,LEFTTP,RGHTTP,NFOUND,PSI)
C
C           check if another level is to be found
            WRITE (OUNIT,*) ' '
            WRITE (OUNIT,*) ' '
            ITER=YESNO(1,'Do you want to find another level?')
C
          END IF
C
          E=E+DESAVE          !reasonable starting values for next level
          DE=DESAVE
C
      GOTO 5
      END IF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE SEARCH(E,DE,LTP,RTP,NODES,NSTP,PSI)
C search for one eigenvalue beginning with energy E and step DE
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
C Passed variables:
      INTEGER NODES          !number of nodes (output)
      REAL E                 !trial eigenenergy, true eigenenergy (I/O)
      INTEGER LTP,RTP        !classical turning points (lattice)(output)
      REAL DE                !step in energy search (input)
      INTEGER NSTP           !number of steps taken in search (output)
      REAL PSI(MAXLAT)       !wave function (output)
C Local variables:
      LOGICAL SECANT         !are we doing secant search yet?
      REAL F,FOLD,FSTART     !values of the mismatch
      REAL EOLD              !last value of the energy
      INTEGER NCROSS         !classically forbidden regions
      LOGICAL FIRST          !signal first step in search
      INTEGER NLINES         !number of lines sent to screen
C Functions:
      REAL GETFLT            !obtain real input
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      FIRST=.TRUE.           !first call to NUMERV for this level
      SECANT=.FALSE.         !start off with simple search
      F=TOLF                 !dummy value to get into loop
      NLINES=2
      NSTP=0
C
C    search for eigenenergy until F is small enough or too many
C    steps are taken
10    IF ((ABS(F) .GE. TOLF) .AND. (NSTP .LT. MAXSTP)) THEN
          NSTP=NSTP+1
C         integ Schroedinger equation; find discontinuity in derivative
          CALL NUMERV (F,NODES,E,LTP,RTP,NCROSS,FIRST,PSI)
          IF (FIRST .EQV. .TRUE.) THEN
              FSTART=F
              FIRST=.FALSE.
          END IF
          IF (F*FSTART  .LE. 0.) SECANT=.TRUE.
          IF ((SECANT .EQV. .TRUE.) .AND. (F .NE. FOLD)) THEN
              DE=-F*(E-EOLD)/(F-FOLD)
          END IF
C
          IF (TTERM) CALL TXTOUT(OUNIT,E,DE,F,NODES,NCROSS,NLINES)
          IF (TFILE) CALL TXTOUT(TUNIT,E,DE,F,NODES,NCROSS,NLINES)
C
          EOLD=E             !update values for next step
          FOLD=F
          E=E+DE
C
C         keep energy greater than VMIN=-1
          IF (E .LT. -1.) THEN
              WRITE (OUNIT,*) ' Energy is less than -1.'
              E=GETFLT(-.99,EMIN,EMAX,' Enter new energy')
              DE=GETFLT(DE,DEMIN,DEMAX,'Enter step in energy search')
          END IF
C
C         end search if DE is smaller than machine precision
          IF ((ABS(DE) .LT. DEMIN) .AND. (ABS(F) .GT. TOLF)) THEN
             WRITE (OUNIT,20)
20           FORMAT('0',21X,'Delta E is too small, search must stop')
             F=TOLF/2             !dummy value to end search
          END IF
C
      GOTO 10
      END IF
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE NUMERV (F,NODES,E,LTP,RTP,NCROSS,FIRST,PSI)
C subroutine to integrate time independent Schroedinger equation
C with energy=E
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E3'
C Passed variables:
      REAL F                     !size of mismatch (output)
      INTEGER NODES              !number of nodes (output)
      REAL E                     !trial eigenvalue (input)
      INTEGER LTP,RTP            !classical turning points (output)
      INTEGER NCROSS             !classically forbidden regions (output)
      LOGICAL FIRST              !signal first step in search (output)
      REAL PSI(MAXLAT)           !wave function (output)
C Local variables:
      INTEGER IMATCH             !matching lattice point
      REAL C                     !useful constant
      INTEGER IX,KX              !X indices
      REAL KI,KIM1,KIP1          !terms in Numerov algorithm
      REAL NORM                  !norm of wave function
      REAL PMMTCH,PPMTCH         !PSI at match point
      LOGICAL FLIP               !do we need to flip sign of PSI
      Real PSIMAX                !max value of wave function
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (FIRST .EQV. .TRUE.) IMATCH=0   !signals search for IMATCH
      C=(DX*DX/12)*GAMMA*GAMMA           !evaluate constant
C
C     find IMATCH once per energy level by looking for entry
C     into classically forbidden regions
      IX=1
      KIM1=C*(E-V(IX))
1     IF (IMATCH .EQ. 0) THEN
         IX=IX+1
         KI=C*(E-V(IX))    !neg value of K indicates class frbdn region
         IF ((KI*KIM1 .LT. 0) .AND. (KIM1 .GT. 0)) IMATCH=IX
C        if other procedure fails to find IMATCH, set IMATCH=NPTS-10
         IF (IX .EQ. NPTS-10) IMATCH=IX
         KIM1=KI
      GOTO 1
      END IF
C
      PSI(1)=0                     !left hand side bound. cond.
      PSI(2)=9.999999E-10
      KIM1=C*(E-V(1))              !initial K*K values
      KI=C*(E-V(2))
C
C     Numerov algorithm; S=0; integrate until enter class. frbdn. region
      DO 10 IX=2,IMATCH
         KIP1=C*(E-V(IX+1))
         PSI(IX+1)=(PSI(IX)*(2.-10.*KI)-PSI(IX-1)*(1+KIM1))/(1+KIP1)
         KIM1=KI                  !roll values of K*K
         KI=KIP1
C
C        if PSI grows too large rescale all previous points
         IF (ABS(PSI(IX+1)) .GT. (1.0E+10)) THEN
             DO 20 KX=1,IX+1
                PSI(KX)=PSI(KX)*9.999999E-06
20           CONTINUE
         END IF
10    CONTINUE
      PMMTCH=PSI(IMATCH)           !save value for normalization
C
      PSI(NPTS)=0                  !rhs boundary conditions
      PSI(NPTS-1)=9.999999E-10
      KIP1=C*(E-V(NPTS))           !initial K*K values
      KI=C*(E-V(NPTS-1))
C
C     Numerov algorithm, S=0;integrate from rhs to IMATCH
      DO 30 IX=NPTS-1,IMATCH+1,-1
           KIM1=C*(E-V(IX-1))
           PSI(IX-1)=(PSI(IX)*(2.-10.*KI)-PSI(IX+1)*(1+KIP1))/(1+KIM1)
           KIP1=KI                 !roll values of K*K
           KI=KIM1
C
C          if PSI grows too large rescale all previous points
           IF (ABS(PSI(IX-1)) .GT. (1.0E+10)) THEN
              DO 40 KX=NPTS-1,IX-1,-1
                   PSI(KX)=PSI(KX)*9.999999E-06
40            CONTINUE
           END IF
30    CONTINUE
C
      KIM1=C*(E-V(IMATCH-1))       !finds values needed for log deriv
      PPMTCH=(PSI(IMATCH)*(2-10*KI)-PSI(IMATCH+1)*(1+KIP1))/(1+KIM1)
C
      NORM=PMMTCH/PSI(IMATCH)      !norm PSI right to PSI left
      DO 5 IX=IMATCH,NPTS
           PSI(IX)=PSI(IX)*NORM
5     CONTINUE
      PPMTCH=PPMTCH*NORM
C
C     find nodes, turning points, entry into classically forb regions
C     and determine if overall sign must be flipped
      CALL DETAIL(IMATCH,NODES,E,LTP,RTP,NCROSS,PMMTCH,FLIP,FIRST,PSI)
C
C     find maximum PSI value and flip sign if necessary
      PSIMAX=ABS(PSI(1))
      DO 7 IX=1,NPTS
           IF (ABS(PSI(IX)) .GT. PSIMAX) PSIMAX=ABS(PSI(IX))
           IF (FLIP .EQV. .TRUE.) PSI(IX)=-PSI(IX)
7     CONTINUE
      IF (FLIP) PPMTCH=-PPMTCH
C
      F=(PSI(IMATCH-1)-PPMTCH)/PSIMAX   !evaluate matching condition
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE
     +    DETAIL(IMATCH,NODES,E,LTP,RTP,NCROSS,PMMTCH,FLIP,FIRST,PSI)
C subroutine to calculates nodes, turning points, entry
C into classically forbidden regions, and whether or not the
C overall sign of PSI must be flipped to make F continuous function of E
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E3'
C Passed variables:
      INTEGER IMATCH            !matching lattice point (input)
      INTEGER NODES             !number of nodes (output)
      REAL E                    !trial eigenvalue (input)
      INTEGER LTP,RTP           !classical turning points (output)
      INTEGER NCROSS            !classically forbidden regions (output)
      REAL PMMTCH               !PSI at match point (input)
      LOGICAL FIRST             !signal first step in search(input)
      LOGICAL FLIP              !do we need to flip sign of PSI (output)
      REAL PSI(MAXLAT)          !wave function (input)
C Local variables:
      LOGICAL LSAME             !does PSI left retain its sign?
      INTEGER IX                !X index
      REAL K,KLAST              !wavenumbers
      INTEGER NLOLD,NLFT        !left nodes
      INTEGER NROLD,NRT         !right nodes
      REAL PSIR,PSIL            !sign of PSI which must be constant
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     find number of nodes on each side
      NLOLD=NLFT                !save old values first
      NROLD=NRT
      NLFT=0                    !zero sums
      NRT=0
      DO 8 IX=2,IMATCH-1        !left side
          IF (PSI(IX)*PSI(IX-1) .LT. 0) NLFT=NLFT+1
8     CONTINUE
      IF (PSI(IMATCH-1)*PMMTCH .LT. 0) NLFT=NLFT+1
      DO 10 IX=IMATCH+1,NPTS        !right side
          IF (PSI(IX)*PSI(IX-1) .LT. 0) NRT=NRT+1
10    CONTINUE
C
C     check for change in node number
C      if one side of the wave function has gained a node,
C      that side must maintain the same sign between steps
C      in order that F be a continuous function of Energy.
C      if no new node has appeared, keep same sign same
C      as last time
      IF ((NLOLD .NE. NLFT) .AND. (NRT .EQ. NROLD)) THEN
         IF (LSAME .EQV. .FALSE.) LSAME=.TRUE.
      ELSE IF ((NROLD .NE. NRT) .AND. (NLOLD .EQ. NLFT)) THEN
         IF (LSAME .EQV. .TRUE.) LSAME=.FALSE.
      END IF
C
      IF (FIRST .EQV. .TRUE.) LSAME=.TRUE.    !initialize variables
      IF (FIRST .EQV. .TRUE.) PSIL=1.
C
C     now, finally, determine if the sign needs to be flipped
      FLIP=.FALSE.
      IF ((LSAME) .AND. (PSIL*PSI(2) .LT. 0.)) FLIP=.TRUE.
      IF (( .NOT. LSAME ) .AND. (PSIR*PSI(NPTS-1) .LT. 0.))
     +    FLIP=.TRUE.
C
C     save values for next step
      PSIL=PSI(2)
      PSIR=PSI(NPTS-1)
      IF (FLIP) PSIL=-PSIL
      IF (FLIP) PSIR=-PSIR
C
      NODES=NLFT+NRT             !total number of nodes
C
C     find leftmost turning point
      LTP=0
      IX=0
110   IF (LTP .EQ. 0) THEN
         IX=IX+1
         IF ((E-V(IX)) .GE. 0) LTP=IX
      GOTO 110
      END IF
C
C     find rightmost turning point
      RTP=0
      IX=NPTS+1
120   IF (RTP .EQ. 0) THEN
         IX=IX-1
         IF ((E-V(IX)) .GE. 0) RTP=IX
      GOTO 120
      END IF
C
C     do we integrate into classically forbidden regions?
      KLAST=(E-V(LTP))
      NCROSS=0
      DO 90 IX=LTP+1,RTP-1
         K=(E-V(IX))
         IF ((K*KLAST .LE. 0) .AND. (K .LT. 0)) NCROSS=NCROSS+1
         KLAST=K
90    CONTINUE
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE POTNTL
C sets up array for current potential;
C all potentials have a minimum value of -1 and max of 1;
C if you change the potential, also change XMIN and XMAX in INIT,
C and estimate DEBOT and EBOTTM (one fifth of the expected spacing
C at the bottom of the well, and two DEBOT's below the expected ground
C state energy).
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.E3'
C Local variables:
      INTEGER ILEFT,IWID,IRIGHT     !lattice values for width, left
      REAL VSCALE                   !scaling factor for renorm of parab
      INTEGER IX                    !labels lattice points
      REAL VMIN                     !minimum value of potential
      REAL CURVE                    !curvature for smoothing bump
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     define limits on X and DX
      IF (POT .EQ. SQUARE) THEN
         VXMIN=XMIN1
         VXMAX=XMAX1
      ELSE IF (POT .EQ. PARAB) THEN
         VXMIN=XMIN2
         VXMAX=XMAX2
      ELSE IF (POT .EQ. LENRD) THEN
         VXMIN=XMIN3
         VXMAX=XMAX3
      END IF
C
      DX=(VXMAX-VXMIN)/(NPTS-1)
C
C     setup X (space coordinate) array
      DO 5 IX=1,NPTS
         X(IX)=VXMIN+(IX-1)*DX
5     CONTINUE
C
C     setup V (potential) array
      IF (POT .EQ. SQUARE) THEN             !square well
         DO 10 IX=1,NPTS
            V(IX)=-1.
10       CONTINUE
         VMAX=1.
         DEBOT=.2*(3.1415926/(4*GAMMA))**2!energy spacing at well bottom
         IF (BUMP .EQ. 1) THEN            !bump in well bottom
            ILEFT=NINT((LEFT-XMIN1)/DX)+1 !locate bump edges
            IRIGHT=NPTS+NINT((RIGHT-XMAX1)/DX)
            RIGHT=X(IRIGHT)
            LEFT=X(ILEFT)
            CURVE=-.025/((RIGHT-LEFT)/2.)**2
C           top of bump is curved to avoid discontinuities
            DO 20 IX=ILEFT,IRIGHT
               V(IX)=-1.+HEIGHT*(1.+CURVE*(X(IX)-(RIGHT+LEFT)/2.)**2)
20          CONTINUE
         END IF
C
      ELSE IF (POT .EQ. PARAB) THEN    !parabolic well
         DO 30 IX=1,NPTS
            V(IX)=-(1.-.5*X(IX)*X(IX))
30       CONTINUE
         VMAX=1.
         DEBOT=.2/(SQRT(2.)*GAMMA)     !energy spacing at well bottom
         IF (FLAT .EQ. 1) THEN
C           the parabolic potential is flattened symmetrically about x=0
            IWID=INT(PWID/DX)
            IF (MOD(IWID,2) .NE. MOD(NPTS,2)) IWID=IWID-1
            ILEFT=(NPTS-IWID)/2+1
            VMIN=V(ILEFT)
            DO 40 IX=ILEFT,ILEFT+IWID-1
               V(IX)=VMIN
40          CONTINUE
C
            VSCALE=2./(V(1)-VMIN)    !normalize so that min value is -1
            DO 50 IX=1,NPTS
               V(IX)=VSCALE*(V(IX)-VMIN)-1.
50          CONTINUE
         END IF
C
      ELSE IF (POT .EQ. LENRD) THEN    !Lennard-Jones potential
         DO 60 IX=1,NPTS
            V(IX)=4*(X(IX)**(-12.)-X(IX)**(-6))
60       CONTINUE
         VMAX=V(1)
         DEBOT=1.0692/GAMMA !energy spacing at well bottom (see Ex. 1.8)
C
      END IF
C
C     educated guesses for ground state energy and energy spacing;
C     with these values, it will take three steps for F to change sign
      EBOTTM=-1.+2.5*DEBOT
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.E3'
C Local parameters:
      CHARACTER*80 DESCRP        !program description
      DIMENSION DESCRP(22)
      INTEGER NHEAD,NTEXT,NGRF   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL SETUP                !get environment parameters
C
C     display header screen
      DESCRP(1)= 'EXAMPLE 3'
      DESCRP(2)= 'Bound states in a one-dimensional potential'
      NHEAD=2
C
C     text output description
      DESCRP(3)= 'during search: energy, delta energy, discontinuity,'
      DESCRP(4)='nodes, and entrance into classically forbidden regions'
      DESCRP(5)= 'after search: energy, classical turning points,'
     +  //' number of nodes'
      NTEXT=3
C
C     graphics output description
      DESCRP(6)= 'potential, eigenvalues, and eigenfunctions'
      NGRF=1
C
C     setup constant values for the potentials
      !all potentials have VMIN=-1, VMAX=1
      XMIN1=-2.
      XMAX1=2.
      XMIN2=-2.
      XMAX2=2.
      XMIN3=(2.*(SQRT(2.)-1.))**(.1666666)
      XMAX3=1.9
C
C     reasonable limits on energy and energy increment
      EMIN=-.99999
      EMAX=100.
      DEMIN=5.E-06
      DEMAX=1.
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRF)
C
      CALL MENU                !setup constant part of header
C
      MTYPE(13)=FLOAT
      MPRMPT(13)= 'Enter Gamma=sqrt[2m(a**2)V/hbar**2] (dimensionless)'
      MTAG(13)= 'Gamma=sqrt[2m(a**2)V/hbar**2] (dimensionless)'
      MLOLIM(13)=0.001
      MHILIM(13)=150.
      MREALS(13)=30.0
C
      MTYPE(14)=TITLE
      MPRMPT(14)= 'POTENTIAL FUNCTION MENU'
      MLOLIM(14)=2.
      MHILIM(14)=1.
C
      MTYPE(15)=MTITLE
      MPRMPT(15)='1) Square-well potential'
      MLOLIM(15)=0.
      MHILIM(15)=0.
C
      MTYPE(16)=MTITLE
      MPRMPT(16)='2) Parabolic-well potential'
      MLOLIM(16)=0.
      MHILIM(16)=0.
C
      MTYPE(17)=MTITLE
      MPRMPT(17)='3) Lennard-Jones potential'
      MLOLIM(17)=0.
      MHILIM(17)=1.
C
      MTYPE(18)=MCHOIC
      MPRMPT(18)= 'Make menu choice and press Return'
      MTAG(18)='19 24 26'
      MLOLIM(18)=1.
      MHILIM(18)=3.
      MINTS(18)=3
      MREALS(18)=3.
C
      MTYPE(19)=NOSKIP
      MPRMPT(19)= 'Do you want a bump in the square well?'
      MTAG(19)= 'Square Well Bump:'
      MREALS(19)=35.
      MINTS(19)=0
C
      MTYPE(20)=FLOAT
      MPRMPT(20)= 'Enter the left hand edge of bump (scaled units)'
      MTAG(20)= 'Left hand edge of bump (scaled units)'
      MLOLIM(20)=XMIN1
      MHILIM(20)=XMAX1
      MREALS(20)=-.1
C
      MTYPE(21)=FLOAT
      MPRMPT(21)= 'Enter the right hand edge of bump (scaled units)'
      MTAG(21)= 'Right hand edge of bump (scaled units)'
      MLOLIM(21)=XMIN1
      MHILIM(21)=XMAX1
      MREALS(21)=.1
C
      MTYPE(22)=FLOAT
      MPRMPT(22)= 'Enter the height of the bump (scaled units)'
      MTAG(22)= 'Height of the bump (scaled units)'
      MLOLIM(22)=0.
      MHILIM(22)=20
      MREALS(22)=1.
C
      MTYPE(23)=SKIP
      MREALS(23)=35.
C
      MTYPE(24)=NOSKIP
      MPRMPT(24)= 'Do you want a flattened bottom in parabolic-well'
      MTAG(24)= 'Parabolic Flattened area:'
      MREALS(24)=35.
      MINTS(24)=0
C
      MTYPE(25)=FLOAT
      MPRMPT(25)= 'Enter length of the flattened area (scaled units)'
      MTAG(25)= 'Length of the flattened area (scaled units)'
      MLOLIM(25)=0
      MHILIM(25)=XMAX2-XMIN2
      MREALS(25)=.1
C
      MTYPE(26)=SKIP
      MREALS(26)=35.
C
      MTYPE(38)=FLOAT
      MPRMPT(38)= 'Enter the matching tolerance'
      MTAG(38)= 'Matching tolerance'
      MLOLIM(38)=5.E-06
      MHILIM(38)=1.000
      MREALS(38)=.00005
C
      MTYPE(39)=NUM
      MPRMPT(39)= 'Enter number of lattice points'
      MTAG(39)= 'Number of lattice points'
      MLOLIM(39)=50
      MHILIM(39)=MAXLAT
      MINTS(39)=160
C
      MTYPE(40)=NUM
      MPRMPT(40)= 'Enter maximum number of steps in search'
      MTAG(40)= 'Maximum number of search steps'
      MLOLIM(40)=10
      MHILIM(40)=300
      MINTS(40)=50
C
      MTYPE(41)=SKIP
      MREALS(41)=60.
C
      MSTRNG(MINTS(75))= 'exmpl3.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'exmpl3.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
C Local variables:
C map between menu items and parameters
      INTEGER IGAMMA,ITOLR,INPTS,IMXSTP
      INTEGER IPOT,IBUMP,ILEFT,IHEIGH,IRIGHT,IFLAT,IPWID
      PARAMETER (IGAMMA = 13 )
      PARAMETER (IPOT   = 18 )
      PARAMETER (IBUMP  = 19 )
      PARAMETER (ILEFT  = 20 )
      PARAMETER (IRIGHT = 21 )
      PARAMETER (IHEIGH = 22 )
      PARAMETER (IFLAT  = 24 )
      PARAMETER (IPWID  = 25 )
      PARAMETER (ITOLR  = 38 )
      PARAMETER (INPTS  = 39 )
      PARAMETER (IMXSTP = 40 )
C Function:
      LOGICAL LOGCVT          !converts 1 and 0 to true and false
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
      CALL CLEAR
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     set new parameter values
C     physical and numerical:
      GAMMA=MREALS(IGAMMA)
      TOLF=MREALS(ITOLR)
      NPTS=MINTS(INPTS)
      MAXSTP=MINTS(IMXSTP)
C
C     potential parameters
      POT=MREALS(IPOT)
      BUMP=MINTS(IBUMP)
      LEFT=MREALS(ILEFT)
      RIGHT=MREALS(IRIGHT)
      HEIGHT=MREALS(IHEIGH)
      FLAT=MINTS(IFLAT)
      PWID=MREALS(IPWID)
C
      CALL POTNTL  !setup potential array
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
      !files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE PRMOUT(MUNIT)
C outputs parameter summary to the specified unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
       INCLUDE 'IO.ALL'
       INCLUDE 'PARAM.E3'
C Passed variables:
       INTEGER MUNIT            !unit number for output
       REAL VAR(4)              !initial values of coord and momenta
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
       WRITE (MUNIT,2)
       WRITE (MUNIT,4)
       WRITE (MUNIT,6) GAMMA
       WRITE (MUNIT,8) TOLF
       WRITE (MUNIT,12) NPTS
C
       IF (POT .EQ. SQUARE) THEN
          WRITE (MUNIT,14)
          IF (BUMP .EQ. 1) WRITE (MUNIT,16) LEFT,RIGHT,HEIGHT
       ELSE IF (POT .EQ. PARAB) THEN
          WRITE (MUNIT,18)
          IF (FLAT .EQ. 1) WRITE (MUNIT,20) -PWID,PWID
       ELSE IF (POT .EQ. LENRD) THEN
          WRITE (MUNIT,22)
       END IF
C
       WRITE (MUNIT,24)VXMIN,VXMAX,DX
       WRITE (MUNIT,26)
       WRITE (MUNIT,2)
C
2      FORMAT (' ')
4      FORMAT (' Output from Example 3: Time Independent Schroedinger',
     +         ' Equation')
6      FORMAT (' Gamma =',F9.3)
8      FORMAT (' Matching tolerance = ', 1PE10.3)
12     FORMAT (' Number of lattice points =', I5)
14     FORMAT (' Square Well potential')
16     FORMAT (' with bump from ',F6.3,' to ',F6.3,' of height =',F8.3)
18     FORMAT (' Parabolic potential')
20     FORMAT (' with flat bottom from ',F6.3,' to ',F6.3)
22     FORMAT (' Lennard-Jones potential')
24     FORMAT (' Xmin=',F6.3,' Xmax=',F6.3,' Dx=',1PE10.3)
26     FORMAT (' Energies and lengths are in scaled units')
C
       RETURN
       END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
       SUBROUTINE CTITL(MUNIT)
C writes title for text output to requested device
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Passed variables:
      INTEGER MUNIT                 !unit to which we are writing
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      WRITE (MUNIT,30)
      WRITE (MUNIT,35)
C
30    FORMAT
     +     (10X,'Energy',14X,'De',16X,'F',10x,'Nodes',5x,'Frbddn')
35    FORMAT
     +     (10X,'------',14X,'--',16X,'-',10X,'-----',5X,'------')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,E,DE,F,NODES,NCROSS,NLINES)
C writes results for one level to the requested unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
C Input variables:
      INTEGER MUNIT                !unit to which we are writing
      REAL F                       !values of the mismatch
      INTEGER NODES                !number of nodes
      REAL E                       !trial eigenenergy
      REAL DE                      !step in energy search
      INTEGER NCROSS               !classically forbidden regions
      CHARACTER*3 FORBDN           !have we integrated into forb regions
      INTEGER NLINES               !number of lines sent to screen (I/O)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear screen and retype headings
      IF ((MOD(NLINES,TRMLIN-4) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         CALL CTITL(OUNIT)
         NLINES=2
      END IF
C
      IF (NCROSS .GT. 0) THEN
         FORBDN='Yes'
      ELSE
         FORBDN='No '
      END IF
      WRITE (MUNIT,20) E,DE,F,NODES,FORBDN
      NLINES=NLINES+1
C
20    FORMAT (8X,F10.7,7X,1PE10.3,7X,1PE10.3,8X,I2,8X,A3)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE EOUT(E,LTP,RTP,NODES,MUNIT)
C output information about eigenstate
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
C Passed variables:
      INTEGER MUNIT                 !unit to which we are writing
      INTEGER NODES                 !number of nodes
      REAL E                        !trial eigenenergy
      INTEGER LTP,RTP               !classical turning points (lattice)
      REAL XLTP,XRTP                !classical turning points
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      XLTP=VXMIN+(LTP-1)*DX         !turning points
      XRTP=VXMIN+(RTP-1)*DX
      WRITE (MUNIT,500) E, NODES
      WRITE (MUNIT,510) XLTP,XRTP
C
500   FORMAT ('0',20X,'Eigenvalue = ',F10.7,' with ',I2,' nodes.')
510   FORMAT (16X,'and classical turning points ',F7.4,' and ',F7.4)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE,ENERGY,LEFTTP,RGHTTP,NFOUND,PSI)
C outputs potential and eigenvalues (plot 1) and eigenfunctions (plot 2)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.E3'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE               !which device is being used?
      REAL ENERGY(MAXLEV)          !array of eigenvalues
      INTEGER LEFTTP(MAXLEV),RGHTTP(MAXLEV)   !array of turning points
      INTEGER NFOUND               !number of levels found
      REAL PSI(MAXLAT)             !wave function
C Local variables
      INTEGER IX                   !index of lattice
      INTEGER ILEVEL               !index of eigenvalue
      REAL XE(2),GRAPHE(2)         !arrays to graph eigenvalue
      CHARACTER*9 CGAMMA,CE        !GAMMA, ENERGY as a character string
      INTEGER LEN                  !length of string
      REAL NORM,MAXPSI             !norm and max value for PSI
      INTEGER SCREEN               !send to terminal
      INTEGER PAPER                !make a hardcopy
      INTEGER FILE                 !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      !messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
      NORM=0.
      DO 10 IX=1,NPTS               !normalize wave function
        NORM=NORM+PSI(IX)**2
10    CONTINUE
      NORM=SQRT(NORM*DX)
      MAXPSI=0.
      DO 30 IX=1,NPTS
         PSI(IX)=PSI(IX)/NORM
         IF (ABS(PSI(IX)) .GT. MAXPSI) MAXPSI = ABS(PSI(IX))
30    CONTINUE
C
      IF (DEVICE .NE. FILE) THEN
          NPLOT=2                        !how many plots?
C
C         parameters that are the same for both plots
          XMIN=VXMIN                     !axis parameters
          Y0VAL=VXMIN
          XMAX=VXMAX
          NPOINT=NPTS
          LABEL(1)= 'x (scaled units)'
C
          ILINE=1                        !line and symbol styles
          ISYM=1
          IFREQ=0
          NXTICK=5
          NYTICK=5
C
          CALL CONVRT(GAMMA,CGAMMA,LEN)
          TITLE='Solutions to Schroedinger''s Equation, Gamma='//CGAMMA
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
C
C         first plot: potential and eigenvalues
          IPLOT=1
          YMIN=-1.
          YMAX=VMAX
          X0VAL=0.
          INFO=' '
          LABEL(2)= 'potential and eigenvalues (scaled units)'
          CALL LNLNAX
          CALL XYPLOT (X,V)                    !plot potential
C
          ILINE=3                              !plot eigenvalues
          NPOINT=2
          DO 20 ILEVEL=1,NFOUND
            XE(1)=VXMIN+(LEFTTP(ILEVEL)-1)*DX
            XE(2)=VXMIN+(RGHTTP(ILEVEL)-1)*DX
            GRAPHE(1)=ENERGY(ILEVEL)
            GRAPHE(2)=ENERGY(ILEVEL)
            CALL XYPLOT(XE,GRAPHE)
20        CONTINUE
C
C         second plot:  wave function
          IPLOT=2
          ILINE=1
          NPOINT=NPTS
          YMIN=-MAXPSI
          YMAX=+MAXPSI
          X0VAL=0.
          CALL CONVRT(ENERGY(NFOUND),CE,LEN)
          INFO='Eigenvalue = '//CE
          LABEL(2)= 'normalized wave function'
          CALL LNLNAX
          CALL XYPLOT (X,PSI)
C
      ELSE
C         output to file
          WRITE (GUNIT,80)
          WRITE (GUNIT,85)
          WRITE (GUNIT,70) (X(IX),V(IX),PSI(IX),IX=1,NPTS)
      END IF
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !end graphing package
      IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
C
100   FORMAT (/,' Patience, please; output going to a file.')
80    FORMAT ('0',13X,'Position',14X,'Potential',13X,'Wave function')
85    FORMAT (13X,'--------',14X,'---------',13X,'------------')
70    FORMAT (3(11X,1PE12.5))
C
      RETURN
      END


PROGRAM squares

IMPLICIT NONE

INTEGER :: i
INTEGER, DIMENSION(10) :: number, square

! Initialize number and calculate square.
DO i = 1, 10
   number(I) = i                 ! Initialize number
   square(i) = number(i)**2      ! Calculate square
END DO

! Write out each number and its square.
DO i = 1, 10
   WRITE (*,100) number(i), square(i)
   100 FORMAT (1X,'Number = ',I6,'  Square = ',I6)
END DO

END PROGRAM squares


c----------------------------------------------------------------------------

	program main
		implicit none
		integer*4 N
		integer*4 row, col
		parameter(N=2)
		real*8 ham(2**N, 2**N)
		real*8 Hz, Hf

		do row = 1, 2**N, +1
			do col = 1, 2**N, +1
				if (row .eq. col) then
					ham(row,col) = Hz(col,N)
				else
					ham(row,col) = 0.0d0
				end if
                        ham(row, col) = ham(row,col) + Hf(col,N)
			end do
		end do

		do row = 1, 2**N, +1
			write(*,100) (ham(row, col), col = 1, 2**N)
100				format(f5.1,f5.1,f5.1,f5.1,f5.1,f5.1,f5.1,f5.1,
     >				 f5.1,f5.1,f5.1,f5.1,f5.1,f5.1,f5.1,f5.1)
		end do
	end

c----------------------------------------------------------------------------

	double precision function Hz(state,N)
		implicit none
		integer*4 state, N, site
		real*8 sum, Sz

		sum = 0.0d0

		do site = 0, N - 1, +1
			if (site .eq. N - 1) then
				sum = sum + Sz(state, site)*Sz(state, 0)
			else
				sum = sum + Sz(state, site)*Sz(state, site + 1)
			endif
		end do

		Hz = sum
		return
	end

c----------------------------------------------------------------------------

      double precision function Hf(state, N)
            implicit none
            integer*4 i, row, N
            real*8 sum, Sz

            sum = 0.0d0

            do i = 0, N - 1, +1
                  if (i .eq. N - 1) then
                        if (Sz(state,i)*Sz(state,0) .lt. 0.0d0) then
                        write(*,*)'** sz(i)sz(i+1) = ',i,0,
     >                              Sz(state,i)*Sz(state,i+1)

                              sum = sum + 0.5d0
                        end if
                  else
                         write(*,*)'   sz(i)sz(i+1) = ',i,i+1,
     >                              Sz(state,i)*Sz(state,i+1)

                        if (Sz(state,i)*Sz(state,i+1) .lt. 0.0d0) then
                              sum = sum + 0.5d0
                        end if
                  end if
            end do
      end

	double precision function Hmichael(state, N)
		implicit none
		real*8 sum
            integer*4 state, N, i
            real*8 Sp, Sm
            real*8 flip

		sum = 0.0d0

		do i = 0, N - 1, +1
                  if (i .eq. N - 1) then
                        flip = 0.5*(Sp(state,i)*Sm(state,0) +
     >                              Sm(state,i)*Sp(state,0))
                        sum = sum + flip
                  else
                        flip = 0.5*(Sp(state,i)*Sm(state,i+1) +
     >                              Sm(state,i)*Sp(state,i+1))
                        sum = sum + flip
                  endif
                  write(*,*)'sum = ',sum
		end do

            Hmichael = sum
            return
	end

c----------------------------------------------------------------------------

	double precision function Sz(state, site)
		implicit none
		integer*4 state, site
		real*8 spin

		spin = and(state, 2**site)
		spin = spin/(2**site)

		if (spin .gt. 0.0d0) then
			Sz = 0.5d0
		else
			Sz = -0.5d0
		endif

		return
	end

c-----------------------------------------------------------------------------

      double precision function Sp(state, site)
            implicit none
            integer*4 state, site
            real*8 spin, val, Sz

            spin = Sz(state, site)

            if (spin .eq. -0.5d0) then
                  val = 0.5d0
            endif

            if (spin .eq. 0.5d0) then
                  val = 0.0d0
            endif

            Sp = val
            return
      end

c-----------------------------------------------------------------------------

      double precision function Sm(state, site)
            implicit none
            integer*4 state, site
            real*8 spin, val, Sz

            spin = Sz(state, site)

            if (spin .eq. 0.5d0) then
                  val = -0.5d0
            endif

            if (spin .eq. -0.5d0) then
                  val = 0.0d0
            endif
      end

c------------------------------------------------------------------------------

      subroutine tred1(nm,n,a,d,e,e2)
c
      integer i,j,k,l,n,ii,nm,jp1
      double precision a(nm,n),d(n),e(n),e2(n)
      double precision f,g,h,scale
c
c     this subroutine is a translation of the algol procedure tred1,
c     num. math. 11, 181-195(1968) by martin, reinsch, and wilkinson.
c     handbook for auto. comp., vol.ii-linear algebra, 212-226(1971).
c
c     this subroutine reduces a real symmetric matrix
c     to a symmetric tridiagonal matrix using
c     orthogonal similarity transformations.
c
c     on input
c
c        nm must be set to the row dimension of two-dimensional
c          array parameters as declared in the calling program
c          dimension statement.
c
c        n is the order of the matrix.
c
c        a contains the real symmetric input matrix.  only the
c          lower triangle of the matrix need be supplied.
c
c     on output
c
c        a contains information about the orthogonal trans-
c          formations used in the reduction in its strict lower
c          triangle.  the full upper triangle of a is unaltered.
c
c        d contains the diagonal elements of the tridiagonal matrix.
c
c        e contains the subdiagonal elements of the tridiagonal
c          matrix in its last n-1 positions.  e(1) is set to zero.
c
c        e2 contains the squares of the corresponding elements of e.
c          e2 may coincide with e if the squares are not needed.
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      do 100 i = 1, n
         d(i) = a(n,i)
         a(n,i) = a(i,i)
  100 continue
c     .......... for i=n step -1 until 1 do -- ..........
      do 300 ii = 1, n
         i = n + 1 - ii
         l = i - 1
         h = 0.0d0
         scale = 0.0d0
         if (l .lt. 1) go to 130
c     .......... scale row (algol tol then not needed) ..........
         do 120 k = 1, l
  120    scale = scale + dabs(d(k))
c
         if (scale .ne. 0.0d0) go to 140
c
         do 125 j = 1, l
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = 0.0d0
  125    continue
c
  130    e(i) = 0.0d0
         e2(i) = 0.0d0
         go to 300
c
  140    do 150 k = 1, l
            d(k) = d(k) / scale
            h = h + d(k) * d(k)
  150    continue
c
         e2(i) = scale * scale * h
         f = d(l)
         g = -dsign(dsqrt(h),f)
         e(i) = scale * g
         h = h - f * g
         d(l) = f - g
         if (l .eq. 1) go to 285
c     .......... form a*u ..........
         do 170 j = 1, l
  170    e(j) = 0.0d0
c
         do 240 j = 1, l
            f = d(j)
            g = e(j) + a(j,j) * f
            jp1 = j + 1
            if (l .lt. jp1) go to 220
c
            do 200 k = jp1, l
               g = g + a(k,j) * d(k)
               e(k) = e(k) + a(k,j) * f
  200       continue
c
  220       e(j) = g
  240    continue
c     .......... form p ..........
         f = 0.0d0
c
         do 245 j = 1, l
            e(j) = e(j) / h
            f = f + e(j) * d(j)
  245    continue
c
         h = f / (h + h)
c     .......... form q ..........
         do 250 j = 1, l
  250    e(j) = e(j) - h * d(j)
c     .......... form reduced a ..........
         do 280 j = 1, l
            f = d(j)
            g = e(j)
c
            do 260 k = j, l
  260       a(k,j) = a(k,j) - f * e(k) - g * d(k)
c
  280    continue
c
  285    do 290 j = 1, l
            f = d(j)
            d(j) = a(l,j)
            a(l,j) = a(i,j)
            a(i,j) = f * scale
  290    continue
c
  300 continue
c
      return
      end
c     ------------------------------------------------------
	subroutine imtql1(n,d,e,ierr)
c
      integer i,j,l,m,n,ii,mml,ierr
      double precision d(n),e(n)
      double precision b,c,f,g,p,r,s,tst1,tst2,pythag
c
c     this subroutine is a translation of the algol procedure imtql1,
c     num. math. 12, 377-383(1968) by martin and wilkinson,
c     as modified in num. math. 15, 450(1970) by dubrulle.
c     handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).
c
c     this subroutine finds the eigenvalues of a symmetric
c     tridiagonal matrix by the implicit ql method.
c
c     on input
c
c        n is the order of the matrix.
c
c        d contains the diagonal elements of the input matrix.
c
c        e contains the subdiagonal elements of the input matrix
c          in its last n-1 positions.  e(1) is arbitrary.
c
c      on output
c
c        d contains the eigenvalues in ascending order.  if an
c          error exit is made, the eigenvalues are correct and
c          ordered for indices 1,2,...ierr-1, but may not be
c          the smallest eigenvalues.
c
c        e has been destroyed.
c
c        ierr is set to
c          zero       for normal return,
c          j          if the j-th eigenvalue has not been
c                     determined after 30 iterations.
c
c     calls pythag for  dsqrt(a*a + b*b) .
c
c     questions and comments should be directed to burton s. garbow,
c     mathematics and computer science div, argonne national laboratory
c
c     this version dated august 1983.
c
c     ------------------------------------------------------------------
c
      ierr = 0
      if (n .eq. 1) go to 1001
c
      do 100 i = 2, n
  100 e(i-1) = e(i)
c
      e(n) = 0.0d0
c
      do 290 l = 1, n
         j = 0
c     .......... look for small sub-diagonal element ..........
  105    do 110 m = l, n
            if (m .eq. n) go to 120
            tst1 = dabs(d(m)) + dabs(d(m+1))
            tst2 = tst1 + dabs(e(m))
            if (tst2 .eq. tst1) go to 120
  110    continue
c
  120    p = d(l)
         if (m .eq. l) go to 215
         if (j .eq. 30) go to 1000
         j = j + 1
c     .......... form shift ..........
         g = (d(l+1) - p) / (2.0d0 * e(l))
         r = pythag(g,1.0d0)
         g = d(m) - p + e(l) / (g + dsign(r,g))
         s = 1.0d0
         c = 1.0d0
         p = 0.0d0
         mml = m - l
c     .......... for i=m-1 step -1 until l do -- ..........
         do 200 ii = 1, mml
            i = m - ii
            f = s * e(i)
            b = c * e(i)
            r = pythag(f,g)
            e(i+1) = r
            if (r .eq. 0.0d0) go to 210
            s = f / r
            c = g / r
            g = d(i+1) - p
            r = (d(i) - g) * s + 2.0d0 * c * b
            p = s * r
            d(i+1) = g + p
            g = c * r - b
  200    continue
c
         d(l) = d(l) - p
         e(l) = g
         e(m) = 0.0d0
         go to 105
c     .......... recover from underflow ..........
  210    d(i+1) = d(i+1) - p
         e(m) = 0.0d0
         go to 105
c     .......... order eigenvalues ..........
  215    if (l .eq. 1) go to 250
c     .......... for i=l step -1 until 2 do -- ..........
         do 230 ii = 2, l
            i = l + 2 - ii
            if (p .ge. d(i-1)) go to 270
            d(i) = d(i-1)
  230    continue
c
  250    i = 1
  270    d(i) = p
  290 continue
c
      go to 1001
c     .......... set error -- no convergence to an
c                eigenvalue after 30 iterations ..........
 1000 ierr = l
 1001 return
      end
      double precision function pythag(a,b)
      double precision a,b
c
c     finds dsqrt(a**2+b**2) without overflow or destructive underflow
c
      double precision p,r,s,t,u
      p = dmax1(dabs(a),dabs(b))
      if (p .eq. 0.0d0) go to 20
      r = (dmin1(dabs(a),dabs(b))/p)**2
   10 continue
         t = 4.0d0 + r
         if (t .eq. 4.0d0) go to 20
         s = r/t
         u = 1.0d0 + 2.0d0*s
         p = u*p
         r = (s/u)**2 * r
      go to 10
   20 pythag = p
      return
      end


!!!Author: Huseyin Emrah Konokman

module step_class

    use :: precision, only: rp

    implicit none

    private

    !!!The equation (derivatives of the equation set) to be integrated (to be stepped forward)
    !! The type for the equation set to be stepped forward should be extended from this abstract type
    type, abstract, public :: derivative_abstract_type
        !!!Parameters of the (derivatives of) equation set should be given by the extended type of that equation set
    contains
        procedure(derivative_proc), deferred :: derivative    !!!The procedure of the derivative equation to be stepped forward. This procedure takes x input and output xdot
    end type derivative_abstract_type

    abstract interface
        subroutine derivative_proc(self, t, h, x, xdot)
            import :: derivative_abstract_type, rp
            class(derivative_abstract_type), intent(inout) :: self
            real(rp), intent(in) :: t
            real(rp), intent(in) :: h                    !!!Step size
            real(rp), intent(in) :: x(:)                !!!Vector of the equation set
            real(rp), intent(out) :: xdot(size(x))      !!!Vector of the derivatives of equation set
        end subroutine
    end interface

    !!!Abstract step type
    !! The type for a new step method is extended from this abstract type
    type, abstract, public :: step_abstract_type
        real(rp) :: ds          !!!Step size
    contains
        procedure(step_proc), deferred, nopass :: step
    end type step_abstract_type

    abstract interface
        subroutine step_proc(f, t, x, h, dx)
            use :: precision, only: rp
            import :: derivative_abstract_type
            class(derivative_abstract_type) :: f        !!!The derivative function come through overloaded deferred procedure f%derivative(...)
            real(rp), intent(in) :: t
            real(rp), intent(in) :: x(:)                !!!Vector of the equation set
            real(rp), intent(in) :: h                   !!!Step size
            real(rp), intent(out) :: dx(:)              !!!Vector of one step of the equation set
        end subroutine step_proc
    end interface

    !!!Euler step
    type, extends(step_abstract_type), public :: step_euler_type

    contains
        procedure, nopass :: step => step_euler
    end type step_euler_type

    !!!RK4 step
    type, extends(step_abstract_type), public :: step_rk4_type

    contains
        procedure, nopass :: step => step_rk4
    end type step_rk4_type

    !!!Any new step types can be added here>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    !type, extends(step_abstract_type), public :: step_..._type

    !contains
    !    procedure, nopass :: step => step_...
    !end type step_..._type

    !!!Any new step types can be added here<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

    public :: step

    !!!Constructor
    interface step
        module procedure allocate_step_type
    end interface

contains

    !!!Procedure for the allocation of the step container according to desired step type
    subroutine allocate_step_type(step_c, step_type, ds)

        implicit none
        class(step_abstract_type), allocatable, intent(inout) :: step_c     !!!Step type container
        character(*), intent(in) :: step_type
        real(rp), intent(in), optional :: ds

        if(allocated(step_c)) deallocate(step_c)
        select case(trim(adjustl(step_type)))
        case("RK4")
            allocate(step_rk4_type :: step_c)
        case("Euler")
            allocate(step_euler_type :: step_c)
        case default
                allocate(step_rk4_type :: step_c)
        end select

        if(present(ds)) step_c%ds = ds

    end subroutine

    !!!Procedures for the steps

    !!!Procedure for simple Euler step
    subroutine step_euler(f, t, x, h, dx)

        implicit none
        class(derivative_abstract_type) :: f
        real(rp), intent(in) :: t
        real(rp), intent(in) :: x(:)
        real(rp), intent(in) :: h
        real(rp), intent(out) :: dx(:)

        real(rp), dimension(size(x)) :: xdot

        call f%derivative(t, h, x, xdot)
        dx = h * xdot

    end subroutine step_euler

    !!!Procedure for 4th order Runge-Kutta step
    subroutine step_rk4(f, t, x, h, dx)

        implicit none
        class(derivative_abstract_type) :: f
        real(rp), intent(in) :: t
        real(rp), intent(in) :: x(:)
        real(rp), intent(in) :: h
        real(rp), intent(out) :: dx(:)

        real(rp), dimension(size(x)) :: xdot1, xdot2, xdot3, xdot4
        real(rp) :: ho2

        ho2 = 0.5_rp * h

        call f%derivative(t, 0._rp, x, xdot1)           !!!1st RK4 step
        call f%derivative(t+ho2, ho2, x+ho2*xdot1, xdot2)   !!!2nd RK4 step
        call f%derivative(t+ho2 + ho2, x+ho2*xdot2, xdot3)   !!!3rd RK4 step
        call f%derivative(t+h, h, x+h*xdot3, xdot4)       !!!4th RK4 step

        dx = h * (xdot1 + 2._rp*xdot2 + 2._rp*xdot3 + xdot4)/6._rp

    end subroutine step_rk4

    !!!Procedures for any new step types can be added here>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    !subroutine step_...(f, x, h, dx)
    !
    !end subroutine step...

    !!!Procedures for any new step types can be added here<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

end module step_class


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test for multiplication operation take quad precision

program test
  integer, parameter :: k = 16, n = 4
  real(kind = k) :: a1 = 1.191127656_16
  real(kind = k) :: a2 = 2.192357256_16
  real(kind = k) :: r1, r2, r3
  real(kind = k) :: r4 = 1.1_16 * 1.2_16
  real(kind = k) :: eps_q = 1.e-33_16

  integer :: result(n), expect(n)
  expect = 1
  result = 0

  r1 = a1 * a2
  r2 = a1 * 12345678.987654321_16
  r3 = 123.456789_16 * 987654.3125121651_16
  if (abs((r1 - 2.61137735945387193599999999999999999_16)/r1) <= eps_q) result(1) = 1
  if (abs((r2 - 14705279.6742931443110015759999999991_16)/r2) <= eps_q) result(2) = 1
  if (abs((r3 - 121932630.064754426683863900000000003_16)/r3) <= eps_q) result(3) = 1
  if (abs((r4 - 1.32000000000000000000000000000000005_16)/r4) <= eps_q) result(4) = 1
  call check(result, expect, n)
end program


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!   bru :    Time integration of a scalar nonlinear parabolic PDE
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION X,Y,A,B

        X=U(1)
        Y=U(2)
        A=PAR(1)
        B=PAR(2)

!      *Set the nonlinear term
        F(1)= X**2*Y - (B+1)*X + A
        F(2)=-X**2*Y + B*X

      END SUBROUTINE FUNC

      SUBROUTINE STPNT(NDIM,U,PAR,Z)
!     ---------- -----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: Z

      DOUBLE PRECISION pi,A,B,Dx,Dy,RL

      pi=4*DATAN(1.d0)

!      *Set the (constant) parameters
       A  = 2.
       B  = 5.45
       Dx = 0.008
       Dy = 0.004
       RL = 0.75

       PAR(1)=A
       PAR(2)=B
       PAR(3)=RL

!      *Set the actual width of the space interval [0,PAR(11)]
       PAR(11) = 1.

!      *Set the initial data in the (scaled) interval [0,1]
       U(1) = A   - 0.5*DSIN(pi*Z)
       U(2) = B/A + 0.7*DSIN(pi*Z)

!      *Also set the space-derivative of the initial data
!      *Note the scaling by PAR(11)
       U(3) = - 0.5*pi*DCOS(pi*Z)/PAR(11)
       U(4) =   0.7*pi*DCOS(pi*Z)/PAR(11)

!      *Set the diffusion constants
       PAR(15) = Dx/RL**2
       PAR(16) = Dy/RL**2

      END SUBROUTINE STPNT

      SUBROUTINE BCND(NDIM,PAR,ICP,NBC,U0,U1,FB,IJAC,DBC)
!     ---------- ----

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), NBC, IJAC
      DOUBLE PRECISION, INTENT(IN) :: PAR(*), U0(NDIM), U1(NDIM)
      DOUBLE PRECISION, INTENT(OUT) :: FB(NBC)
      DOUBLE PRECISION, INTENT(INOUT) :: DBC(NBC,*)

!      *Define the boundary conditions (Dirichlet, in this example).
       FB(1)=U0(1)-PAR(1)
       FB(2)=U0(2)-PAR(2)/PAR(1)
       FB(3)=U1(1)-PAR(1)
       FB(4)=U1(2)-PAR(2)/PAR(1)

      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT

      SUBROUTINE PVLS
      END SUBROUTINE PVLS


module mod_fold_functions

implicit none

public

contains

pure integer(int8) function sum_i1(x, y) result(res)
  use iso_fortran_env, only:int8
  integer(int8), intent(in) :: x, y
  res = x + y
end function sum_i1

pure integer(int16) function sum_i2(x, y) result(res)
  use iso_fortran_env, only:int16
  integer(int16), intent(in) :: x, y
  res = x + y
end function sum_i2

pure integer(int32) function sum_i4(x, y) result(res)
  use iso_fortran_env, only:int32
  integer(int32), intent(in) :: x, y
  res = x + y
end function sum_i4

pure integer(int64) function sum_i8(x, y) result(res)
  use iso_fortran_env, only:int64
  integer(int64), intent(in) :: x, y
  res = x + y
end function sum_i8

pure real(real32) function sum_r4(x, y) result(res)
  use iso_fortran_env, only:real32
  real(real32), intent(in) :: x, y
  res = x + y
end function sum_r4

pure real(real64) function sum_r8(x, y) result(res)
  use iso_fortran_env, only:real64
  real(real64), intent(in) :: x, y
  res = x + y
end function sum_r8

pure real(real128) function sum_r16(x, y) result(res)
  use iso_fortran_env, only:real128
  real(real128), intent(in) :: x, y
  res = x + y
end function sum_r16

pure complex(real32) function sum_c4(x, y) result(res)
  use iso_fortran_env, only:real32
  complex(real32), intent(in) :: x, y
  res = x + y
end function sum_c4

pure complex(real64) function sum_c8(x, y) result(res)
  use iso_fortran_env, only:real64
  complex(real64), intent(in) :: x, y
  res = x + y
end function sum_c8

pure complex(real128) function sum_c16(x, y) result(res)
  use iso_fortran_env, only:real128
  complex(real128), intent(in) :: x, y
  res = x + y
end function sum_c16

end module mod_fold_functions

program test_foldl
use iso_fortran_env, only:int8, int16, int32, int64, real32, real64, real128
use mod_testing, only:assert, initialize_tests, report_tests
use mod_functional
use mod_fold_functions

implicit none

logical, dimension(:), allocatable :: tests
logical :: test_failed
integer :: n, norder, ntests
integer, parameter :: stdout = 6

complex(real32), dimension(:), allocatable :: c4
complex(real64), dimension(:), allocatable :: c8
complex(real128), dimension(:), allocatable :: c16
complex(real64) :: c8_start
complex(real128) :: c16_start

n = 1
ntests = 10
call initialize_tests(tests, ntests)

tests(n) = assert(foldl(sum_i1, 0_int8, [1_int8, 2_int8, 3_int8, 4_int8, 5_int8]) == 15, &
                        'foldl,  int8')
n = n + 1

tests(n) = assert(foldl(sum_i2, 0_int16, [1_int16, 2_int16, 3_int16, 4_int16, 5_int16]) == 15, &
                        'foldl,  int16')
n = n + 1

tests(n) = assert(foldl(sum_i4, 0_int32, [1_int32, 2_int32, 3_int32, 4_int32, 5_int32]) == 15, &
                        'foldl,  int32')
n = n + 1

tests(n) = assert(foldl(sum_i8, 0_int64, [1_int64, 2_int64, 3_int64, 4_int64, 5_int64]) == 15, &
                        'foldl,  int64')
n = n + 1

tests(n) = assert(foldl(sum_r4, 0._real32, [1._real32, 2._real32, 3._real32, 4._real32, 5._real32]) == 15, &
                        'foldl,  real32')
n = n + 1

tests(n) = assert(foldl(sum_r8, 0._real64, [1._real64, 2._real64, 3._real64, 4._real64, 5._real64]) == 15, &
                        'foldl,  real64')
n = n + 1

tests(n) = assert(foldl(sum_r16, 0._real128, [1._real128, 2._real128, 3._real128, 4._real128, 5._real128]) == 15, &
                        'foldl,  real128')
n = n + 1

c4 = arange(cmplx(1, 0), cmplx(5, 0))
c8 = c4
c16 = c4

c8_start = cmplx(0, 0)
c16_start = c8_start

tests(n) = assert(foldl(sum_c4, cmplx(0., 0.), c4) == cmplx(15, 0), &
                  'foldl,  complex real32')
n = n + 1

tests(n) = assert(foldl(sum_c8, c8_start, c8) == cmplx(15._real64, 0._real64), &
                  'foldl,  complex real64')
n = n + 1

tests(n) = assert(foldl(sum_c16, c16_start, c16) == cmplx(15._real128, 0._real128), &
                  'foldl,  complex real128')
n = n + 1

test_failed = .false.
call report_tests(tests, test_failed)
if(test_failed)stop 1

end program test_foldl


program main

  use mo_kind,   only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_julian, only: ndays, ndyin
  use mo_julian, only: caldat, julday, date2dec, dec2date
  use mo_utils,  only: ne

  implicit none

  integer(i4) :: dd, mm, yy
  integer(i4) :: hh, nn, ss
  integer(i4) :: dd2, mm2, yy2
  integer(i4) :: hh2, nn2, ss2
  real(dp)    :: ff, rr, gg, d0
  integer(i4), dimension(3) :: dd1, mm1, yy1, hh1, nn1, ss1
  integer(i4), dimension(3) :: dd12, mm12, yy12, hh12, nn12, ss12
  real(dp),    dimension(3) :: dec1
  real(dp),    dimension(3) :: rr1, ff1, gg1, fd1, fd2
  integer(i4) :: jj

  logical :: isgood, allgood

  integer(i4),      parameter :: ncal = 10
  character(len=8), dimension(ncal) :: calendars
  integer(i4),      dimension(ncal) :: is1900
  integer(i4)       :: ical, dmin, dmax
  character(len=20) :: iscal
  real(dp)          :: eps

  write(*,*) ''
  write(*,*) 'Test mo_julian.f90'

  allgood = .true.

  calendars(1)  = 'standard'
  calendars(2)  = '360day'
  calendars(3)  = '365day'
  calendars(4)  = '366day'
  calendars(5)  = '360_day'
  calendars(6)  = '365_day'
  calendars(7)  = '366_day'
  calendars(8)  = 'noleap'
  calendars(9)  = 'all_leap'
  calendars(10) = 'lilian'

  is1900(1)  = 2415021
  is1900(2)  = 684000
  is1900(3)  = 693500
  is1900(4)  = 695400
  is1900(5)  = 2380320
  is1900(6)  = 2413380
  is1900(7)  = 2419992
  is1900(8)  = 2413380
  is1900(9)  = 2419992
  is1900(10) = 115861

  dmin = 2415021 - 366 ! < 1899
  dmax = 2524594       ! 01.01.2200 in julian days

  ! ----------------------
  ! IMSL tests

  isgood = .true.

  ! ndays, ndyin
  do jj=0, 109573 ! 01.01.2200
     call ndyin(jj,dd,mm,yy)
     ss = ndays(dd,mm,yy)
     if (jj /= ss) isgood = .false.
  end do
  if (ndays(01,01,1900) /= 0) isgood = .false.
  call ndyin(0, dd, mm, yy)
  if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900)) isgood = .false.
  if (ndays(1,1,-4712) /= -is1900(1)) isgood = .false.
  call ndyin(-is1900(1), dd, mm, yy)
  if ((dd /= 1) .or. (mm /= 1) .or. (yy /= -4712)) isgood = .false.

  allgood = allgood .and. isgood

  if (isgood) then
     write(*,*) 'mo_julian ndyin/ndays ', color('o.k.', c_green)
  else
     write(*,*) 'mo_julian ndyin/ndays ', color('failed!', c_red)
  endif

  ! ----------------------
  ! calendar tests

  do ical=1, ncal

     iscal = calendars(ical)
     isgood = .true.

     ! julday, caldat
     do jj=dmin, dmax ! 01.01.2200
        call caldat(jj, dd, mm, yy, calendar=trim(iscal))
        ss = julday(dd, mm, yy, calendar=trim(iscal))
        if (jj /= ss) isgood = .false.
     end do
     if (julday(01, 01, 1900, calendar=trim(iscal)) /= is1900(ical)) isgood = .false.
     call caldat(is1900(ical), dd, mm, yy, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900)) isgood = .false.

     ! date2dec

     if (trim(iscal)=='lilian') then
        hh = 0
        ff = 0._dp
        gg = 0.5_dp
        eps = epsilon(1.0_dp)*(real(is1900(ical),dp)+2299159.5_dp)
     else
        hh = 12
        ff = 0.5_dp
        gg = 0._dp
        eps = epsilon(1.0_dp)*real(is1900(ical),dp)
     endif
     if (abs(date2dec(01,01,1900,hh,0, calendar=trim(iscal)) - real(is1900(ical),dp)) > eps*10.0_dp) isgood = .false.
     if (abs(date2dec(01,01,1900, calendar=trim(iscal)) - real(is1900(ical),dp) + ff) > eps*10.0_dp) isgood = .false.
     if (abs(date2dec(01,01,1900, fracday=0.5_dp, calendar=trim(iscal)) - real(is1900(ical),dp) - gg) > &
             eps*10.0_dp) isgood = .false.

     ! date2dec, dec2date - scalar
     do jj=dmin, dmax ! 01.01.2200
        call random_number(ff)
        rr = real(jj,dp) + ff
        call dec2date(rr,dd,mm,yy,hh,nn,ss, calendar=trim(iscal))
        gg = date2dec(dd,mm,yy,hh,nn,ss, calendar=trim(iscal))
        call dec2date(gg,dd2,mm2,yy2,hh2,nn2,ss2, calendar=trim(iscal))
        if ((dd /= dd2) .or. (mm /= mm2) .or. (yy /= yy2) .or. (hh /= hh2) .or. (nn /= nn2) .or. (ss /= ss2)) &
             isgood = .false.
     end do

     call dec2date(date2dec(01,01,1900,12,01,02, calendar=trim(iscal)), dd, mm, yy, hh, nn, ss, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 12) .or. (nn /= 01) .or. (ss /= 02)) isgood = .false.
     call dec2date(date2dec(01,01,1900, calendar=trim(iscal)), dd, mm, yy, hh, nn, ss, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 00) .or. (nn /= 00) .or. (ss /= 00)) isgood = .false.
     call dec2date(date2dec(01,01,1900,23,59,59, calendar=trim(iscal)), dd, mm, yy, hh, nn, ss, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 23) .or. (nn /= 59) .or. (ss /= 59)) isgood = .false.
     call dec2date(date2dec(01,01,01,12,12,12, calendar=trim(iscal)), dd, mm, yy, hh, nn, ss, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 01) .or. (hh /= 12) .or. (nn /= 12) .or. (ss /= 12)) isgood = .false.
     call dec2date(date2dec(01,02,-100,11,11,11, calendar=trim(iscal)), dd, mm, yy, hh, nn, ss, calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 2) .or. (yy /= -100) .or. (hh /= 11) .or. (nn /= 11) .or. (ss /= 11)) isgood = .false.

     ! date2dec, dec2date - vector
     do jj=dmin, dmax ! 01.01.2200
        call random_number(ff1)
        rr1 = real(jj,dp) + ff1
        call dec2date(rr1,dd1,mm1,yy1,hh1,nn1,ss1,calendar=trim(iscal))
        gg1 = date2dec(dd1,mm1,yy1,hh1,nn1,ss1,calendar=trim(iscal))
        call dec2date(gg1,dd12,mm12,yy12,hh12,nn12,ss12,calendar=trim(iscal))
        if (any(dd1 /= dd12) .or. any(mm1 /= mm12) .or. any(yy1 /= yy12) .or. &
             any(hh1 /= hh12) .or. any(nn1 /= nn12) .or. any(ss1 /= ss12)) isgood = .false.
     end do

     call dec2date(date2dec((/01,10,27/),(/02,12,03/),(/-100,1,2000/),(/11,23,00/),(/11,57,47/),(/11,12,59/), &
          calendar=trim(iscal)), dd1, mm1, yy1, hh1, nn1, ss1, calendar=trim(iscal))
     if ((dd1(1) /= 1) .or. (mm1(1) /= 2) .or. (yy1(1) /= -100) .or. &
          (hh1(1) /= 11) .or. (nn1(1) /= 11) .or. (ss1(1) /= 11)) isgood = .false.
     if ((dd1(2) /= 10) .or. (mm1(2) /= 12) .or. (yy1(2) /= 1) .or. &
          (hh1(2) /= 23) .or. (nn1(2) /= 57) .or. (ss1(2) /= 12)) isgood = .false.
     if ((dd1(3) /= 27) .or. (mm1(3) /= 3) .or. (yy1(3) /= 2000) .or. &
          (hh1(3) /= 0) .or. (nn1(3) /= 47) .or. (ss1(3) /= 59)) isgood = .false.

     ! date2dec, dec2date - scalar/vector mix
     ! This does not work with all NAG compilers. Have to have temporary array.
     ! call dec2date360(date2dec360(01,12,2000,(/11,12,13/),11,59), dd1, mm1, yy1, hh1, nn1, ss1)
     do jj=dmin, dmax ! 01.01.2200
        call random_number(ff1)
        rr1 = real(jj,dp) + ff1
        call dec2date(rr1,dd1,mm1,yy1,hh1,nn1,ss1, calendar=trim(iscal))
        gg1 = date2dec(dd1(1),mm1(1),yy1(1),hh1,nn1,ss1, calendar=trim(iscal))
        call dec2date(gg1,dd12,mm12,yy12,hh12,nn12,ss12, calendar=trim(iscal))
        if (any(dd1(1) /= dd12) .or. any(mm1(1) /= mm12) .or. any(yy1(1) /= yy12) .or. &
             any(hh1 /= hh12) .or. any(nn1 /= nn12) .or. any(ss1 /= ss12)) isgood = .false.
     end do

     dec1 = date2dec(01,12,2000,(/11,12,13/),11,59, calendar=trim(iscal))
     call dec2date(dec1, dd1, mm1, yy1, hh1, nn1, ss1, calendar=trim(iscal))
     if ((dd1(1) /= 1) .or. (mm1(1) /= 12) .or. (yy1(1) /= 2000) .or. &
          (hh1(1) /= 11) .or. (nn1(1) /= 11) .or. (ss1(1) /= 59)) isgood = .false.
     if ((dd1(2) /= 1) .or. (mm1(2) /= 12) .or. (yy1(2) /= 2000) .or. &
          (hh1(2) /= 12) .or. (nn1(2) /= 11) .or. (ss1(2) /= 59)) isgood = .false.
     if ((dd1(3) /= 1) .or. (mm1(3) /= 12) .or. (yy1(3) /= 2000) .or. &
          (hh1(3) /= 13) .or. (nn1(3) /= 11) .or. (ss1(3) /= 59)) isgood = .false.

     ! Mix
     do jj=dmin, dmax ! 01.01.2200
        call caldat(jj,dd,mm,yy, calendar=trim(iscal))
        ss = int(date2dec(dd,mm,yy,12,0,0, calendar=trim(iscal)), i4)
        if (jj /= ss) isgood = .false.
     end do

     ! fracday
     do jj=dmin, dmax ! 01.01.2200
        call random_number(ff1)
        rr1 = real(jj,dp) + ff1
        call dec2date(rr1,dd1,mm1,yy1,fracday=fd1, calendar=trim(iscal))
        gg1 = date2dec(dd1(1),mm1(1),yy1(1),fracday=fd1, calendar=trim(iscal))
        call dec2date(gg1,dd12,mm12,yy12,fracday=fd2, calendar=trim(iscal))
        if (any(dd1(1) /= dd12) .or. any(mm1(1) /= mm12) .or. any(yy1(1) /= yy12) .or. any(ne(fd1,fd2))) &
             isgood = .false.
     end do

     ! units
     d0 = date2dec(1,1,1900,calendar=trim(iscal))
     do jj=is1900(ical), is1900(ical)+dmax-dmin
        call random_number(ff)
        rr = real(jj,dp) + ff
        call dec2date(rr,dd,mm,yy,hh,nn,ss,calendar=trim(iscal))
        rr = date2dec(dd,mm,yy,hh,nn,ss,calendar=trim(iscal)) ! include eps
        gg = rr - d0     ! days since 01.01.1900 00:00:00
        call dec2date(gg,dd2,mm2,yy2,hh2,nn2,ss2,units='days since 1900-01-01 00:00:00',calendar=trim(iscal))
        if ((dd /= dd2) .or. (mm /= mm2) .or. (yy /= yy2) .or. (hh /= hh2) .or. (nn /= nn2) .or. (ss /= ss2)) &
             isgood = .false.
        gg = gg * 24._dp ! hours since 01.01.1900 00:00:00
        call dec2date(gg,dd2,mm2,yy2,hh2,nn2,ss2,units='hours since 1900-1-01 00:00:00',calendar=trim(iscal))
        if ((dd /= dd2) .or. (mm /= mm2) .or. (yy /= yy2) .or. (hh /= hh2) .or. (nn /= nn2) .or. (ss /= ss2)) &
             isgood = .false.
        gg = gg * 60._dp ! minutes since 01.01.1900 00:00:00
        call dec2date(gg,dd2,mm2,yy2,hh2,nn2,ss2,units='minutes since 1900-01-1 00:00',calendar=trim(iscal))
        if ((dd /= dd2) .or. (mm /= mm2) .or. (yy /= yy2) .or. (hh /= hh2) .or. (nn /= nn2) .or. (ss /= ss2)) &
             isgood = .false.
        gg = gg * 60._dp ! seconds since 01.01.1900 00:00:00
        call dec2date(gg,dd2,mm2,yy2,hh2,nn2,ss2,units='seconds since 1900-1-1 00',calendar=trim(iscal))
        if ((dd /= dd2) .or. (mm /= mm2) .or. (yy /= yy2) .or. (hh /= hh2) .or. (nn /= nn2) .or. (ss /= ss2)) &
             isgood = .false.
     end do

     call dec2date(0.5_dp, dd, mm, yy, hh, nn, ss, units='days since 1900-1-1',calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 12) .or. (nn /= 0) .or. (ss /= 0)) isgood = .false.
     call dec2date(12.0_dp, dd, mm, yy, hh, nn, ss, units='hours since 1900-01-01 12:00',calendar=trim(iscal))
     if ((dd /= 2) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 0) .or. (nn /= 0) .or. (ss /= 0)) isgood = .false.
     call dec2date(60.0_dp, dd, mm, yy, hh, nn, ss, units='minutes since 1900-01-01 12:00',calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 13) .or. (nn /= 0) .or. (ss /= 0)) isgood = .false.
     call dec2date(59.0_dp, dd, mm, yy, hh, nn, ss, units='seconds since 1900-01-01 12:00',calendar=trim(iscal))
     if ((dd /= 1) .or. (mm /= 1) .or. (yy /= 1900) .or. (hh /= 12) .or. (nn /= 0) .or. (ss /= 59)) isgood = .false.

     allgood = allgood .and. isgood

     if (isgood) then
        write(*,*) 'mo_julian ', trim(iscal), ' ', color('o.k.', c_green)
     else
        write(*,*) 'mo_julian ', trim(iscal), ' ', color('failed!', c_red)
     endif

  end do

  if (allgood) then
     write(*,*) 'mo_julian ', color('o.k.', c_green)
  else
     write(*,*) 'mo_julian ', color('failed!', c_red)
  endif

  ! ! Check 59 minutes, 60 seconds problem if eps too small in dec2date
  ! dec1(1) = 2443879.5_dp
  ! write(*,*) '#00: ', dec1(1), 1._dp/24._dp, date2dec(1,1,1990,1,0,0) - date2dec(1,1,1990,0,0,0)
  ! call dec2date(dec1(1), dd, mm, yy, hh, nn, ss)
  ! write(*,*) '#01: ', dec1(1), dd, mm, yy, hh, nn, ss
  ! dec1(1) = dec1(1) + 1._dp/24._dp
  ! call dec2date(dec1(1), dd, mm, yy, hh, nn, ss)
  ! write(*,*) '#02: ', dec1(1), dd, mm, yy, hh, nn, ss
  ! dec1(1) = dec1(1) - 1._dp/24._dp
  ! call dec2date(dec1(1), dd, mm, yy, hh, nn, ss)
  ! write(*,*) '#03: ', dec1(1), dd, mm, yy, hh, nn, ss
  ! dec1(1) = dec1(1) + date2dec(1,1,1990,1,0,0) - date2dec(1,1,1990,0,0,0)
  ! call dec2date(dec1(1), dd, mm, yy, hh, nn, ss)
  ! write(*,*) '#04: ', dec1(1), dd, mm, yy, hh, nn, ss

  ! ! Check date2dec with John
  ! write(*,*) '#05: ', date2dec(22,12,2005,15,00,00)
  ! write(*,*) '#06: ', date2dec(22,12,2005,16,00,00)
  ! write(*,*) '#07: ', date2dec(22,12,2005,17,00,00)
  ! write(*,*) '#08: ', date2dec(22,12,2005,17,01,00)
  ! write(*,*) '#09: ', date2dec(22,12,2005,17,00,01)

  ! ! check python
  ! dd2 = 16
  ! mm2 = 1
  ! yy2 = 2004
  ! hh2 = 12
  ! nn2 = 0
  ! ss2 = 0
  ! gg = date2dec(16,01,2004,12,0,calendar='360day') - date2dec(01,01,1850,calendar='360day')
  ! print*, 'days of 16.01.2004 12:00 from 01.01.1850 00:00: ', gg

END PROGRAM main


program pardiso_basic
!! https://software.intel.com/en-us/mkl-developer-reference-fortran-intel-mkl-pardiso-parameters-in-tabular-form

use, intrinsic :: iso_fortran_env, only: int64, dp=>real64, stderr=>error_unit

implicit none (type, external)

integer(int64) :: pt(64)
integer :: maxfct, mnum, mtype, phase, n, nrhs, error, msglvl
integer :: iparm(64)
integer :: ia(9), ja(18)
real(dp) :: dparm (64), a(18), b(8), x(8), y(8)
integer :: i, j, idum, solver
real(dp) :: waltime1, waltime2, ddum, normb, normr

external :: pardisoinit, pardiso

pt = 0
iparm = 0

!! example
maxfct = 1
mnum = 1
n = 8
nrhs = 1
mtype = -2 ! real, symmetric, indefinite
solver = 10 ! use sparse direct method
msglvl = 1

!! sparse example matrix
ia = [1,5,8,10,12,15,17,18,19]

ja = [&
1, 3, 6, 7, &
2, 3, 5, &
3, 8, &
4, 7, &
5, 6, 7, &
6, 8, &
7, &
8]

a = [&
7._dp, 1._dp, 2._dp, 7._dp, &
-4._dp, 8._dp, 2._dp, &
1._dp, 5._dp, &
7._dp, 9._dp, &
5._dp, -1._dp, 5._dp, &
0._dp, 5._dp, &
11._dp, &
5._dp]

!! example rhs
do i = 1, n
  b(i) = i
end do

! -------------------------------------
!! https://software.intel.com/en-us/mkl-developer-reference-fortran-pardiso

!! initialize pardiso
call pardisoinit(pt, mtype, iparm)

!! analysis
phase = 11
call pardiso(pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
              idum, nrhs, iparm, msglvl, ddum, ddum, error, dparm)

if (error /= 0) then
  write(stderr,*) 'ERROR: pardiso reordering: code ',error
  error stop
endif

!! factorization
phase = 22
call pardiso(pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
              idum, nrhs, iparm, msglvl, ddum, ddum, error, dparm)

if (error /= 0) then
  write(stderr,*) 'ERROR: pardiso factoring: code ',error
  error stop
endif

if (iparm(33) == 1) print *,'log(determinant) = ',dparm

!! deallocate internal memory
phase = -1
call pardiso(pt, maxfct, mnum, mtype, phase, n, a, ia, ja, &
              idum, nrhs, iparm, msglvl, ddum, ddum, error, dparm)

end program