c=======================================================================
c
c     GENNOR
c
c     General Normal distribution generator N(mean,std).
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION gennor(av, sd)
c-----------------------------------------------------------------------
c
c     INPUT :
c          av  : mean of the normal distribution                  double
c          std : std of the normal distribution (>0)              double
c
c     OUTPUT :
c          gennor : generated normal deviate                      double
c
c-----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION av,sd
c
c     external functions
      DOUBLE PRECISION snorm
      EXTERNAL snorm
c
c     executable statements
      gennor = sd*snorm() + av
      RETURN
      END


PROGRAM anneal_test

  use mo_kind,    only: dp, i4, i8
  use mo_anneal,  only: anneal            !, anneal_valid
  use mo_anneal,  only: GetTemperature    !, GetTemperature_valid
  use mo_cost,    only: cost_dp, range_dp !, cost_valid_dp
  use mo_xor4096, only: get_timeseed
  use mo_ansi_colors, only: color, c_red, c_green

  IMPLICIT NONE

  REAL(DP), DIMENSION(4)            :: para
  REAL(DP)                          :: temperature
  REAL(DP)                          :: costbest
  REAL(DP), DIMENSION(size(para,1)) :: parabest

  REAL(DP)                          :: costbestAll
  REAL(DP), DIMENSION(size(para,1)) :: parabestAll

  INTEGER(I4)                       :: i, runs
  INTEGER(I8), DIMENSION(3)         :: seeds
  REAL(DP)                          :: Tstart, Tend
  REAL(DP), DIMENSION(:,:), ALLOCATABLE :: history

  ! time dependent seeds
  call get_timeseed(seeds)
  print*, 'time dependent seeds would be: ', seeds

  runs = 4_i4

  para(1) = 2.0_dp
  para(2) = 10.0_dp
  para(3) = 0.5_dp
  para(4) = 0.4_dp

  ! Initialization
  print*, '-----------------------------------'
  print*, '   INITIALIZATION                  '
  print*, '-----------------------------------'
  print*, 'Initial parameter set:       ',para
  print*, 'Initial cost function value: ',cost_dp(para(:))
  costbestAll = cost_dp(para(:))
  parabestAll = para(:)
  print*, '-----------------------------------'
  print*, '   INITIAL TEMPERATURE             '
  print*, '-----------------------------------'
  print*, 'Estimation of Initial Temperature: '
  seeds(1) = 854_i8
  seeds(2) = seeds(1) + 1000_i8
  print*, 'seeds used:                        ', seeds(1:2)
  temperature = GetTemperature( para, cost_dp, 0.95_dp, &
       ! optionals
       prange_func=range_dp, &
       samplesize=500_i4, &
       seeds=seeds(1:2), &
       printflag=.true.)

  print*, '-----------------------------------'
  print*, '   SIMULATED ANNEALING             '
  print*, '-----------------------------------'

  ! Run Simulated Annealing <runs> times
  do i=1,runs
     ! Setting the seeds: Only used to generate comparable results for test case
     seeds(1) = int(i,i8)*259_i8
     seeds(2) = seeds(1) + 1000_i8
     seeds(3) = seeds(2) + 1000_i8
     print*, 'seeds used: ', seeds(1:3)
     !
     call cpu_time(Tstart)
     parabest = anneal(cost_dp, para, &
          ! optionals
          prange_func=range_dp, &
          maxit=.false., &
          temp=temperature, &
          seeds=seeds,&
          LEN=250_i4, &
          nST=5_i4, &
          nITERmax=150000_i4, &
          eps=0.00001_dp,&
          acc=0.1_dp,&
          DT=0.90_dp, &
          printflag=.false., &
          funcbest=costbest, history=history, &
          weight=(/ 1.0_dp, 1.0_dp, 1.0_dp, 1.0_dp  /), &
          maskpara=(/ .true., .true., .true., .true. /), &
          undef_funcval=9999.0_dp, &
          ! settings for standard simulated annealing
          reflectionFlag=.False., &
          pertubFlexFlag=.True., &
          changeParaMode=1_i4)
          ! settings for dds generation of new parameter sets
          ! reflectionFlag=.True., &
          ! pertubFlexFlag=.False., &
          ! changeParaMode=3_i4)
     call cpu_time(Tend)
     if (costbestAll .gt. costbest) then
        costbestAll = costbest
        parabestAll = parabest
     end if
     print*,'Run ',i,':   cost = ',costbest,'  (CPU time = ',Tend-Tstart,' sec)'
  end do

  ! Print best overall solutions
  print*, '-----------------------------------'
  print*, 'Best solution found in ',runs,' Runs'
  print*, '   costbest = ', costbestAll
  print*, '   parabest = ', parabestAll

  ! Is program running properly?   costbestAll = 1.5210594853672710E-002
  print*, '-----------------------------------'
  if ( nint(costbestAll*100000) .eq. 1521 ) then
     print*, 'mo_anneal: ', color('o.k.', c_green)
  else
     print*, 'mo_anneal: ', color('failed', c_red)
  end if

END PROGRAM anneal_test


C++***************************************************************
C    Program PROFILE1
C
C This program computes a profile along elliptical annuli.
C Discards stars and defects over n-sigma (n is chosen by the user)
C Possibility of computation within angular sectors or on complete annuli.
C Input parameters in a file (See PROFILE1.DOC for documentation
C Output profile stored with the input parameter file.
C
C Multiple sectors (i.e. a series of 12 sectors of 30 degrees) can
C be selected in the parameter file (option 3).
C
C Syntax:
C       RUNS PROFILE1 [Y/N: mask?] [[mask_name]] parameter_file
C
C Examples:
C       RUNS PROFILE1 N in_image parameter_file out_profile
C       RUNS PROFILE1 Y test_mask in_image parameter_file out_profile
C
C JLP
C Version of 02-02-94
C--***************************************************************
C Unit 2  : Profile (Output)
C Unit 3  : profile1.log (Logfile)
C Unit 10 : Parameter input file
C*****************************************************************
	PROGRAM PROFILE1
	PARAMETER (IDIM1=2000)
        REAL*4 R1,R2,R3,R4,RADMAX
C Linux 32 bits:
C	INTEGER*4 PNTR_ARRAY,IPROF2D,PNTR_MASK
C Linux 64 bits: I switch to INTEGER*8:
	INTEGER*8 PNTR_ARRAY,IPROF2D,PNTR_MASK
C
	INTEGER*4 MADRID(1)
	LOGICAL MASK_OUT,SECTOR,MEDIAN,MULT_SECT
	CHARACTER NAME1*40,NAMEPRO*40,NAMEPAR*40,COMMENTS1*160
	CHARACTER MASK_NAME*40,MASK_COM*160
	CHARACTER ANS*1

	COMMON /VMR/MADRID
	COMMON /PRF1_DATA/NX,NY,NAME1,COMMENTS1
	COMMON /PRF1_OPTIONS/MASK_OUT,SECTOR,MEDIAN,MULT_SECT
	COMMON /PRF1_PARAM/AXRATIO,PHI,X0,Y0,RADMIN1,RADMAX1,AMIN,AMAX,
     1	XINCREM,FACT,SCALE,SKY,NBINS,SIGREJEC,BADVALUE,ITERMAX,RVMAG
	COMMON /PRF1_UTILITIES/AXISMIN,AXISMAX,BB1,DD1,UU,VV,WW,
     1	IXMIN,IXMAX,IYMIN,IYMAX

10	FORMAT(A)
	CALL JLP_BEGIN
C Writing the title :
	WRITE(6,867)
867	FORMAT(' Program PROFILE1 to compute profiles of galaxies',
     1	' Version of 02/02/94',/)

C Output file with all the important details
	OPEN(3,FILE='profile1.log',STATUS='unknown',
     1	ACCESS='SEQUENTIAL',ERR=999)
	WRITE(3,867)

C Prompting the format for the files :
	CALL JLP_INQUIFMT

	PRINT 15
15	FORMAT(' Do you want to output a mask with the pixels which',
     1	/,' will be selected when computing the profile (N)')
	READ(5,10) ANS
	MASK_OUT=(ANS.EQ.'Y'.OR.ANS.EQ.'y')
	IF(MASK_OUT)THEN
	 PRINT *,' Enter the name for the output mask:'
	 READ(5,10) MASK_NAME
	ENDIF

C Input image file
	PRINT *,' Input image file ?'
	READ(5,10) NAME1

C**** Input of the image to process *****************
	CALL JLP_VM_READIMAG(PNTR_ARRAY,NX,NY,NAME1,COMMENTS1)
	WRITE(3,868)NAME1,NX,NY
868	FORMAT(' INPUT FILE : ',A,/,' NX, NY :',I4,2X,I4)

C Input file with the input parameters
	PRINT *,' Input file with the parameters for the profile ?'
	READ(5,10) NAMEPAR

C Read the parameter file :
	CALL READ_PARAM(NAMEPAR)

C Ouput profile:
	PRINT *,' Output profile name ?'
	READ(5,10) NAMEPRO

C********** Special case : multiple sectors  **********
C Loop on the different sectors if MULT_SECT is true :
	IF(MULT_SECT)THEN
         PRINT *,' OK: multiple sectors'
	 ISECTOR=1
	 AMIN=0.
	 AMAX=30.
C Incrementing the names of the profiles automatically :
	 I=INDEX(NAMEPRO,' ')
	 INDX=INDEX(NAMEPRO,'.')
	 IF(INDX.EQ.0)INDX=I

C Starting the loop :
554	 I1=ISECTOR/10
	 I2=ISECTOR-10*I1
	 WRITE(NAMEPRO(INDX:INDX+6),873)I1,I2
873	 FORMAT('_',I1,I1,'.pro')
	ENDIF

C*********** General procedure ********
C Computes different coefficients which are used during all the following ;
	CALL UTILITIES

C Exit if too many bins
	IF(NBINS.GT.IDIM1)THEN
	  PRINT *,' Fatal error : too many bins !'
	  PRINT *,' NBINS =',NBINS
	  PRINT *,' Whereas   MAX Number =',IDIM1
	  STOP
	ENDIF

C An estimation of the maximum number of pixels in the annuli is given
C by (circle_length*(width+2)) where width is in pixels.
C (+1) is due to the "thickness" of each pixel.
C
C Four angles of the frame:
        R1=(FLOAT(NX)-X0)**2+(FLOAT(NY)-Y0)**2
        R2=(FLOAT(NX)-X0)**2+(FLOAT(NY)-Y0)**2
        R3=(FLOAT(NX)-X0)**2+(FLOAT(NY)-Y0)**2
        R4=(FLOAT(NX)-X0)**2+(FLOAT(NY)-Y0)**2
        RADMAX=MAX(R1,R2)
        RADMAX=MAX(RADMAX,R3)
        RADMAX=MAX(RADMAX,R4)
C Conversion to arcsec:
        RADMAX=SCALE*SQRT(RADMAX)
C Take minimum value of RADMAX1 (max wanted by the user) and maximum
C value taking into account the size of the image:
        RADMAX=MIN(RADMAX,RADMAX1)
C Then compute maximum width:
        XINC_MAX=XINCREM
        R1=RADMIN1
        DO I=1,NBINS
C R2: old value, R1: new value of radius
         R2=R1
         XINC_MAX=XINC_MAX*FACT
         R1=R1+XINC_MAX
         IF(R1.GT.RADMAX)GOTO 34
        ENDDO
C Computing equivalent radius betwwen R2 and RADMAX:
34      R3=(R2**2 + RADMAX**2)/2.
        R3=SQRT(R3)
C 2 PI -> 6.30
        R3=6.30*(R3/SCALE)*(1.+XINC_MAX/SCALE)
        NMAX=NINT(R3)
        WRITE(6,38) RADMAX,R3,XINC_MAX,NMAX,NBINS
38      FORMAT(' Estimated maximum radius: ',G12.5,' arcsec'/,
     1         ' Equivalent radius of last annulus: ',G12.5,' arcsec'/,
     1         ' Maximum annulus width (last annulus): ',G12.5,' arcsec',/,
     1         ' Maximum number of pixels in an annulus: ',I8,/,
     1         ' Number of annuli (NBINS): ',I5)

C Allocating memory space for the working array PROF2D :
	N_VMSIZE=NBINS*4*NMAX
	CALL JLP_GETVM(IPROF2D,N_VMSIZE)

C Loading the array in PROF2D
	CALL GENE_PROF2D(MADRID(PNTR_ARRAY),NX,MADRID(IPROF2D),NMAX)

C Computing the profile :
	IF(MEDIAN)THEN
C Set ratio to 0.5 (since looking for the middle value of the histogram...)
	 RATIO=0.50
	 CALL MEDIAN_PROF2D(MADRID(PNTR_ARRAY),NX,
     1	MADRID(IPROF2D),NMAX,RATIO)
	ELSE
	 CALL MEAN_PROF2D(MADRID(PNTR_ARRAY),NX,
     1	MADRID(IPROF2D),NMAX)
	ENDIF

C Output the results :
	CALL OUTPUT_RESULTS(NAMEPAR,NAMEPRO)

C********** Special case : multiple sectors  **********
C Loop on the different sectors if MULT_SECT is true :
	IF(MULT_SECT.AND.AMAX.LT.360.)THEN
	 ISECTOR=ISECTOR+1
	 AMIN=AMIN+30.
	 AMAX=AMAX+30.
C Freeing memory space:
	 CALL JLP_FREEVM(IPROF2D,N_VMSIZE)
	 GO TO 554
	ENDIF

C ****** Only the last one if multiple sectors ******
C Creation and output of the mask *******************
	IF(MASK_OUT)THEN

C Allocating memory space :
	  ISIZE=NX*NY*4
	  CALL JLP_GETVM(PNTR_MASK,ISIZE)

	  IF(MEDIAN)THEN
	   CALL MASK_MINI(MADRID(PNTR_MASK),MADRID(PNTR_ARRAY),NX)
	  ELSE
	   CALL MASK_MEAN(MADRID(PNTR_MASK),MADRID(PNTR_ARRAY),NX)
	  ENDIF
	 PRINT *,' Output of the mask :'
	 MASK_COM=' '
	 I=INDEX(NAMEPRO,'  ')
	 WRITE(MASK_COM,101)NAMEPRO(1:I-1)
101	 FORMAT(' Mask with ',A,'//')
	 PRINT *,' COMMENTS FOR THE MASK :',MASK_COM
	 CALL JLP_WRITEIMAG(MADRID(PNTR_MASK),NX,NY,NX,
     1	MASK_NAME,MASK_COM)
C Freeing memory space :
	  CALL JLP_FREEVM(PNTR_MASK,ISIZE)
	ENDIF

	CALL JLP_END
	STOP
999	PRINT *,' Fatal error opening "profile1.log"'
	CALL JLP_END
	STOP
	END
C ******************************************************************
C Subroutine GENE_PROF2D
C
C To generate a 2-D array PROF2D(NMAX,NBINS) by scanning the input
C image ARRAY once.
C
C
C Output :
C
C PROF2D : Array of the values of the input image classified according
C	   to the major axis of the ellipses which they belong to.
C RADFIRST : Mean equivalent radius in arcseconds for the first iteration
C NBFIRST  : pixel number in each annulus
C
C*******************************************************************
	SUBROUTINE GENE_PROF2D(ARRAY,IDIM,PROF2D,NMAX)
	PARAMETER (IDIM1=2000)
	REAL*4 PROF2D(NMAX,NBINS),ARRAY(IDIM,*)
	REAL*8 MEAN(IDIM1),RADFIRST(IDIM1),
     1	SUM_MAJAX(IDIM1),SIGMA(IDIM1)
	INTEGER*4 NBER(IDIM1),NBFIRST(IDIM1)
	LOGICAL MASK_OUT,SECTOR,MEDIAN,MULT_SECT,NORMAL
	CHARACTER NAME1*40,COMMENTS1*160

	COMMON /PRF1_DATA/NX,NY,NAME1,COMMENTS1
	COMMON /PRF1_OPTIONS/MASK_OUT,SECTOR,MEDIAN,MULT_SECT
	COMMON /PRF1_PARAM/AXRATIO,PHI,X0,Y0,RADMIN1,RADMAX1,AMIN,AMAX,
     1	XINCREM,FACT,SCALE,SKY,NBINS,SIGREJEC,BADVALUE,ITERMAX,RVMAG
	COMMON /PRF1_RESULTS/MEAN,SIGMA,NBER,RADFIRST,NBFIRST
	COMMON /PRF1_UTILITIES/AXISMIN,AXISMAX,BB1,DD1,UU,VV,WW,
     1	IXMIN,IXMAX,IYMIN,IYMAX

C Logical name:
	NORMAL=(AMIN.LE.AMAX)

C **********************************************************************
C Determination of the radius for each annulus
C The image is scanned once
C **********************************************************************
	 DO K=1,NBINS
	   NBFIRST(K)=0
	   SUM_MAJAX(K)=0.D0
	 END DO

	 DO 3 IY=IYMIN,IYMAX
	 Y1=FLOAT(IY)-Y0

	  DO 2 IX=IXMIN,IXMAX
	  X1=FLOAT(IX)-X0

C Check if the pixel lies within the angular limits of the sector :
	    IF (SECTOR) THEN
	     CALL ANGLED(X1,Y1,APOINT)
	     IF(NORMAL)THEN
	       IF((APOINT.LT.AMIN).OR.(APOINT.GT.AMAX)) GO TO 2
	     ELSE
	       IF((APOINT.LT.AMIN).AND.(APOINT.GT.AMAX)) GO TO 2
	     ENDIF
	    ENDIF

C F2: Semi major axis of the ellipse containing the current pixel (in arcsec)
	  F2=SCALE*SQRT(UU*X1*X1+VV*Y1*Y1+WW*X1*Y1)
C JLP94: before .LE. now .LT.
	  IF(F2.LT.AXISMIN)GO TO 2

C KBIN : Index of the profile bin corresponding to the current pixel
	  KBIN=1+INT(SQRT(BB1*BB1+DD1*(F2-AXISMIN))-BB1)
	    IF(KBIN.GE.1.AND.KBIN.LE.NBINS) THEN
	     NBFIRST(KBIN) = NBFIRST(KBIN)+1
             IF(NBFIRST(KBIN).LE.0)THEN
               PRINT *,' PB, NBFIRST (KBIN) =',NBFIRST(KBIN),' KBIN=',KBIN
             ENDIF
	     SUM_MAJAX(KBIN)=SUM_MAJAX(KBIN)+F2
	     PROF2D(NBFIRST(KBIN),KBIN)=ARRAY(IX,IY)
	    ENDIF

2	  CONTINUE

3        CONTINUE

C Reduce the value of NBINS if the array is too large.
94	IF(NBFIRST(NBINS).NE.0.OR.NBINS.LT.2)GOTO 95
	NBINS=NBINS-1
	GOTO 94

C Computing the mean equivalent radius (sqrt(a*b)) for each annulus :
95	  DO KL=1,NBINS
	   IF(NBFIRST(KL).GT.0.)
     1	RADFIRST(KL)=SQRT(AXRATIO)*SUM_MAJAX(KL)/FLOAT(NBFIRST(KL))
	  END DO

	RETURN
	END
C ******************************************************************
C Subroutine MEAN_PROF2D
C Computes a mean profile discarding the
C bad points (BADVALUE) and the stars and defects over n-sigma.
C
C Meaning of the different arrays for the main loop on ITER (iterations):
C
C SIGMA    : sigma computed in the previous iteration (ITER_1)
C MEAN     : mean computed in the previous iteration (ITER-1)
C NBER     : pixel number beeing computed in this iteration
C
C and variables :
C
C SUM      : sum being computed in the current iteration
C SUMSQ    : sum of squares being computed in the current iteration
C
C Output:
C MEAN, SIGMA, NBER : of the last iteration
C
C*******************************************************************
	SUBROUTINE MEAN_PROF2D(ARRAY,IDIM,PROF2D,NMAX)
	PARAMETER (IDIM1=2000)
	REAL*4 PROF2D(NMAX,NBINS),ARRAY(IDIM,*)
	REAL*8 MEAN(IDIM1),RADFIRST(IDIM1),SIGMA(IDIM1)
	REAL*8 SUM,SUMSQ,WORK
	INTEGER*4 NBER(IDIM1),NBFIRST(IDIM1)

	COMMON /PRF1_PARAM/AXRATIO,PHI,X0,Y0,RADMIN1,RADMAX1,AMIN,AMAX,
     1	XINCREM,FACT,SCALE,SKY,NBINS,SIGREJEC,BADVALUE,ITERMAX,RVMAG
	COMMON /PRF1_RESULTS/MEAN,SIGMA,NBER,RADFIRST,NBFIRST

C **********************************************************************
C Main loop on the radius index KBIN :
C **********************************************************************

	DO K=1,NBINS

C Initialization:
	 MEAN(K)=0.
	 SIGMA(K)=10000000.
	 NBER(K)=0

C **********************************************************************
C The line (K) is scanned ITERMAX times, and stars and defects over n-sigma
C are automatically discarded.
C **********************************************************************

	DO ITER=1,ITERMAX
	 SUM=0.D0
	 SUMSQ=0.D0
	 NB=0
	 SIG3=SIGREJEC*SIGMA(K)

	   DO I=1,NBFIRST(K)
	    WORK=ABS(PROF2D(I,K)-MEAN(K))
C Discard the points equal to BADVALUE or over n-sigma :
C JLP94: do not discard any point if the bin contains less than 8 pixels
	     IF((NBFIRST(K).LE.8)
     1          .OR.(PROF2D(I,K).NE.BADVALUE.AND.WORK.LT.SIG3))THEN
	      NB=NB+1
	      SUMSQ=SUMSQ+PROF2D(I,K)*PROF2D(I,K)
	      SUM=SUM+PROF2D(I,K)
	     ENDIF
	   END DO

C Compute the mean and standard deviation for each annulus,
C and store the result in the arrays MEAN and SIGMA :
	  IF(NB.NE.0)THEN
	   NBER(K)=NB
	   MEAN(K)=SUM/FLOAT(NB)
	  IF(NB.GT.3)
     1	SIGMA(K)=DSQRT((SUMSQ/FLOAT(NB))-MEAN(K)*MEAN(K))
	  ENDIF

C Go to another iteration
	 END DO

C Go to another bin
	END DO

	RETURN
	END
C ******************************************************************
C Subroutine MASK_MINI
C
C Create a mask where all the values inferior to MEAN(K) are set to 1.,
C and the other ones to 0., for MINI profiles.
C
C Input :
C MEAN : median value from MEDIAN_PROF2D
C
C*******************************************************************
	SUBROUTINE MASK_MINI(MASK1,ARRAY,IDIM)
	PARAMETER (IDIM1=2000)
	REAL*8 MEAN(IDIM1),RADFIRST(IDIM1),SIGMA(IDIM1)
	REAL*4 MASK1(IDIM,*),ARRAY(IDIM,*)
	INTEGER*4 NBER(IDIM1),NBFIRST(IDIM1)
	LOGICAL MASK_OUT,SECTOR,MEDIAN,MULT_SECT,NORMAL
	CHARACTER NAME1*40,COMMENTS1*160

	COMMON /PRF1_DATA/NX,NY,NAME1,COMMENTS1
	COMMON /PRF1_OPTIONS/MASK_OUT,SECTOR,MEDIAN,MULT_SECT
	COMMON /PRF1_PARAM/AXRATIO,PHI,X0,Y0,RADMIN1,RADMAX1,AMIN,AMAX,
     1	XINCREM,FACT,SCALE,SKY,NBINS,SIGREJEC,BADVALUE,ITERMAX,RVMAG
	COMMON /PRF1_RESULTS/MEAN,SIGMA,NBER,RADFIRST,NBFIRST
	COMMON /PRF1_UTILITIES/AXISMIN,AXISMAX,BB1,DD1,UU,VV,WW,
     1	IXMIN,IXMAX,IYMIN,IYMAX

C Logical name:
	NORMAL=(AMIN.LE.AMAX)

C Erasing the array:
        DO IY=1,NY
	  DO IX=1,NX
           MASK1(IX,IY)=0.
	  ENDDO
	ENDDO

C**********************************************************************
C Main loop :
C Scan only the working area since VAX initializes the arrays to 0
C when they are created :

	DO IY=IYMIN,IYMAX
	Y1=FLOAT(IY)-Y0

	DO IX=IXMIN,IXMAX
	  X1=FLOAT(IX)-X0

	  IF(ARRAY(IX,IY).EQ.BADVALUE) GO TO 2

C Check if the pixel lies within the angular limits of the sector :
	    IF (SECTOR) THEN
	     CALL ANGLED(X1,Y1,APOINT)
	     IF(NORMAL)THEN
	       IF((APOINT.LT.AMIN).OR.(APOINT.GT.AMAX)) GO TO 2
	     ELSE
	       IF((APOINT.LT.AMIN).AND.(APOINT.GT.AMAX)) GO TO 2
	     ENDIF
	    ENDIF

C F2: Semi major axis of the ellipse containing the current pixel (in arcsec)
	  F2=SCALE*SQRT(UU*X1*X1+VV*Y1*Y1+WW*X1*Y1)

C KBIN : Index of the profile bin corresponding to the current pixel
	  KBIN=1+INT(SQRT(BB1*BB1+DD1*(F2-AXISMIN))-BB1)

	    IF(KBIN.GE.1.AND.KBIN.LE.NBINS) THEN

C Set to 1. the points selected by MINI_PROF2D
	      IF(ARRAY(IX,IY).LE.MEAN(KBIN))MASK1(IX,IY)=1.
	    ENDIF

2	 END DO

	END DO

	RETURN
	END
C ******************************************************************
C Subroutine MEDIAN_PROF2D
C
C To compute the median value in each annuli (when RATIO is set to 0.5)
C
C Arrays :
C NBFIRST  : pixel number in each annulus
C NBER     : number of pixels kept in each annulus
C
C*******************************************************************
	SUBROUTINE MEDIAN_PROF2D(ARRAY,IDIM,PROF2D,NMAX,RATIO)
	PARAMETER (IDIM1=2000)
	REAL*4 PROF2D(NMAX,*),ARRAY(IDIM,*)
	REAL*8 MEAN(IDIM1),RADFIRST(IDIM1),SIGMA(IDIM1)
	REAL*8 SUM0
	INTEGER*4 NBER(IDIM1),NBFIRST(IDIM1),IHISTO(200)

	COMMON /PRF1_PARAM/AXRATIO,PHI,X0,Y0,RADMIN1,RADMAX1,AMIN,AMAX,
     1	XINCREM,FACT,SCALE,SKY,NBINS,SIGREJEC,BADVALUE,ITERMAX,RVMAG
	COMMON /PRF1_RESULTS/MEAN,SIGMA,NBER,RADFIRST,NBFIRST

C **********************************************************************
C Main loop on the radius index K :
C **********************************************************************

	DO K=1,NBINS

C Initialization:
	 XMIN0=320000.
	 XMAX0=-320000.

C Looks for the minimum value :
	   DO I=1,NBFIRST(K)
	     IF(PROF2D(I,K).NE.BADVALUE)THEN
                XMIN0=MIN(PROF2D(I,K),XMIN0)
                XMAX0=MAX(PROF2D(I,K),XMAX0)
	     ENDIF
	   END DO

C Return if only one value :
	IF(XMAX0.EQ.XMIN0)THEN
	MEAN(K)=XMIN0
	GO TO 2
	ENDIF

C Set up the increment for the histogram :
	NHISBINS=100
	FACTHIS=FLOAT(NHISBINS)/(XMAX0-XMIN0)

C Resets the histogram (IHISTO) :
	DO II=1,NHISBINS+2
	IHISTO(II)=0
	END DO

C Computes the histogram :
	NPTSHIS=0
	   DO I=1,NBFIRST(K)
	     IF(PROF2D(I,K).NE.BADVALUE)THEN
	      NPTSHIS=NPTSHIS+1
	      II=NINT((PROF2D(I,K)-XMIN0)*FACTHIS)+1
	      IHISTO(II)=IHISTO(II)+1
	     ENDIF
	   END DO
	NBER(K)=NPTSHIS

C Works out the median
C (i.e. looking for the middle column of the histogram (when RATIO=0.5))
	XNPTMAX=FLOAT(NBER(K))*RATIO
	SUM0=FLOAT(IHISTO(1))
	II=1
96	IF(SUM0.GE.XNPTMAX.OR.II.GE.NHISBINS) GOTO 97
	 II=II+1
	 SUM0=SUM0+FLOAT(IHISTO(II))
	GOTO 96

C Stores the result (median) in MEAN (although it is not the mean in that case)
97	MEAN(K)=XMIN0+FLOAT(II-1)/FACTHIS

2	END DO

	RETURN
	END
C-----------------------------------------------------------------
	include 'jlpsub:profile_set.for'


	SUBROUTINE TI_CTOI  ( dattim, idtarr, iret )
C************************************************************************
C* TI_CTOI								*
C*									*
C* This subroutine converts a standard GEMPAK time into an integer	*
C* array containing year, month, day, hour, and minute.  The input	*
C* string must be a complete GEMPAK date/time.  The integers are	*
C* checked for validity.  If YY is less than or equal to 20, 2000 is    *
C* added for the year; otherwise, 1900 is added.			*
C*									*
C* TI_CTOI  ( DATTIM, IDTARR, IRET )					*
C*									*
C* Input parameters:							*
C*	DATTIM		CHAR*		GEMPAK time			*
C*									*
C* Output parameters:							*
C*	IDTARR (5)	INTEGER		Time array (YYYY,MM,DD,HH,MM)	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = invalid time		*
C*					 -7 = invalid year		*
C*					 -8 = invalid month		*
C*					 -9 = invalid day		*
C*					-10 = invalid hour		*
C*					-11 = invalid minute		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	11/87	GEMPAK 4				*
C* M. desJardins/GSFC	 9/88	Fixed length of Feb in leap year	*
C* I. Durham/GSC	 9/98   Cleaned up				*
C* D. Kidwell/NCEP	 4/99   Changed to call TI_YY24; fixed prologue *
C* A. Hardy/GSC		 7/01   Added else check for dattim string	*
C************************************************************************
	CHARACTER*(*)	dattim
	INTEGER		idtarr (*)
C------------------------------------------------------------------------
	iret = 0
	DO  i = 1, 5
	    idtarr ( i ) = 0
	END DO
C
C*	Get length of input string.
C
	CALL ST_LSTR  ( dattim, length, ier )
C
	islash = INDEX ( dattim, '/' )
C
C*	Check for a valid dattim string.
C
	IF ( ( length .ge. 11 ) .and. ( islash .eq. 7 ) ) THEN
	   CALL ST_NUMB ( dattim (1:6),  idate, ierd )
	   CALL ST_NUMB ( dattim (8:11), itime, iert )
	ELSE IF ( ( length .ge. 13 ) .and. ( islash .eq. 9 ) ) THEN
	   CALL ST_NUMB ( dattim (1:8),   idate, ierd )
	   CALL ST_NUMB ( dattim (10:13), itime, iert )
	ELSE
           ierd = -1
           iert = -1
	END IF
C
C*	Check for error in decode.
C
	IF  ( ( ierd .ne. 0 ) .or. ( iert .ne. 0 ) )  THEN
	    iret = -1
	    RETURN
	END IF
C
C*	Check for negative values of date or time.
C
	IF  ( idate .lt. 0 )  THEN
	    iret = -7
	    RETURN
	END IF
	IF  ( itime .lt. 0 )  THEN
	    iret = -10
	    RETURN
	END IF
C
C*	Break date and time into year, month, day, hour and minute.
C
	iyear  = idate / 10000
	imonth = idate - iyear * 10000
	imonth = imonth / 100
	iday   = MOD ( idate, 100 )
	ihour  = itime / 100
	iminut = MOD ( itime, 100 )
C
C*	Change February in leap year.
C
	CALL TI_DAYM ( iyear, imonth, ndays, ier )
C
C*	Check that each of these values is valid.
C
	CALL TI_YY24 ( iyear, iyear, iret )
C
	IF  ( ( imonth .lt. 1 ) .or. ( imonth .gt. 12 ) ) iret = -8
	IF  ( ( iday   .lt. 1 ) .or. ( iday   .gt. ndays ) )
     +                                                    iret = -9
	IF  ( ( ihour  .lt. 0 ) .or. ( ihour  .gt. 24 ) ) iret = -10
	IF  ( ( iminut .lt. 0 ) .or. ( iminut .gt. 60 ) ) iret = -11
C
C*	Return values in array.
C
	IF  ( iret .eq. 0 )  THEN
	    idtarr (1) = iyear
	    idtarr (2) = imonth
	    idtarr (3) = iday
	    idtarr (4) = ihour
	    idtarr (5) = iminut
	END IF
C*
	RETURN
	END


* $Id$
C
C
C
	FUNCTION GAUSS3(F,A,B,EPS)
	EXTERNAL F
	DIMENSION W(12),X(12)
	DATA CONST/1.0E-12/
	DATA W/0.1012285,.2223810,.3137067,.3623838,.0271525,
     &         .0622535,0.0951585,.1246290,.1495960,.1691565,
     &         .1826034,.1894506/
	DATA X/0.9602899,.7966665,.5255324,.1834346,.9894009,
     &         .9445750,0.8656312,.7554044,.6178762,.4580168,
     &         .2816036,.0950125/
	SAVE
	DELTA=CONST*ABS(A-B)
	GAUSS3=0.0
	AA=A
5	Y=B-AA
	IF(ABS(Y).LE.DELTA) RETURN
2	BB=AA+Y
	C1=0.5*(AA+BB)
	C2=C1-AA
	S8=0.0
	S16=0.0
	DO 1 I=1,4
	U=X(I)*C2
1	S8=S8+W(I)*(F(C1+U)+F(C1-U))
	DO 3 I=5,12
	U=X(I)*C2
3	S16=S16+W(I)*(F(C1+U)+F(C1-U))
	S8=S8*C2
	S16=S16*C2
	IF(ABS(S16-S8).GT.EPS*(1.+ABS(S16))) GOTO 4
	GAUSS3=GAUSS3+S16
	AA=BB
	GOTO 5
4	Y=0.5*Y
	IF(ABS(Y).GT.DELTA) GOTO 2
	WRITE(6,7)
	GAUSS3=0.0
	RETURN
7	FORMAT(1X,'GAUSS3....TOO HIGH ACURACY REQUIRED')
	END


!----------------------------------------------------------------------------- best with 100 columns

!> gradient for FVM
module modGradient
  private

  ! constants
  integer,parameter::DIMS=3 !< dimensions

  !> generic finding gradient
  interface findGrad
    module procedure::findGradPolyVect
    module procedure::findGradPolyScal
    module procedure::findGradOtVect
    module procedure::findGradOtScal
  end interface
  public::findGrad

contains

  !> find gradient of vector v on polyFvGrid
  subroutine findGradPolyVect(grid,v,gradv)
    use modPolyFvGrid
    use modPolyGrid
    use modGeometry
    class(polyFvGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::v(:,:) !< input data
    double precision,allocatable,intent(inout)::gradv(:,:,:) !< gradient output
    logical::useCellOnly
    integer,parameter::MAX_N_NEAR=25
    integer,parameter::MAX_L_WORK=2000
    integer,parameter::L_IWORK=200
    integer::nNear,iNear(MAX_N_NEAR),lwork,iwork(L_IWORK),rank,ier
    double precision::dx(MAX_N_NEAR,DIMS),dv(MAX_N_NEAR,size(v,1)),stat(DIMS),work(MAX_L_WORK),rcond
    double precision::maxDv

    call grid%up()
    m=size(v,1) ! number of components
    ! handling non-cell elements
    useCellOnly=size(v,2)<grid%nE
    if(.not.allocated(gradv))then
      allocate(gradv(DIMS,m,grid%nC))
    end if
    ! find gradient
    !$omp parallel do default(shared)&
    !$omp& private(nNear,iNear,dx,dv,vF,lwork,work,iwork,stat,rcond,rank,ier,j,maxDv)
    do i=1,grid%nC
      ! process the list of nearby points
      nNear=0
      do j=1,size(grid%near,1)
        if(grid%near(j,i)>0.and.grid%near(j,i)<=merge(grid%nC,grid%nE,useCellOnly))then
          nNear=nNear+1
          iNear(nNear)=grid%near(j,i)
        else if(grid%near(j,i)==0)then
          exit
        end if
      end do
      ! LSQ method
      if(.not.useCellOnly)then ! use gradient mapping (constructed by DEGSDD)
        forall(j=1:nNear)
          dv(j,:)=v(:,iNear(j))-v(:,i)
        end forall
        gradv(1:DIMS,1:m,i)=matmul(grid%gradMap(1:DIMS,1:nNear,i),dv(1:nNear,1:m))
      else ! use DGELSD
        forall(j=1:nNear)
          dx(j,:)=grid%p(:,iNear(j))-grid%p(:,i)
          dv(j,:)=v(:,iNear(j))-v(:,i)
          dv(j,:)=dv(j,:)/dot_product(dx(j,:),dx(j,:))
          dx(j,:)=dx(j,:)/dot_product(dx(j,:),dx(j,:))
        end forall
        rcond=-1d0
        lwork=-1
        call DGELSD(nNear,DIMS,m,dx,MAX_N_NEAR,dv,MAX_N_NEAR,stat,rcond,rank,work,lwork,iwork,ier)
        lwork=min(MAX_L_WORK,int(work(1)))
        call DGELSD(nNear,DIMS,m,dx,MAX_N_NEAR,dv,MAX_N_NEAR,stat,rcond,rank,work,lwork,iwork,ier)
        gradv(:,:,i)=dv(1:DIMS,:)
      end if
      do j=1,m
        maxDv=maxval(abs(v(j,grid%neib(:,i))-v(j,i)),&
        &            mask=grid%neib(:,i)>0.and.grid%neib(:,i)<=merge(grid%nC,grid%nE,useCellOnly))
        gradv(:,j,i)=gradv(:,j,i)*min(1d0,maxDv/(norm2(gradv(:,j,i))*grid%v(i)**(1d0/3d0)))
      end do
    end do
    !$end omp parallel do
  end subroutine

  !> find gradient of scalar v on polyFvGrid
  subroutine findGradPolyScal(grid,v,gradv)
    use modPolyFvGrid
    class(polyFvGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::v(:) !< input data
    double precision,allocatable,intent(inout)::gradv(:,:) !< gradient output
    logical::useCellOnly
    integer,parameter::MAX_N_NEAR=25
    integer,parameter::MAX_L_WORK=2000
    integer,parameter::L_IWORK=200
    integer::nNear,iNear(MAX_N_NEAR),lwork,iwork(L_IWORK),rank,ier
    double precision::dx(MAX_N_NEAR,DIMS),dv(MAX_N_NEAR),stat(DIMS),work(MAX_L_WORK),rcond
    double precision::maxDv

    call grid%up()
    ! handling non-cell elements
    useCellOnly=size(v)<grid%nE
    if(.not.allocated(gradv))then
      allocate(gradv(DIMS,grid%nC))
    end if
    ! find gradient
    !$omp parallel do default(shared)&
    !$omp& private(nNear,iNear,dx,dv,vF,lwork,work,iwork,stat,rcond,rank,ier,j,maxDv)
    do i=1,grid%nC
      ! process the list of nearby points
      nNear=0
      do j=1,size(grid%near,1)
        if(grid%near(j,i)>0.and.grid%near(j,i)<=merge(grid%nC,grid%nE,useCellOnly))then
          nNear=nNear+1
          iNear(nNear)=grid%near(j,i)
        else if(grid%near(j,i)==0)then
          exit
        end if
      end do
      ! LSQ method
      if(.not.useCellOnly)then ! use gradient mapping (constructed by DEGSDD)
        forall(j=1:nNear)
          dv(j)=v(iNear(j))-v(i)
        end forall
        gradv(1:DIMS,i)=matmul(grid%gradMap(1:DIMS,1:nNear,i),dv(1:nNear))
      else ! use DGELSD
        forall(j=1:nNear)
          dx(j,:)=grid%p(:,iNear(j))-grid%p(:,i)
          dv(j)=v(iNear(j))-v(i)
          dv(j)=dv(j)/dot_product(dx(j,:),dx(j,:))
          dx(j,:)=dx(j,:)/dot_product(dx(j,:),dx(j,:))
        end forall
        rcond=-1d0
        lwork=-1
        call DGELSD(nNear,DIMS,1,dx,MAX_N_NEAR,dv,MAX_N_NEAR,stat,rcond,rank,work,lwork,iwork,ier)
        lwork=min(MAX_L_WORK,int(work(1)))
        call DGELSD(nNear,DIMS,1,dx,MAX_N_NEAR,dv,MAX_N_NEAR,stat,rcond,rank,work,lwork,iwork,ier)
        gradv(:,i)=dv(1:DIMS)
      end if
      maxDv=maxval(abs(v(grid%neib(:,i))-v(i)),&
      &            mask=grid%neib(:,i)>0.and.grid%neib(:,i)<=merge(grid%nC,grid%nE,useCellOnly))
      gradv(:,i)=gradv(:,i)*min(1d0,maxDv/(norm2(gradv(:,i))*grid%v(i)**(1d0/3d0)))
    end do
    !$end omp parallel do
  end subroutine

  !> find gradient of vector v on otGrid
  subroutine findGradOtVect(grid,v,gradv)
    use modOtGrid
    class(otGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::v(:,:) !< input data
    double precision,allocatable,intent(inout)::gradv(:,:,:) !< gradient output

    m=size(v,1) ! number of components
    if(.not.allocated(gradv))then
      allocate(gradv(DIMS,m,grid%nC))
    end if
    gradv(:,:,:)=0d0
    do i=1,grid%nC
      if(grid%flag(i)/=OT_OUT)then
        do l=1,DIMS
          if(grid%neib(l*2-1,i)>0.and.grid%neib(l*2,i)>0)then
            !TODO: different level?
            gradv(l,:,i)=(v(:,grid%neib(l*2,i))-v(:,grid%neib(l*2-1,i)))/2d0/grid%h(i)
          else if(grid%neib(l*2-1,i)>0)then
            !TODO: different level?
            gradv(l,:,i)=(v(:,i)-v(:,grid%neib(l*2-1,i)))/grid%h(i)
          else if(grid%neib(l*2,i)>0)then
            !TODO: different level?
            gradv(l,:,i)=(v(:,grid%neib(l*2,i))-v(:,i))/grid%h(i)
          end if
        end do
      end if
    end do
  end subroutine

  !> find gradient of scalar v on otGrid
  subroutine findGradOtScal(grid,v,gradv)
    use modOtGrid
    class(otGrid),intent(inout)::grid !< the grid
    double precision,intent(in)::v(:) !< input data
    double precision,allocatable,intent(inout)::gradv(:,:) !< gradient output
    double precision,allocatable::vv(:,:),gradvv(:,:,:)

    allocate(vv(1,size(v)))
    if(allocated(gradv))then
      allocate(gradvv(DIMS,1,size(gradv,2)))
    end if
    vv(1,:)=v(:)
    call findGradOtVect(grid,vv,gradvv)
    if(.not.allocated(gradv))then
      allocate(gradv(DIMS,size(gradvv,3)),source=gradvv(:,1,:))!FIXME:remove work-around
    else
      gradv(:,:)=gradvv(:,1,:)
    end if
    deallocate(vv)
    deallocate(gradvv)
  end subroutine

end module


module tensor
use types
use outerprod
use utils, only: unit_matrix
use randomm, only: gasdev
use ieee_arithmetic, only: ieee_is_nan

implicit none
private
public ih

contains

    subroutine ih(rpos, k, mat_a, R)
        ! Varibles de entrada y salida
        integer, intent(in) :: k   ! numero de submatrices (particulas)
        real(dp), intent(in) :: rpos(:,:)
        real(dp), intent(out) :: R(:)
        real(dp), intent(out) :: mat_a(:, :)

        ! Variables locales
        integer, parameter :: n = 3 !la dimension de la matriz (x,y,z)
        integer :: s
        real(dp) :: Dij(n, n)
        real(dp) :: part1(n)
        real(dp) :: part2(n)
        real(dp) :: ident(n, n)
        real(dp), allocatable :: Xr(:)
        integer :: ix, ij, pos, il   ! indices
        real(dp), allocatable :: sigma(:,:)

        ! Tamaño total de elementos, partícula por cada dimensión espacial
        s = n*k
        allocate( sigma(s,s), Xr(s) )

        ! Inicialización de los arreglos
        call unit_matrix( ident )
        R = 0.0_dp
        Xr = 0.0_dp
        mat_a = 0.0_dp
        Dij = 0.0_dp

        ! Distribucion normal estándar
        do ix = 1,s
            Xr(ix) = gasdev()
        end do

        ! Hacer una matriz identidad a bloques
        do ix = 1, s, n
            mat_a(ix:ix+n-1,ix:ix+n-1) = ident
        end do

        do ix = 1, k
            il = (ix * n) - n + 1
            do ij = ix+1, k
                pos = (ij*n) - n + 1

                part1 = rpos(:, ix)
                part2 = rpos(:, ij)

                call matrizDij( part1,part2,Dij,n )

                mat_a(il:il+n-1,pos:pos+n-1) = Dij
                mat_a(pos:pos+n-1,il:il+n-1) = Dij
            end do
        end do

        ! Se añade un pequeño valor para hacer a la matriz
        ! estable numéricamente
        sigma = mat_a + 0.00001_dp
        !! # Se escoge cualquiera de los dos
        ! call cholesky_method( sigma,s,Xr,R )
        call krylov_method( sigma,s,Xr,R )

        ! Liberar memoria
        deallocate( sigma,Xr )
    end subroutine ih

    subroutine matrizDij(part1, part2, Dij, n)
        ! Variables de entrada y salida
        integer, intent(in) :: n
        real(dp), intent(in) :: part1(:)
        real(dp), intent(in) :: part2(:)
        real(dp), intent(out) :: Dij(:,:)

        ! Variables locales
        real(dp) :: rij,sqrddist,xij,yij,zij
        real(dp) :: ident(n, n), prodout(n, n)
        real(dp) :: temp(n)
        real(dp), external :: dnrm2 ! Norma euclidiana de BLAS

        ! Calcular las distancias
        xij = part1(1) - part2(1)
        yij = part1(2) - part2(2)
        zij = part1(3) - part2(3)
        ! rij = xij**2 + yij**2 + zij**2
        temp = [xij, yij, zij]
        sqrddist = dnrm2( 3,temp,1 )
        rij = sqrddist ** 2

        ! calculando Dij
        Dij = 0.0_dp
        prodout = 0.0_dp

        call unit_matrix( ident )

        if (sqrddist >= 1.0_dp) then
            prodout = outerprod_d( temp, temp ) / rij
            Dij = ident + prodout

            Dij = Dij + ( (ident/3.0_dp) - prodout )/(2.0_dp*rij)

            Dij = 3.0_dp*Dij/(8.0_dp*sqrddist)
        else
            Dij = (1.0_dp-(9.0_dp*sqrddist/16.0_dp))*ident
            Dij = Dij + 3.0_dp*outerprod_d( temp, temp )/(16.0_dp*sqrddist)
        end if
    end subroutine matrizDij

    subroutine cholesky_method(sigma,s,xr,r)
        !  Variables de entrada
        real(dp), intent(in) :: sigma(:,:),xr(:)
        real(dp), intent(inout) :: r(:)
        integer, intent(in) :: s

        ! Variables locales
        integer :: info
        character(1) :: uplo
        real(dp), allocatable :: temp(:,:)
        allocate( temp(s,s) )

        ! Descomposición de Cholesky
        uplo = 'L'
        call dpotrf( uplo,s,sigma,s,info )
        if ( info .ne. 0 ) print*, "No se puede descomponer"
        ! Copiar la descomposición a una matriz nueva
        call dlacpy( uplo, s, s, sigma, s, temp, s )
        ! Multiplicar L*Xr para obtener el vector de números aleatorios
        call dgemv( 'n',s,s,1.0_dp,temp,s,Xr,1,0.0_dp,R,1 )

        deallocate(temp)
    end subroutine cholesky_method

    subroutine krylov_method(sigma,s,xr,r)
        !  Variables de entrada
        real(dp), intent(in) :: sigma(:,:),xr(:)
        real(dp), intent(inout) :: r(:)
        integer, intent(in) :: s
        ! Variables locales
        real(dp), allocatable :: w(:),eid(:),v(:),res(:)
        real(dp), allocatable :: temp(:,:),vm(:,:),h(:,:)
        integer :: n, m, i, k
        real(dp), external :: dnrm2,ddot ! Operaciones de BLAS
        real(dp) :: znorm, dump

        if ( (size(r) .ne. s) .or. (size(Xr) .ne. s) ) stop 'Tamaños incorrectos'

        ! Inicializar arreglos
        m = 50 ! Número de pasos de Lanczos
        allocate( vm(s,m),h(m,m),w(s),eid(m) )
        allocate( temp(m,m),v(m),res(s) )
        vm(:,:) = 0.0_dp
        h(:,:) = 0.0_dp
        w(:) = 0.0_dp
        v(:) = 0.0_dp
        r(:) = 0.0_dp
        res(:) = 0.0_dp
        temp(:,:) = 0.0_dp
        ! eid es el primer vector de la matrix identidad
        eid(:) = 0.0_dp
        eid(1) = 1.0_dp

        ! Calcular el primer vector base
        znorm = dnrm2( s,xr,1 )
        vm(:,1) = xr / znorm
        ! Comienzan las iteraciones de Lanczos
        do i = 1,m
            call dgemv( 'n',s,s,1.0_dp,sigma,s,vm(:,i),1,0.0_dp,w,1 )
            if ( i > 1 ) then
                w = w - ( h(i-1,i) * vm(:,i-1) )
            end if
            k = size(w, 1)
            h(i,i) = ddot( k,w,1,vm(:,i),1 )
            if ( i < m ) then
                w = w - ( h(i,i) * vm(:,i) )
                k = size(w, 1)
                h(i+1,i) = dnrm2( k,w,1 )
                h(i,i+1) = h(i+1,i)
                vm(:,i+1) = w / h(i+1,i)
            end if
        end do
        call sqrt_matrix( h,temp )
        call dgemv( 'N',m,m,1.0_dp,temp,m,eid,1,0.0_dp,v,1 )
        call dgemv( 'N',s,m,1.0_dp,vm,s,v,1,0.0_dp,res,1 )
        r = znorm * res

        ! Se libera la memoria
        deallocate( v,vm,h,w,temp,eid,res )
    end subroutine krylov_method

    subroutine sqrt_matrix(a,b)
        ! Variables de entrada
        real(dp), intent(in) :: a(:,:)
        real(dp), intent(out) :: b(:,:)
        ! Variables locales
        integer :: lda,n,i,nb,info,lwork
        real(dp), allocatable :: w(:),work(:)
        real(dp), allocatable :: diagw(:,:),temp(:,:)

        lda = size(a, 1)
        n = size(a, 2)
        nb = 64
        lwork = nb * n
        allocate( w(lda),diagw(lda,n),work(lwork) )
        allocate( temp(lda,n) )
        diagw = 0.0_dp
        b = 0.0_dp
        w = 0.0_dp
        work = 0.0_dp

        ! Copiar los datos de `a` en `b`
        call dlacpy( 'All',lda,n,a,lda,b,lda )

        ! Descomposición espectral de `b`
        call dsyev( 'V','U',n,b,lda,w,work,lwork,info )
        if (info .ne. 0) stop 'No se pudo descomponer espectralmente'

        ! Construir la matriz diagonal, habiendo calculado la raíz cuadrada
        w = dsqrt(w)
        forall ( i = 1:lda ) diagw(i,i) = w(i)

        ! Reconstruir la matriz
        ! Primero, Lambda * U**T
        call dgemm( 'N','T',lda,n,n,1.0_dp,diagw,lda,b,lda,0.0_dp,temp,lda )
        ! Luego, U * temp = U * (Lambda * U**T)
        call dgemm ( 'N','N',lda,n,n,1.0_dp,b,lda,temp,lda,0.0_dp,b,lda )

        ! Liberar la memoria
        deallocate( w,diagw,work,temp )
    end subroutine sqrt_matrix
end module tensor


      SUBROUTINE DLAR1V( N, B1, BN, SIGMA, D, L, LD, LLD, GERSCH, Z,
     $                   ZTZ, MINGMA, R, ISUPPZ, WORK )
*
*  -- LAPACK auxiliary routine (instru to count ops, version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      INTEGER            B1, BN, N, R
      DOUBLE PRECISION   MINGMA, SIGMA, ZTZ
*     ..
*     .. Array Arguments ..
      INTEGER            ISUPPZ( * )
      DOUBLE PRECISION   D( * ), GERSCH( * ), L( * ), LD( * ), LLD( * ),
     $                   WORK( * ), Z( * )
*     ..
*     Common block to return operation count
*     .. Common blocks ..
      COMMON             / LATIME / OPS, ITCNT
*     ..
*     .. Scalars in Common ..
      DOUBLE PRECISION   ITCNT, OPS
*     ..
*
*  Purpose
*  =======
*
*  DLAR1V computes the (scaled) r-th column of the inverse of
*  the sumbmatrix in rows B1 through BN of the tridiagonal matrix
*  L D L^T - sigma I. The following steps accomplish this computation :
*  (a) Stationary qd transform,  L D L^T - sigma I = L(+) D(+) L(+)^T,
*  (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
*  (c) Computation of the diagonal elements of the inverse of
*      L D L^T - sigma I by combining the above transforms, and choosing
*      r as the index where the diagonal of the inverse is (one of the)
*      largest in magnitude.
*  (d) Computation of the (scaled) r-th column of the inverse using the
*      twisted factorization obtained by combining the top part of the
*      the stationary and the bottom part of the progressive transform.
*
*  Arguments
*  =========
*
*  N        (input) INTEGER
*           The order of the matrix L D L^T.
*
*  B1       (input) INTEGER
*           First index of the submatrix of L D L^T.
*
*  BN       (input) INTEGER
*           Last index of the submatrix of L D L^T.
*
*  SIGMA    (input) DOUBLE PRECISION
*           The shift. Initially, when R = 0, SIGMA should be a good
*           approximation to an eigenvalue of L D L^T.
*
*  L        (input) DOUBLE PRECISION array, dimension (N-1)
*           The (n-1) subdiagonal elements of the unit bidiagonal matrix
*           L, in elements 1 to N-1.
*
*  D        (input) DOUBLE PRECISION array, dimension (N)
*           The n diagonal elements of the diagonal matrix D.
*
*  LD       (input) DOUBLE PRECISION array, dimension (N-1)
*           The n-1 elements L(i)*D(i).
*
*  LLD      (input) DOUBLE PRECISION array, dimension (N-1)
*           The n-1 elements L(i)*L(i)*D(i).
*
*  GERSCH   (input) DOUBLE PRECISION array, dimension (2*N)
*           The n Gerschgorin intervals. These are used to restrict
*           the initial search for R, when R is input as 0.
*
*  Z        (output) DOUBLE PRECISION array, dimension (N)
*           The (scaled) r-th column of the inverse. Z(R) is returned
*           to be 1.
*
*  ZTZ      (output) DOUBLE PRECISION
*           The square of the norm of Z.
*
*  MINGMA   (output) DOUBLE PRECISION
*           The reciprocal of the largest (in magnitude) diagonal
*           element of the inverse of L D L^T - sigma I.
*
*  R        (input/output) INTEGER
*           Initially, R should be input to be 0 and is then output as
*           the index where the diagonal element of the inverse is
*           largest in magnitude. In later iterations, this same value
*           of R should be input.
*
*  ISUPPZ   (output) INTEGER array, dimension (2)
*           The support of the vector in Z, i.e., the vector Z is
*           nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
*
*  WORK     (workspace) DOUBLE PRECISION array, dimension (4*N)
*
*  Further Details
*  ===============
*
*  Based on contributions by
*     Inderjit Dhillon, IBM Almaden, USA
*     Osni Marques, LBNL/NERSC, USA
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            BLKSIZ
      PARAMETER          ( BLKSIZ = 32 )
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            SAWNAN
      INTEGER            FROM, I, INDP, INDS, INDUMN, J, R1, R2, TO
      DOUBLE PRECISION   DMINUS, DPLUS, EPS, S, TMP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH
      EXTERNAL           DLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX, MIN
*     ..
*     .. Executable Statements ..
*
      EPS = DLAMCH( 'Precision' )
      IF( R.EQ.0 ) THEN
*
*        Eliminate the top and bottom indices from the possible values
*        of R where the desired eigenvector is largest in magnitude.
*
         R1 = B1
         DO 10 I = B1, BN
            IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
     $           THEN
               R1 = I
               GO TO 20
            END IF
   10    CONTINUE
   20    CONTINUE
         R2 = BN
         DO 30 I = BN, B1, -1
            IF( SIGMA.GE.GERSCH( 2*I-1 ) .OR. SIGMA.LE.GERSCH( 2*I ) )
     $           THEN
               R2 = I
               GO TO 40
            END IF
   30    CONTINUE
   40    CONTINUE
      ELSE
         R1 = R
         R2 = R
      END IF
*
      INDUMN = N
      INDS = 2*N + 1
      INDP = 3*N + 1
      SAWNAN = .FALSE.
*
*     Compute the stationary transform (using the differential form)
*     untill the index R2
*
      IF( B1.EQ.1 ) THEN
         WORK( INDS ) = ZERO
      ELSE
         WORK( INDS ) = LLD( B1-1 )
      END IF
      OPS = OPS + DBLE( 1 )
      S = WORK( INDS ) - SIGMA
      DO 50 I = B1, R2 - 1
         OPS = OPS + DBLE( 5 )
         DPLUS = D( I ) + S
         WORK( I ) = LD( I ) / DPLUS
         WORK( INDS+I ) = S*WORK( I )*L( I )
         S = WORK( INDS+I ) - SIGMA
   50 CONTINUE
*
      IF( .NOT.( S.GT.ZERO .OR. S.LT.ONE ) ) THEN
*
*        Run a slower version of the above loop if a NaN is detected
*
         SAWNAN = .TRUE.
         J = B1 + 1
   60    CONTINUE
         IF( WORK( INDS+J ).GT.ZERO .OR. WORK( INDS+J ).LT.ONE ) THEN
            J = J + 1
            GO TO 60
         END IF
         WORK( INDS+J ) = LLD( J )
         S = WORK( INDS+J ) - SIGMA
         DO 70 I = J + 1, R2 - 1
            OPS = OPS + DBLE( 3 )
            DPLUS = D( I ) + S
            WORK( I ) = LD( I ) / DPLUS
            IF( WORK( I ).EQ.ZERO ) THEN
               WORK( INDS+I ) = LLD( I )
            ELSE
               OPS = OPS + DBLE( 2 )
               WORK( INDS+I ) = S*WORK( I )*L( I )
            END IF
            S = WORK( INDS+I ) - SIGMA
   70    CONTINUE
      END IF
      OPS = OPS + DBLE( 1 )
      WORK( INDP+BN-1 ) = D( BN ) - SIGMA
      DO 80 I = BN - 1, R1, -1
         OPS = OPS + DBLE( 5 )
         DMINUS = LLD( I ) + WORK( INDP+I )
         TMP = D( I ) / DMINUS
         WORK( INDUMN+I ) = L( I )*TMP
         WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
   80 CONTINUE
      TMP = WORK( INDP+R1-1 )
      IF( .NOT.( TMP.GT.ZERO .OR. TMP.LT.ONE ) ) THEN
*
*        Run a slower version of the above loop if a NaN is detected
*
         SAWNAN = .TRUE.
         J = BN - 3
   90    CONTINUE
         IF( WORK( INDP+J ).GT.ZERO .OR. WORK( INDP+J ).LT.ONE ) THEN
            J = J - 1
            GO TO 90
         END IF
         OPS = OPS + DBLE( 1 )
         WORK( INDP+J ) = D( J+1 ) - SIGMA
         DO 100 I = J, R1, -1
            OPS = OPS + DBLE( 3 )
            DMINUS = LLD( I ) + WORK( INDP+I )
            TMP = D( I ) / DMINUS
            WORK( INDUMN+I ) = L( I )*TMP
            IF( TMP.EQ.ZERO ) THEN
               OPS = OPS + DBLE( 1 )
               WORK( INDP+I-1 ) = D( I ) - SIGMA
            ELSE
               OPS = OPS + DBLE( 2 )
               WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - SIGMA
            END IF
  100    CONTINUE
      END IF
*
*     Find the index (from R1 to R2) of the largest (in magnitude)
*     diagonal element of the inverse
*
      MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
      IF( MINGMA.EQ.ZERO )
     $   MINGMA = EPS*WORK( INDS+R1-1 )
      R = R1
      DO 110 I = R1, R2 - 1
         OPS = OPS + DBLE( 1 )
         TMP = WORK( INDS+I ) + WORK( INDP+I )
         IF( TMP.EQ.ZERO ) THEN
            OPS = OPS + DBLE( 1 )
            TMP = EPS*WORK( INDS+I )
         END IF
         IF( ABS( TMP ).LT.ABS( MINGMA ) ) THEN
            MINGMA = TMP
            R = I + 1
         END IF
  110 CONTINUE
*
*     Compute the (scaled) r-th column of the inverse
*
      ISUPPZ( 1 ) = B1
      ISUPPZ( 2 ) = BN
      Z( R ) = ONE
      ZTZ = ONE
      IF( .NOT.SAWNAN ) THEN
         FROM = R - 1
         TO = MAX( R-BLKSIZ, B1 )
  120    CONTINUE
         IF( FROM.GE.B1 ) THEN
            DO 130 I = FROM, TO, -1
               OPS = OPS + DBLE( 3 )
               Z( I ) = -( WORK( I )*Z( I+1 ) )
               ZTZ = ZTZ + Z( I )*Z( I )
  130       CONTINUE
            IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO+1 ) ).LE.EPS )
     $           THEN
               ISUPPZ( 1 ) = TO + 2
            ELSE
               FROM = TO - 1
               TO = MAX( TO-BLKSIZ, B1 )
               GO TO 120
            END IF
         END IF
         FROM = R + 1
         TO = MIN( R+BLKSIZ, BN )
  140    CONTINUE
         IF( FROM.LE.BN ) THEN
            DO 150 I = FROM, TO
               OPS = OPS + DBLE( 3 )
               Z( I ) = -( WORK( INDUMN+I-1 )*Z( I-1 ) )
               ZTZ = ZTZ + Z( I )*Z( I )
  150       CONTINUE
            IF( ABS( Z( TO ) ).LE.EPS .AND. ABS( Z( TO-1 ) ).LE.EPS )
     $           THEN
               ISUPPZ( 2 ) = TO - 2
            ELSE
               FROM = TO + 1
               TO = MIN( TO+BLKSIZ, BN )
               GO TO 140
            END IF
         END IF
      ELSE
         DO 160 I = R - 1, B1, -1
            IF( Z( I+1 ).EQ.ZERO ) THEN
               OPS = OPS + DBLE( 2 )
               Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
            ELSE IF( ABS( Z( I+1 ) ).LE.EPS .AND. ABS( Z( I+2 ) ).LE.
     $               EPS ) THEN
               ISUPPZ( 1 ) = I + 3
               GO TO 170
            ELSE
               OPS = OPS + DBLE( 1 )
               Z( I ) = -( WORK( I )*Z( I+1 ) )
            END IF
            OPS = OPS + DBLE( 2 )
            ZTZ = ZTZ + Z( I )*Z( I )
  160    CONTINUE
  170    CONTINUE
         DO 180 I = R, BN - 1
            IF( Z( I ).EQ.ZERO ) THEN
               OPS = OPS + DBLE( 2 )
               Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
            ELSE IF( ABS( Z( I ) ).LE.EPS .AND. ABS( Z( I-1 ) ).LE.EPS )
     $                THEN
               ISUPPZ( 2 ) = I - 2
               GO TO 190
            ELSE
               OPS = OPS + DBLE( 1 )
               Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
            END IF
            OPS = OPS + DBLE( 2 )
            ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
  180    CONTINUE
  190    CONTINUE
      END IF
      DO 200 I = B1, ISUPPZ( 1 ) - 3
         Z( I ) = ZERO
  200 CONTINUE
      DO 210 I = ISUPPZ( 2 ) + 3, BN
         Z( I ) = ZERO
  210 CONTINUE
*
      RETURN
*
*     End of DLAR1V
*
      END


        subroutine refcof (a0, b0, d1,e1,t1, t2, t3, t4)
c
        c1 = e1 - b0 * b0
        c11 = sqrt(c1 * c1 + d1 * d1)
        e2 = sqrt(abs(c1 + c11) / 2.0)
        f2 = sqrt(abs(-c1 + c11) / 2.0)
        rk1 = e1 * a0 - e2
        rl1 = rk1 + e2 * 2
        rm1 = d1 * a0 - f2
        rn1 = rm1 + f2 * 2
        rl1n = rl1 * rl1 + rn1 * rn1
        t1 = (rk1 * rl1 + rm1 * rn1) / rl1n
        t2 = (rk1 * rn1 - rm1 * rl1) / rl1n
        g1 = a0 - e2
        h2 = a0 + e2
        hn = h2 * h2 + f2 * f2
        t3 = (g1 * h2 - f2 * f2) / hn
        t4 = (h2 * f2 + g1 * f2) / hn
        return
        end
c--------------------------------------------------------------------


  ! Index of velocity nodes
  i1 = i - sgnvz
  j1 = j - sgnvx
  k1 = k - sgnvy

  ! Get local times of surrounding points
  tv = tt(i-sgntz,j,k)
  te = tt(i,j-sgntx,k)
  tn = tt(i,j,k-sgnty)
  tev = tt(i-sgntz,j-sgntx,k)
  ten = tt(i,j-sgntx,k-sgnty)
  tnv = tt(i-sgntz,j,k-sgnty)
  tnve = tt(i-sgntz,j-sgntx,k-sgnty)

  ! 1D operators (refracted times)
  vref = min( slow(i1,max(j-1,1),max(k-1,1)), slow(i1,max(j-1,1),min(k,ny-1)), &
              slow(i1,min(j,nx-1),max(k-1,1)), slow(i1,min(j,nx-1),min(k,ny-1)) )
  t1d1 = tv + dz * vref                   ! First dimension (Z axis)
  vref = min( slow(max(i-1,1),j1,max(k-1,1)), slow(min(i,nz-1),j1,max(k-1,1)), &
              slow(max(i-1,1),j1,min(k,ny-1)), slow(min(i,nz-1),j1,min(k,ny-1)) )
  t1d2 = te + dx * vref                   ! Second dimension (X axis)
  vref = min( slow(max(i-1,1),max(j-1,1),k1), slow(max(i-1,1),min(j,nx-1),k1), &
              slow(min(i,nz-1),max(j-1,1),k1), slow(min(i,nz-1),min(j,nx-1),k1) )
  t1d3 = tn + dy * vref                   ! Third dimension (Y axis)
  t1d = min(t1d1, t1d2, t1d3)

  ! 2D operators
  ! ZX plane
  t2d1 = Big
  vref = min( slow(i1,j1,max(k-1,1)), slow(i1,j1,min(k,ny-1)) )
  if ( ( tv .lt. te + dx*vref ) .and. ( te .lt. tv + dz*vref ) ) then
    ta = tev + te - tv
    tb = tev - te + tv
    t2d1 = ( ( tb * dz2i + ta * dx2i ) + sqrt( 4.d0 * vref*vref * ( dz2i + dx2i ) &
           - dz2i * dx2i * ( ta - tb ) * ( ta - tb ) ) ) / ( dz2i + dx2i )
  end if

  ! ZY plane
  t2d2 = Big
  vref = min( slow(i1,max(j-1,1),k1), slow(i1,min(j,nx-1),k1) )
  if ( ( tv .lt. tn + dy*vref ) .and. ( tn .lt. tv + dz*vref ) ) then
    ta = tv - tn + tnv
    tb = tn - tv + tnv
    t2d2 = ( ( ta * dz2i + tb * dy2i ) + sqrt( 4.d0 * vref*vref * ( dz2i + dy2i ) &
           - dz2i * dy2i * ( ta - tb ) * ( ta - tb ) ) ) / ( dz2i + dy2i )
  end if

  ! XY plane
  t2d3 = Big
  vref = min( slow(max(i-1,1),j1,k1), slow(min(i,nz-1),j1,k1) )
  if ( ( te .lt. tn + dy*vref ) .and. ( tn .lt. te + dx*vref ) ) then
    ta = te - tn + ten
    tb = tn - te + ten
    t2d3 = ( ( ta * dx2i + tb * dy2i ) + sqrt( 4.d0 * vref*vref * ( dx2i + dy2i ) &
           - dx2i * dy2i * ( ta - tb ) * ( ta - tb ) ) ) / ( dx2i + dy2i )
  end if

  t2d = min(t2d1, t2d2, t2d3)

  ! 3D operator
  t3d = Big
  vref = slow(i1,j1,k1)
  ta = te - 0.5d0 * tn + 0.5d0 * ten - 0.5d0 * tv + 0.5d0 * tev - tnv + tnve
  tb = tv - 0.5d0 * tn + 0.5d0 * tnv - 0.5d0 * te + 0.5d0 * tev - ten + tnve
  tc = tn - 0.5d0 * te + 0.5d0 * ten - 0.5d0 * tv + 0.5d0 * tnv - tev + tnve
  if ( min(t1d, t2d) .gt. max(tv, te, tn) ) then
    t2 = vref*vref * dsum * 9.d0
    t3 = dz2dx2 * ( ta - tb ) * ( ta - tb ) &
       + dz2dy2 * ( tb - tc ) * ( tb - tc ) &
       + dx2dy2 * ( ta - tc ) * ( ta - tc )
    if ( t2 .ge. t3 ) then
      t1 = tb * dz2i + ta * dx2i + tc * dy2i
      t3d = ( t1 + sqrt( t2 - t3 ) ) / dsum
    end if
  end if

  ! Select minimum time
  time_sol = [ tt(i,j,k), t1d1, t1d2, t1d3, t2d1, t2d2, t2d3, t3d ]
  imin = minloc(time_sol, dim = 1)
  tt(i,j,k) = time_sol(imin)

  ! Compute gradient according to minimum time direction
  if ( present(ttgrad) ) then
    select case(imin)
    case(2)
      ttz(i,j,k) = sgntz * (tt(i,j,k)-tv) / dz
      ttx(i,j,k) = 0.d0
      tty(i,j,k) = 0.d0
    case(3)
      ttz(i,j,k) = 0.d0
      ttx(i,j,k) = sgntx * (tt(i,j,k)-te) / dx
      tty(i,j,k) = 0.d0
    case(4)
      ttz(i,j,k) = 0.d0
      ttx(i,j,k) = 0.d0
      tty(i,j,k) = sgnty * (tt(i,j,k)-tn) / dy
    case(5)
      ttz(i,j,k) = sgntz * (tt(i,j,k)-tv) / dz
      ttx(i,j,k) = sgntx * (tt(i,j,k)-te) / dx
      tty(i,j,k) = 0.d0
    case(6)
      ttz(i,j,k) = sgntz * (tt(i,j,k)-tv) / dz
      ttx(i,j,k) = 0.d0
      tty(i,j,k) = sgnty * (tt(i,j,k)-tn) / dy
    case(7)
      ttz(i,j,k) = 0.d0
      ttx(i,j,k) = sgntx * (tt(i,j,k)-te) / dx
      tty(i,j,k) = sgnty * (tt(i,j,k)-tn) / dy
    case(8)
      ttz(i,j,k) = sgntz * (tt(i,j,k)-tv) / dz
      ttx(i,j,k) = sgntx * (tt(i,j,k)-te) / dx
      tty(i,j,k) = sgnty * (tt(i,j,k)-tn) / dy
    end select
  end if


! Module that exposes all the necessary constants, parameters and variable definitions

module mod_constants
  implicit none

  integer, parameter, public :: x_precision  = selected_real_kind(15) ! Numerical precision
  integer, parameter, public :: n_cell       = 256                    ! Number of cells along the disk radius
  ! Specific to main program
  integer, parameter, public :: n_iterations = 200000000              ! Number of iterations to run
  integer, parameter, public :: output_freq  = 8000                   ! Frequency of the outputs
  integer, parameter, public :: mean_size    = 100                    ! When doing means for S evolution, length of the history
  real(x_precision), parameter, public :: cst_dt_nu = 100._x_precision
  real(x_precision), parameter, public :: cst_dt_T  = 1000._x_precision
  ! Specific to s_curve
  integer,           parameter, public :: nb_it  = 1000              ! Number of points for the S curve
  integer,           parameter, public :: max_it = 10000000          ! Maximum number of s_curve dichotomy iterations
  real(x_precision), parameter, public :: eps    = 1.e-6_x_precision ! Precision required for the dichotomy
  real(x_precision), parameter, public :: Tmin   = 10._x_precision**5.3_x_precision
  real(x_precision), parameter, public :: Tmax   = 10._x_precision**7.4_x_precision
  real(x_precision), parameter, public :: Smin   = 10._x_precision**1.0_x_precision
  real(x_precision), parameter, public :: Smax   = 10._x_precision**3.5_x_precision

  ! Physical constants
  real(x_precision), parameter, public :: G       = 6.67408e-8_x_precision ! Gravitationnal cst in cgs
  real(x_precision), parameter, public :: c       = 2.99792458e10_x_precision ! Speed of light in cgs
  real(x_precision), parameter, public :: pi      = 4.0_x_precision*atan(1.0_x_precision)
  real(x_precision), parameter, public :: M_sun   = 1.98855e33_x_precision ! Mass of the sun in cgs
  real(x_precision), parameter, public :: cst_rad = 7.5657308531642009e-15_x_precision ! Radiation cst in cgs
  real(x_precision), parameter, public :: stefan  = (c * cst_rad) / 4.0_x_precision ! Stefan cst in cgs
  real(x_precision), parameter, public :: kb      = 1.3806488e-16_x_precision ! Boltzmann cst in cgs
  real(x_precision), parameter, public :: R       = 8.3144598e7_x_precision ! Gas cst in csg = Boltzmann cst over proton mass
  real(x_precision), parameter, public :: gammag  = 5._x_precision / 3._x_precision ! Adiabatic coefficient
  real(x_precision), parameter, public :: thomson = 6.6524587158e-25_x_precision ! Thomson cross-section in cgs

  type parameters
    real(x_precision) :: M, Mdot, Mdot_crit, kappa_e, RTM, alpha, dx, t_nu, t_T
    ! M         : Black hole Mass
    ! Mdot      : Acretion rate at rmax
    ! Mdot_crit : Critical accretion rate
    ! kappa_e   : Thomson scattering thickness
    ! RTM       : Gas constant × T_0 ÷ μ
    ! alpha     : Viscosity parameter
    ! dx        : Dimensionless spacestep
    ! t_nu      : Viscous time
    ! t_T       : Thermal time
  end type parameters

  type state
    real(x_precision), dimension(n_cell) :: nu, v, cs, S, H, Mdot, rho, T, Fz, Cv, Pgaz, Prad, beta, Qplus, Qminus, tau, Qadv
    ! nu     : Viscosity
    ! v      : Local, radial accretion speed
    ! cs     : Speed of sound
    ! S      : Variable of density
    ! H      : Disk half-height
    ! Mdot   : Accretion rate
    ! rho    : Volume density
    ! T      : Temperature
    ! Fz     : Radiative flux
    ! Cv     : Heat capacity at constant volume
    ! Pgaz   : Gaz pressure
    ! Prad   : Radiative pressure
    ! beta   : Pressure indicator
    ! Qplus  : Heating term
    ! Qminus : Cooling term
    ! tau    : Opacity
    ! Qadv   : Advection term
  end type state

  type dim_state
    real(x_precision), dimension(n_cell) :: r, Omega_r
    ! r       : Space variable
    ! Omega_r : Angular velocity
  end type dim_state

  type adim_state
    real(x_precision), dimension(n_cell) :: x, Omega
    ! x     : Space variable
    ! Omega : Angular velocity
  end type adim_state

  type state_zero
    real(x_precision) :: temps_0, Omega_0, nu_0, v_0, cs_0, S_0, H_0, Mdot_0, rho_0, T_0, Fz_0, Cv_0, Pgaz_0, Prad_0, beta_0, Q_0
    ! Usefull quantities to get the dimensionless ones
  end type state_zero

  type state_ic
     real(x_precision), dimension(n_cell) :: T, Sigma, H
     ! T     : Initial condition for Temperature
     ! Sigma : Initial condition for Sigma
     ! H     : Initial condition for H (for comparison only)
  end type state_ic

contains

end module mod_constants


!
! gr.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
module gr
use precision, pr=>dp

implicit none
integer                         :: nhis, switch
integer, allocatable            :: g(:)
real(pr)                        :: box

contains

subroutine gr(switch)
integer                         :: i, j, k
integer                         :: ngr
real(pr)                        :: delg

    if (switch==0) then
        ngr = 0
        delg = l/(2._pr * nhis)
        do i = 0, nhis
            g(i) = 0
            end do
    else if (switch==1) then
        ngr = ngr + 1
        do i = 1, npart-1
            do j = i+1, npart
                xr = x(3*i-2) - x(j*3-2)
                yr = x(3*i-1) - x(j*3-1)
                zr = x(3*i) - x(j*3)

                r = sqrt(xr*xr + yr*yr + zr*zr)
                if (r < (box/2)) then
                    ig = int(r/delg)
                    g(ig) = g(ig) + 1
                end if
            end do
        end do
    else if (switc == 2) then
        do i = 1, nhis
            r = delg*(i+0.5)
            vb = ((i+1)**3 - i**3)*delg**3
            nid = (4./3.)*pi*vb*rho
            g(i) = g(i)/(ngr*npart*nid)
        end do
    end if
end subroutine gr


A;
lambda x:A. 0.151523;

an : A; // term variable binding
an as A;
bn = lambda x:Nat. iszero x;  //  abbreviation
bn an ;
bn 10;
\x:Nat->Bool y:Nat. x y;

T = Nat->Nat; // type variable binding with abbreviation
g : T ;
(\z:Nat -> Nat . z 3) g;

(lambda f:T. lambda x:Nat. f (f x)) as T -> Nat -> Nat;

a : Nat;
let f= (\b:Nat->Nat .(\a:Nat->Nat. b)) in f (\c:Nat. a);


      SUBROUTINE TOTAL12

C     Submitted by Nga Nguyen, excerpt from INITIA in SWIM.f (Perfect
C     Club)

      PARAMETER (N1 = 513, N2 = 513)
      COMMON UNEW(N1,N2)
      COMMON /CONS/ M,N
      READ (5,*) M, N

      DO 20 I = 1, M
         DO 20 J = 1, N
            UNEW(I+1,J) = (I+1)*J
 20   CONTINUE

      DO 30 J = 1, N
         UNEW(1,J) = UNEW(M+1,J)
 30   CONTINUE

      DO 40 I = 1, M
         UNEW(I+1,N+1) = UNEW(I+1,1)
 40   CONTINUE

      UNEW(1,N+1) = UNEW(M+1,1)
      END


      subroutine mdfd (rx, lm, ln, prob, ier)
C
C          Probabilities in several variance distributions
C
C  References:
C     Egon Dorrer, "Algorithm 322: F-Distribution [S14]",
C         Communications of the ACM, Vol 11(2), 1968, p116-117.
C     J.B.F. Field, "Certification of Algorithm 322",
C         Communications of the ACM, Vol 12(1), 1969, p39.
C     Hubert Tolman, "Remark on Algorithm 322 [S14]",
C         Communications of the ACM, Vol 14(2), 1979, p117.
C
C  Probabilities are returned as the integral of P(q)dq for q
C  in the range zero to X (F-ratio and chi-square) or from -X to +X
C  (Student's t and Normal).
C
C  For F-ratios:
C     M = numerator degrees of freedom
C     N = denominator degrees of freedom
C     X = F-ratio
C  For Student's t (two tailed):
C     M = 1
C     N = Degrees of freedom
C     X = The square of t
C  For normal deviates (two tailed):
C     M = 1
C     N = 5000
C     X = The square of the deviate
C  For chi-square:
C     M = Degrees of freedom
C     N = 5000
C     X = Chi-square/M
C
C  The returned probability will be in the range 0 to 1, unless an error
C  occurred, in which case -1.0 is returned.
C  Recoded by LW, 28-Mar-94.
C
      INTEGER M,N,LM,LN,A,B,I,J
      REAL*8    X,W,Y,Z,D,P,ZK
      REAL	RX, PROB
C
      ier = 0
      X = RX
      M  = MIN(LM,300)
      N  = MIN(LN,5000)
      IF(MIN(M,N) .LT. 1) THEN
	  ier = 129
          PROB = -1.0
          RETURN
      ENDIF
      if (rx .lt. 0.0) then
	ier = 130
	prob = -1.0
	return
      endif
C
      A = 2*(M/2)-M+2
      B = 2*(N/2)-N+2
      W = X*FLOAT(M)/FLOAT(N)
      Z = 1.0/(1.0+W)
      IF(A .EQ. 1) THEN
          IF(B .EQ. 1)THEN
              P=SQRT(W)
              Y=0.3183098862
              D=Y*Z/P
              P=2.0*Y*ATAN(P)
          ELSE
              P=SQRT(W*Z)
              D=P*Z/(2.0*W)
          ENDIF
      ELSE
          IF(B .EQ. 1)THEN
              P=SQRT(Z)
              D=Z*P/2.0
              P=1.0-P
          ELSE
              D=Z*Z
              P=W*Z
          ENDIF
      ENDIF
      Y = 2.0*W/Z
      IF(A .EQ. 1) THEN
          DO 10 J=B+2,N,2
              D = (1.0 + FLOAT(A)/FLOAT(J-2)) * D * Z
              P = P + D * Y/FLOAT(J-1)
10        CONTINUE
      ELSE
          ZK = Z**((N-1)/2)
          D  = D * ZK * N/B
          P  = P * ZK + W * Z * (ZK-1.0)/(Z-1.0)
      ENDIF
      Y = W * Z
      Z = 2.0/Z
      B = N-2
      DO 20 I=A+2,M,2
          J = I + B
          D = (Y*D*FLOAT(J))/FLOAT(I-2)
20        P = P - Z * D/FLOAT(J)
      PROB = AMIN1(1.0,SNGL(P))
      PROB = AMAX1(0.0,PROB)
      RETURN
      END

c $Id$


!***********************************/
!	Name:セル中心における基礎変数勾配を求めるプログラム
!	Alias:GetGradient
!	Description:※勾配計算の式はスカラーに対するガウスの発散定理から導出される
!	Type:CellCenter
!	Input:Geometory,CCPrimitibeVariable
!	Output:CC%GradientOfVariable
!	Note:法線ベクトルについての考慮は式自体に内包してあるのでいらない
!	Author:Akitaka Toyota
!	Date:2017.10.26
!	Update:2018.01.11
!	Other:体積で除してなかったと思われる
!***********************************/
subroutine UGetGradient(UG,UCC)
    use StructVar_Mod
    use LoopVar_Mod
    use ConstantVar_Mod, only:CoreNumberOfCPU
    implicit none
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    double precision, allocatable :: EdgeNormal(:)
    allocate(EdgeNormal(3))

!面ごとに保存量と法線×面積...の定義式を計算
!総和を計算したあとに体積で除す
!本来はセル中心と界面の距離を元に荷重平均を取るべきではあるが，有意な差が出るとも思えないため単純に平均値を取る
!Cell内における勾配を求める
    UCC%GradientOfVariable = 0.0d0 !初期化

!たぶんここOMP入れたら値が不正になる
!!$omp parallel num_threads(CoreNumberOfCPU),shared(UG,UCC),firstprivate(iCell,iLocalEdge,iAdjacentCell,iVariable,EdgeNormal)
!!$omp do
    do iCell=1, UG%GI%RealCells !すべての実セルについて
        do iLocalEdge=1,3        !すべての局所界面についての総和を取る
            iEdge = UG%Tri%Edge(iCell,iLocalEdge) !セル界面の面番号
            iAdjacentCell = UG%Tri%Cell(iCell,iLocalEdge)   !隣接セルの番号

            if(iAdjacentCell > iCell) then !自セル位置の表裏を判定して法線ベクトルの向きを変え
                EdgeNormal(:) = UG%GM%Normal(iEdge,:)
            else
                EdgeNormal(:) = - UG%GM%Normal(iEdge,:)
            end if

            do iVariable = 1, 5 !全変数について勾配ベクトルを計算する
                UCC%GradientOfVariable(iVariable,iCell,1,1,:) = UCC%GradientOfVariable(iVariable,iCell,1,1,:) &
                & + 0.5d0 * (UCC%PrimitiveVariable(iVariable,iCell,1,1) + UCC%PrimitiveVariable(iVariable,iAdjacentCell,1,1)) &
                & * UG%GM%Area(iEdge) * EdgeNormal(:)

            end do

        end do

        UCC%GradientOfVariable(:,iCell,1,1,:) = UCC%GradientOfVariable(:,iCell,1,1,:)/UG%GM%Volume(iCell)

    end do
!!$omp end do
!!$omp end parallel

return
end subroutine UGetGradient


module pran
implicit none
private:: uniform_d,expone_d,gauss_d,gammar,gammar_d,gammad_d,           &
     chisqd,chisqd_d,chisqr_d,gammln_d,gammq_d,gcf_d,gser_d,fgam,fgam_d, &
     randomrot_d,setrot,setrot_d,outerprod3,outerprod3_d

interface chisqq
	module procedure chisqq,chisqq_d, chisqi, chisqi_d
end interface
interface promptseed;module procedure promptseed;        end interface
interface plant;   module procedure plant, plant1;       end interface
interface skewkurt;module procedure skewkurt, skewkurt_d;end interface
interface gammq;   module procedure gammq,  gammq_d;     end interface
interface gammln;  module procedure gammln, gammln_d;    end interface
interface uniform; module procedure uniform,uniform_d;   end interface
interface expone;  module procedure expone, expone_d;    end interface
interface gauss;   module procedure gauss,  gauss_d;     end interface
interface gcf;     module procedure gcf,    gcf_d;       end interface
interface gser;    module procedure gser,   gser_d;      end interface
interface fgam;    module procedure fgam,   fgam_d;      end interface
interface gammad
	module procedure gammar, gammar_d, gammad, gammad_d
end interface
interface chisqr
   module procedure chisqr, chisqr_d, chisqd, chisqd_d
end interface
interface ranperm; module procedure ranperm;             end interface
interface randomrot; module procedure randomrot,randomrot_d; end interface
contains
subroutine skewkurt(u0,u1,u2,u3,u4,bias,sdev,skew,kurt)
real(4),intent(IN ):: u0,u1,u2,u3,u4
real(4),intent(OUT):: bias,sdev,skew,kurt
real(4)            :: t1,t2,t3,t4,s2
t1=u1/u0
t2=u2/u0
t3=u3/u0
t4=u4/u0
t4=t4-4*t3*t1+6*t2*t1**2-3*t1**4
t3=t3-3*t2*t1           +2*t1**3
t2=t2                   -1*t1**2
bias=t1
sdev=sqrt(t2)
skew=t3/sdev**3
kurt=(t4/t2**2)-3
end subroutine skewkurt

subroutine skewkurt_d(u0,u1,u2,u3,u4,bias,sdev,skew,kurt)
real(8),intent(IN ):: u0,u1,u2,u3,u4
real(8),intent(OUT):: bias,sdev,skew,kurt
real(8)            :: t1,t2,t3,t4,s2
t1=u1/u0
t2=u2/u0
t3=u3/u0
t4=u4/u0
t4=t4-4*t3*t1+6*t2*t1**2-3*t1**4
t3=t3-3*t2*t1           +2*t1**3
t2=t2                   -1*t1**2
bias=t1
sdev=sqrt(t2)
skew=t3/sdev**3
kurt=(t4/t2**2)-3
end subroutine skewkurt_d

subroutine gammln(g,xx)
real(4),intent(IN) :: xx
real(4),intent(OUT):: g
REAL(8)         :: cof(6),stp,half,one,fpf,x,tmp,ser
integer         :: j
DATA cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, &
     -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/
DATA half,one,fpf/0.5d0,1.0d0,5.5d0/
x=xx-one
tmp=x+fpf
tmp=(x+half)*LOG(tmp)-tmp
ser=one
DO j=1,6
   x=x+one
   ser=ser+cof(j)/x
ENDDO
g=tmp+LOG(stp*ser)
END subroutine gammln

subroutine gammln_d(g,xx)
real(8),intent(IN ) :: xx
real(8),intent(OUT) :: g
REAL(8)             :: cof(6),stp,half,one,fpf,x,tmp,ser
integer             :: j
DATA cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, &
     -1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/
DATA half,one,fpf/0.5d0,1.0d0,5.5d0/
x=xx-one
tmp=x+fpf
tmp=(x+half)*LOG(tmp)-tmp
ser=one
DO j=1,6
   x=x+one
   ser=ser+cof(j)/x
ENDDO
g=tmp+LOG(stp*ser)
END subroutine gammln_d

subroutine gammq(g,a,x)
REAL(4),INTENT(IN) :: a,x
real(4),intent(OUT):: g
REAL(4)            :: gln,gammcf,gamser
IF(x<0. .OR. a<=0.)STOP 'In gammq; invalid argument'
IF(x<a+1.)THEN
   CALL gser(gamser,a,x,gln)
   g=1.-gamser
ELSE
   CALL gcf(gammcf,a,x,gln)
   g=gammcf
ENDIF
END subroutine gammq

subroutine gammq_d(g,a,x)
REAL(8),INTENT(IN ):: a,x
real(8),intent(OUT):: g
REAL(8)            :: gln,gammcf,gamser
IF(x<0. .OR. a<=0.)STOP 'In gammq; invalid argument'
IF(x<a+1.)THEN
   CALL gser(gamser,a,x,gln)
   g=1.-gamser
ELSE
   CALL gcf(gammcf,a,x,gln)
   g=gammcf
ENDIF
END subroutine gammq_d

subroutine promptseed
integer::seed
print '(" Input seed to initialize random number sequence")'
read(*,*)seed
call plant(seed)
end subroutine promptseed

subroutine plant
integer,parameter :: nn=12
integer,dimension(nn):: jseed
integer:: iran,jran
print '('' input positive integer seed for random number generator'')'
read(*,*)iran
jran=mod(iran,32778)
jseed(1)=jran+1
jseed(2)=jran**2-jran+1
call random_seed(put=jseed(1:nn))
end subroutine plant

subroutine plant1(iran)
integer,intent(IN):: iran
integer,parameter :: nn=12
integer,dimension(nn):: jseed
integer:: jran
jran=mod(iran,32778)
jseed(1)=jran+1
jseed(2)=jran**2-jran+1
call random_seed(put=jseed(1:nn))
end subroutine plant1

subroutine uniform(x)
real(4),intent(OUT):: x
real(4)            :: x1,x2
1 call random_number(x1)
call random_number(x2)
x=x1+x2*1.e-6
if(x>=1.)x=x-1.
if(x==0.)goto 1
end subroutine uniform

subroutine uniform_d(x)
real(8),intent(OUT):: x
real(8)            :: x1,x2
1 call random_number(x1)
call random_number(x2)
x=x1+x2*1.e-8
if(x>=1.d0)x=x-1.d0
if(x==0.d0)goto 1
end subroutine uniform_d

subroutine expone(x)
real(4),intent(OUT):: x
call uniform(x)
x=-log(x)
end subroutine expone

subroutine expone_d(x)
real(8),intent(OUT):: x
call uniform(x)
x=-log(x)
end subroutine expone_d

subroutine gauss(x)
real(4),intent(OUT):: x
integer:: iset
real(4):: gset,v1,v2,r,f
save gset,iset
data iset/0/
if(iset==0)then
1  call uniform(v1); v1=2*v1-1
   call uniform(v2); v2=2*v2-1
   r=v1**2+v2**2
   if(r>=1. .or. r==0.)goto 1
   f=sqrt(-2.*log(r)/r)
   gset=v1*f
   x=v2*f
   iset=1
else
   x=gset
   iset=0
endif
end subroutine gauss

subroutine gauss_d(x)
real(8),intent(OUT):: x
integer            :: iset
real(8)            :: gset,v1,v2,r,f
save gset,iset
data iset/0/
if(iset==0)then
1  call uniform(v1); v1=2*v1-1
   call uniform(v2); v2=2*v2-1
   r=v1**2+v2**2
   if(r>=1.d0 .or. r==0.d0)goto 1
   f=sqrt(-2.d0*log(r)/r)
   gset=v1*f
   x=v2*f
   iset=1
else
   x=gset
   iset=0
endif
end subroutine gauss_d

subroutine gammad(ia,x)
integer,intent(IN ):: ia
real(4),   intent(OUT):: x
integer:: j
real(4):: am,e,s,v1,v2,y
if(ia<0)stop 'In gammad; invalid ia'
if(ia<6)then
   x=1.
   do j=1,ia
      call uniform(y)
      x=x*y
   enddo
   x=-log(x)
else
1  call uniform(v1)
   call uniform(y)
   v2=2*y-1
   if(v1**2+v2**2>1.)goto 1
   y=v2/v1
   am=ia-1
   s=sqrt(2.*am+1.)
   x=s*y+am
   if(x<=0.)goto 1
   e=(1.+y**2)*exp(am*log(x/am)-s*y)
   call uniform(y)
   if(y>e)goto 1
endif
end subroutine gammad

subroutine gammad_d(ia,x)
integer,intent(IN ):: ia
real(8),intent(OUT):: x
integer            :: j
real(8)            :: am,e,s,v1,v2,y
if(ia<0)stop 'In gammad; invalid ia'
if(ia<6)then
   x=1.
   do j=1,ia
      call uniform(y)
      x=x*y
   enddo
   x=-log(x)
else
1  call uniform(v1)
   call uniform(y)
   v2=2*y-1
   if(v1**2+v2**2>1.d0)goto 1
   y=v2/v1
   am=ia-1
   s=sqrt(2.d0*am+1.d0)
   x=s*y+am
   if(x<=0.d0)goto 1
   e=(1.+y**2)*exp(am*log(x/am)-s*y)
   call uniform(y)
   if(y>e)goto 1
endif
end subroutine gammad_d

subroutine chisqd(ia,x)
integer,intent(IN ):: ia
real(4),   intent(OUT):: x
integer            :: ih
real(4)               :: y
if(ia<0)stop 'In chisqd; invalid ia'
ih=ia/2
call gammad(ih,x)
x=x*2
if(2*ih<ia)then
   call gauss(y)
   x=x+y**2
endif
end subroutine chisqd

subroutine chisqd_d(ia,x)
integer,intent(IN ):: ia
real(8),intent(OUT):: x
integer            :: ih
real(8)            :: y
if(ia<0)stop 'In chisqd; invalid ia'
ih=ia/2
call gammad(ih,x)
x=x*2
if(2*ih<ia)then
   call gauss(y)
   x=x+y**2
endif
end subroutine chisqd_d

subroutine chisqr(a,x)
real(4),intent(IN ):: a
real(4),intent(OUT):: x
real(4)            :: ah
ah=a/2
if(ah<0.)stop 'In chisqr; invalid degrees of freedom, a'
call gammad(ah,x)
x=x*2
end subroutine chisqr

subroutine chisqr_d(a,x)
real(8),intent(IN ):: a
real(8),intent(OUT):: x
real(8)            :: ah
ah=a/2
if(ah<0.)stop 'In chisqr; invalid degrees of freedom, a'
call gammad(ah,x)
x=x*2
end subroutine chisqr_d

SUBROUTINE gcf(gammcf,a,x,gln)
INTEGER, PARAMETER :: itmax=100
REAL(4),    PARAMETER :: eps=3.e-7
REAL(4),   INTENT(out):: gammcf,gln
REAL(4),   INTENT(in ):: a,x
INTEGER            :: n
REAL(4)               :: gold,a0,a1,b0,b1,fac,an,ana,anf,g
call gammln(gln,a)
gold=0.
a0=1.
a1=x
b0=0.
b1=1.
fac=1.
DO n=1,itmax
   an=REAL(n)
   ana=an-a
   a0=(a1+a0*ana)*fac
   b0=(b1+b0*ana)*fac
   anf=an*fac
   a1=x*a0+anf*a1
   b1=x*b0+anf*b1
   IF(a1/=0.)THEN
      fac=1./a1
      g=b1*fac
      IF(ABS((g-gold)/g)<eps)go to 1
      gold=g
   ENDIF
ENDDO
STOP 'in gcf; a too large, itmax too small'
1 gammcf=EXP(-x+a*log(x)-gln)*g
END SUBROUTINE gcf

SUBROUTINE gcf_d(gammcf,a,x,gln)
INTEGER, PARAMETER :: itmax=100
REAL(8), PARAMETER :: eps=3.d-14
REAL(8),INTENT(out):: gammcf,gln
REAL(8),INTENT(in ):: a,x
INTEGER            :: n
REAL(8)            :: gold,a0,a1,b0,b1,fac,an,ana,anf,g
call gammln(gln,a)
gold=0.
a0=1.
a1=x
b0=0.
b1=1.
fac=1.
DO n=1,itmax
   an=DBLE(n)
   ana=an-a
   a0=(a1+a0*ana)*fac
   b0=(b1+b0*ana)*fac
   anf=an*fac
   a1=x*a0+anf*a1
   b1=x*b0+anf*b1
   IF(a1/=0.d0)THEN
     fac=1./a1
      g=b1*fac
      IF(ABS((g-gold)/g)<eps)go to 1
      gold=g
   ENDIF
ENDDO
STOP 'in gcf; a too large, itmax too small'
1 gammcf=EXP(-x+a*log(x)-gln)*g
END SUBROUTINE gcf_d

SUBROUTINE gser(gamser,a,x,gln)
INTEGER,PARAMETER  :: itmax=100
REAL(4),   PARAMETER  :: eps=3.e-7
REAL(4),   INTENT(IN ):: a,x
REAL(4),   INTENT(OUT):: gamser,gln
INTEGER            :: n
REAL(4)               :: ap,sum,del
call gammln(gln,a)
IF(x<=0.)THEN
   IF(x<0.)PAUSE
   gamser=0.
   RETURN
ENDIF
ap=a
sum=1./a
del=sum
DO n=1,itmax
   ap=ap+1.
   del=del*x/ap
   sum=sum+del
   IF(ABS(del)<ABS(sum)*eps)go to 1
ENDDO
STOP 'In gser; a too large, itmax too small'
1     gamser=sum*EXP(-x+a*LOG(x)-gln)
END SUBROUTINE gser

SUBROUTINE gser_d(gamser,a,x,gln)
INTEGER,PARAMETER  :: itmax=100
REAL(8),PARAMETER  :: eps=3.d-14
REAL(8),INTENT(IN ):: a,x
REAL(8),INTENT(OUT):: gamser,gln
INTEGER            :: n
REAL(8)            :: ap,sum,del
call gammln(gln,a)
IF(x<=0.d0)THEN
   IF(x<0.d0)PAUSE
   gamser=0.
   RETURN
ENDIF
ap=a
sum=1./a
del=sum
DO n=1,itmax
   ap=ap+1.
   del=del*x/ap
   sum=sum+del
   IF(ABS(del)<ABS(sum)*eps)go to 1
ENDDO
STOP 'In gser; a too large, itmax too small'
1     gamser=sum*EXP(-x+a*LOG(x)-gln)
END SUBROUTINE gser_d

subroutine fgam(a,x)
! Generate gamma deviate with fractional degrees of freedom
real(4),intent(IN) :: a
real(4),intent(OUT):: x
real(4)            :: z,one,c,d,am,ai
data one/1./
if(a<=0. .or. a>=1.)stop 'In fgam; invalid argument'
am=a-1
ai=1/a
call gammq(c,a,one)
call uniform(x)
if(x<c)then
1  call uniform(z)
   x=1-log(z)
   d=x**am
   call uniform(z)
   if(z>d)goto 1
else
2  call uniform(z)
   x=z**ai
   d=exp(-x)
   call uniform(z)
   if(z>d)goto 2
endif
end subroutine fgam

subroutine fgam_d(a,x)
! Generate gamma deviate with fractional degrees of freedom
real(8),intent(IN) :: a
real(8),intent(OUT):: x
real(8)            :: z,one,c,d,am,ai
data one/1.d0/
if(a<=0.d0 .or. a>=1.d0)stop 'In fgam; invalid argument'
am=a-1
ai=1/a
call gammq(c,a,one)
call uniform(x)
if(x<c)then
1  call uniform(z)
   x=1-log(z)
   d=x**am
   call uniform(z)
   if(z>d)goto 1
else
2  call uniform(z)
   x=z**ai
   d=exp(-x)
   call uniform(z)
   if(z>d)goto 2
endif
end subroutine fgam_d

subroutine gammar(a,x)
real(4),intent(IN ):: a
real(4),intent(OUT):: x
integer         :: ia
real(4)            :: r,z
if(a<0.)stop 'In gammar; invalid argument'
ia=a
call gammad(ia,x)
r=a-ia
if(r>0.)then
   call fgam(r,z)
   x=x+z
endif
end subroutine gammar

subroutine gammar_d(a,x)
real(8),intent(IN ):: a
real(8),intent(OUT):: x
integer            :: ia
real(8)            :: r,z
if(a<0.d0)stop 'In gammar; invalid argument'
ia=a
call gammad(ia,x)
r=a-ia
if(r>0.d0)then
   call fgam(r,z)
   x=x+z
endif
end subroutine gammar_d

subroutine chisqq(g,a,x)
real(4),intent(IN ):: a,x
real(4),intent(OUT):: g
real(4):: b,y
b=a/2
y=x/2
call gammq(g,b,y)
end subroutine chisqq

subroutine chisqq_d(g,a,x)
real(8),intent(IN ):: a,x
real(8),intent(OUT):: g
real(8):: b,y
b=a/2
y=x/2
call gammq(g,b,y)
end subroutine chisqq_d

subroutine chisqi(g,ia,x)
integer,intent(IN):: ia
real(4),intent(IN ):: x
real(4),intent(OUT):: g
real(4):: b,y
b=ia/2.
y=x/2
call gammq(g,b,y)
end subroutine chisqi

subroutine chisqi_d(g,ia,x)
integer,intent(IN ):: ia
real(8),intent(IN ):: x
real(8),intent(OUT):: g
real(8):: b,y
b=ia/2.d0
y=x/2
call gammq(g,b,y)
end subroutine chisqi_d

!=============================================================================
subroutine ranperm(n,p)
!=============================================================================
! Deliver a random permutation of {1:n} in array p
!=============================================================================
implicit none
integer,             intent(IN ):: n
integer,dimension(n),intent(OUT):: p
integer,dimension(n)            :: pool
real(8)                         :: xran
integer                         :: i,j,jc
!=============================================================================
do i=1,n
   pool(i)=i
enddo
do j=1,n
   jc=n+1-j
   call uniform(xran)
   i=1+xran*jc
   p(j)=pool(i)
   pool(i:jc-1)=pool(i+1:jc)
enddo
end subroutine ranperm

!==============================================================================
subroutine randomrot(rot)
!==============================================================================
! Create a random 3*3 rotation matrix
real(4),dimension(3,3),intent(OUT):: rot
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(4),dimension(4):: v4
real(4)             :: s,alpha,beta,gamma
integer          :: i
!-----------------------------------------------------------------------------
4 continue
do i=1,4; call gauss(v4(i)); enddo
s=dot_product(v4,v4);           if(s==0)goto 4;gamma=2*acos(v4(4)/sqrt(s))
s=dot_product(v4(1:3),v4(1:3)); if(s==0)goto 4;alpha=acos(v4(3)/sqrt(s))
beta=atan2(v4(2),v4(1))
call setrot(alpha,beta,gamma,rot)
end subroutine randomrot

!==============================================================================
subroutine randomrot_d(rot)
!==============================================================================
! Create a random 3*3 rotation matrix
real(8),dimension(3,3),intent(OUT):: rot
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(8),dimension(4):: v4
real(8)             :: s,alpha,beta,gamma
integer             :: i
!-----------------------------------------------------------------------------
4 continue
do i=1,4; call gauss(v4(i)); enddo
s=dot_product(v4,v4);           if(s==0)goto 4;gamma=2*acos(v4(4)/sqrt(s))
s=dot_product(v4(1:3),v4(1:3)); if(s==0)goto 4;alpha=acos(v4(3)/sqrt(s))
beta=atan2(v4(2),v4(1))
call setrot_d(alpha,beta,gamma,rot)
end subroutine randomrot_d

!==============================================================================
subroutine setrot(alpha,beta,gamma,rot)
!==============================================================================
! Construct a 3*3 orthogonal matrix that represents a rotation by an angle
! gamma counterclockwise about an axis given by the unit vector, "axis3".
! axis3 points in the direction with colatitude alpha and longitude beta.
!==============================================================================
implicit none
real(4),               intent(IN ):: alpha,beta,gamma
real(4),dimension(3,3),intent(OUT):: rot
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(4),dimension(3,3)            :: t,q,r,u
real(4),dimension(3)              :: axis1,axis2,axis3,v3
real(4)                           :: ca,sa,cb,sb,cg,sg, &
                                  cca,csa,ssa,ccb,csb,ssb,pi2
!-----------------------------------------------------------------------------
ca=cos(alpha)
sa=sin(alpha)
cb=cos(beta)
sb=sin(beta)
cg=cos(gamma)
sg=sin(gamma)
cca=ca*ca
ssa=sa*sa
csa=ca*sa
ccb=cb*cb
ssb=sb*sb
csb=cb*sb
axis1(1)=cb*ca
axis1(2)=sb*ca
axis1(3)=sa
axis2(1)=-sb
axis2(2)=cb
axis2(3)=0
axis3(1)=-cb*sa
axis3(2)=-sb*sa
axis3(3)=ca
call outerprod3(axis3,axis3,t)
call outerprod3(axis1,axis1,q)
call outerprod3(axis2,axis2,r)
q=q+r
r=0
r(1,2)=-ca;     r(1,3)=-sb*sa;  r(2,3)=cb*sa
r(2,1)=-r(1,2); r(3,1)=-r(1,3); r(3,2)=-r(2,3)
rot=t + cg*q + sg*r
end subroutine setrot

!==============================================================================
subroutine setrot_d(alpha,beta,gamma,rot)
!==============================================================================
! Construct a 3*3 orthogonal matrix that represents a rotation by an angle
! gamma counterclockwise about an axis given by the unit vector, "axis3".
! axis3 points in the direction with colatitude alpha and longitude beta.
!==============================================================================
implicit none
real(8),               intent(IN ):: alpha,beta,gamma
real(8),dimension(3,3),intent(OUT):: rot
!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
real(8),dimension(3,3)            :: t,q,r,u
real(8),dimension(3)              :: axis1,axis2,axis3,v3
real(8)                           :: ca,sa,cb,sb,cg,sg, &
                                     cca,csa,ssa,ccb,csb,ssb,pi2
!-----------------------------------------------------------------------------
ca=cos(alpha)
sa=sin(alpha)
cb=cos(beta)
sb=sin(beta)
cg=cos(gamma)
sg=sin(gamma)
cca=ca*ca
ssa=sa*sa
csa=ca*sa
ccb=cb*cb
ssb=sb*sb
csb=cb*sb
axis1(1)=cb*ca
axis1(2)=sb*ca
axis1(3)=sa
axis2(1)=-sb
axis2(2)=cb
axis2(3)=0
axis3(1)=-cb*sa
axis3(2)=-sb*sa
axis3(3)=ca
call outerprod3_d(axis3,axis3,t)
call outerprod3_d(axis1,axis1,q)
call outerprod3_d(axis2,axis2,r)
q=q+r
r=0
r(1,2)=-ca;     r(1,3)=-sb*sa;  r(2,3)=cb*sa
r(2,1)=-r(1,2); r(3,1)=-r(1,3); r(3,2)=-r(2,3)
rot=t + cg*q + sg*r
end subroutine setrot_d

!=============================================================================
subroutine outerprod3(va,vb,vv)
!=============================================================================
implicit none
real(4),dimension(3),  intent(IN ):: va,vb
real(4),dimension(3,3),intent(OUT):: vv
integer                        :: i
!-----------------------------------------------------------------------------
do i=1,3
   vv(:,i)=va(:)*vb(i)
enddo
end subroutine outerprod3

!=============================================================================
subroutine outerprod3_d(va,vb,vv)
!=============================================================================
implicit none
real(8),dimension(3),  intent(IN ):: va,vb
real(8),dimension(3,3),intent(OUT):: vv
integer                           :: i
!-----------------------------------------------------------------------------
do i=1,3
   vv(:,i)=va(:)*vb(i)
enddo
end subroutine outerprod3_d

end module pran


module variables
!Network parameters
	integer,parameter::  N= 20000 !=Number of Neurons= Network size
	integer,parameter:: Avg_degree=10 !=<k>
	integer,parameter:: Nbonds=N*Avg_degree/2
!Time Parameters
	integer,parameter:: n_s=50000
	integer,parameter::     MeassTime=0.9*n_s
	integer,parameter::   transient=0.1*n_s
!Model Parameters
	real(8),parameter:: r1= 0.001  !Spontaneous activation
	real(8),parameter:: r2= 0.3 !Refractory to Quiescent probability n which is active)
	real(8),parameter:: lambda=12.5
!Threshold Variables
	real(8)::  T  ! Threshold T
	real(8),parameter::  Delta_T=0.005 ! Threshold Change
	real(8),parameter:: T_0=0.00
	real(8),parameter:: T_F=0.3
!Neuron States and  Neighbor lists
	integer S(1:N) !Neuron State
	integer S_prev(1:N) !Previous Neuron State
	integer,parameter:: x1=5*Avg_degree
	integer,dimension(N):: MyNeighbors=0 ! MyNeighbors(i) = Ammount of neighbors of i
	integer,dimension(N,x1):: NeighborMat=0 ! NeighborMat(i,k)= identity of the k-tjh neighbor of i
	real(8),dimension(N,x1):: Wij=0 ! Wij(i,k)= weight of the k-tjh connetcion of i, i.e., the conection with  NeighborMat(i,k)
	real(8)::weight
!OBSERVABLES
	integer:: activity,prev_activity
	real(8):: AVGact,AVGact2,AvgActPrev
	real(8):: f_s, varf_s,AC1  !fraction of actives, variance of activity and first autocorrelation coefficient
!AUXILIAR VARIABLES
	integer it !iteration step
	integer i,j, jj,k
	real(8) p !for random numbers
end module

program GH1
use variables
implicit none

!Load connection matrix and generate weights
open(99,file= "../Matrix/MyMatrix.txt",status="old",action="read")
do k=1,Nbonds
read(99,*) i,j
p=rand(); weight=-log(p)/lambda

MyNeighbors(i)=MyNeighbors(i)+1
NeighborMat(i,MyNeighbors(i))=j
Wij(i,MyNeighbors(i))=weight

MyNeighbors(j)=MyNeighbors(j)+1
NeighborMat(j,MyNeighbors(j))=i
Wij(j,MyNeighbors(j))=weight
enddo
close(99)

!Random Initial Condition
do i=1,N;	p=rand(); S(i)= int(p*3); enddo
! RUN

open(101,file= "Results.txt",status="unknown")
do T = T_0,T_F,Delta_T
call BlockStep
enddo !T
close(101)

! RUN Backwards
open(101,file= "BackResults.txt",status="unknown")
do T = T_F,T_0,-Delta_T
call BlockStep
enddo !T
close(101)

end program

subroutine BlockStep
use variables;
implicit none

!Transient
do it=1,transient;call step;enddo
!Now we compute variables
avgact=0 !Average Activity
avgact2=0 !Average Activity**2
AvgActPrev=0 !Average Activity(t)*Activity(t-1)

do it=1,MeassTime;
prev_activity=activity;
call step

avgact=avgact+activity
avgact2=avgact2+activity**2
AvgActPrev=AvgActPrev+activity*prev_activity

enddo
avgact=avgact/real(measstime)
avgact2=avgact2/real(measstime)
AvgActPrev=AvgActPrev/real(measstime)

f_s= avgact/real(N)
varf_s= real(avgact2-avgact**2)/real(N)**2
AC1= real((AvgActPrev-avgact**2)/(avgact2-avgact**2))

write(101,*) real(T ),f_s, varf_s, AC1
write(*,*) real(T ),f_s, varf_s, AC1
end subroutine

!------------------------------------------------
subroutine step
!Generates new State from previous state
use variables;
implicit none
real(8) sum_transmit

S_prev=S
Activity=0
do i=1,N
!Previously active -> Refractory Always
	if (S_prev(i).eq.1) then; S(i)=2  ; endif
!Refractary becomes Quiescent with probability r_2
	if (S_prev(i).eq.2)then
	 p=rand()
		if (p<r2) then; S(i)=0;
		else;  S(i)=2 ;  endif
	endif
!Previously Quiescent- > Excited
	if (S_prev(i).eq.0)then
		s(i)=0
! Spontaneous Activation
		p=rand()
		if (p<r1)then
			S(i)=1;
		else;
! Transmitted activation
		sum_transmit=0;
		do k=1,MyNeighbors(i)
			j=NeighborMat(i,k)
			if (S_prev(j)==1) sum_transmit=sum_transmit+Wij(i,k)
		end do
		if(sum_transmit > T ) S(i)=1
        end if
	endif
! Now we count active neurons
if (S(i)==1) then
activity=activity+1
!if (i<301) write(*,*) it,i
endif
end do !i
end subroutine


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

PROGRAM gaussian_test

    USE GAUSSIAN

    IMPLICIT NONE

    REAL*8 :: aa = 1.0D0, bb = 2.0D0 ! Gaussian exponential coefficients
    REAL*8, dimension(3) :: Ra = (/0.0D0,0.0D0,0.0D0/), Rb = (/1.0D0,1.0D0,1.0D0/)

    REAL :: Na, Nb

    Na = norm(0,0,0,aa)
    Nb = norm(0,0,0,bb)

    WRITE(*,*) "Na = ", Na
    WRITE(*,*) "Nb = ", Nb

END PROGRAM gaussian_test


*----------------------------------------------------------------------*
*
      implicit none
      integer Nmax
      parameter (Nmax=120)
      integer Nspheres
      parameter (Nspheres=2)
*
      real*8 pi
      parameter (pi = 3.141592653589793238462643d0)
*
*----------------------------------------------------------------------*
*
      integer NN(Nspheres,Nspheres), Neach(1:Nspheres), MainN
      common /dynamicN/ NN, Neach, MainN
      real*8 radius(1:Nspheres), r(Nspheres,Nspheres), th(Nspheres)
	  real*8 scaling(3)
      common /geometry/ radius, r, th
*
*----------------------------------------------------------------------*
*
      real*8 A(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax),
     +     B(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax),
     +     C(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax),
     +     D(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax),
     +     E(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax),
     +     F(1:2,1:Nspheres,1:3+Nspheres,1:Nmax,-Nmax:Nmax)
      common /coefficients/ A,B,C,D,E,F
*
*----------------------------------------------------------------------*
*
      real*8 s
      common /distance/ s
      real*8 globalerror
      common /error/ globalerror
*
*----------------------------------------------------------------------*
*
      real*8 g(0:Nmax,0:Nmax,-Nmax:Nmax)
      real*8 FracH(0:Nmax,0:Nmax,-Nmax:Nmax)
      common /Constants/ g, FracH
*
*----------------------------------------------------------------------*
*
      logical INALINE, NFUDGE
      common /Flags/ INALINE, NFUDGE
*
*----------------------------------------------------------------------*


subroutine pair_distances
   ! Calculate pair_dist(i,j) : distances for all the pairs of atoms
   !              x_dist(i,j) is xyz_dist(1,i,j)
   !              y_dist(i,j) is xyz_dist(2,i,j)
   !              z_dist(i,j) is xyz_dist(3,i,j)
   !         cutoffmat(i,j) : the cutoff matrix (logical), if needed

   use cluster, only : natom
   use enforce, only : x, y, z, u, v, w
   use distance
   !USE OMP_LIB                                                 !>>> CPU_TIME

   implicit none
   integer :: i, j
   !REAL(8) :: t_start, t_end                                   !>>> CPU_TIME

   !t_start = OMP_GET_WTIME()                                   !>>> CPU_TIME
!$OMP PARALLEL DEFAULT(SHARED)
   !----------------------------------------------
   ! Creating x_dist, y_dist, z_dist and pair_dist
   ! This should replicate the results of
   ! MolDyn M2.3; I need a way of dealing with the
   ! problem of reproducibility

!$OMP SECTIONS PRIVATE(i, j)
!$OMP SECTION
   do j=1, natom
      do i=1, natom
         xyz_dist(1,i,j) = x(j) +u(j) -x(i) -u(i)
      end do
   end do

!$OMP SECTION
   do j=1, natom
      do i=1, natom
         xyz_dist(2,i,j) = y(j) +v(j) -y(i) -v(i)
      end do
   end do

!$OMP SECTION
   do j=1, natom
      do i=1, natom
         xyz_dist(3,i,j) = z(j) +w(j) -z(i) -w(i)
      end do
   end do
!$OMP END SECTIONS

!$OMP DO PRIVATE(i, j), SCHEDULE(STATIC)
   do i=1, natom
      do j=1, natom
         pair_dist(j,i) = DSQRT(SUM(xyz_dist(:,j,i)**2))
      end do
   end do
!$OMP END DO
   !!write(*,*) "pair_distances:> pair(1,2) pair(1,natom)",pair_dist(1,2), pair_dist(1,natom)
!
   !---------------------------------------------------------
   ! Creating the cutoff matrix (logical),
   ! considering different pair kinds: (1)A-A, (2)B-B, (3)A-B
!$OMP SINGLE PRIVATE(i,j)
   IF (cutoffmat_req) THEN
      DO i = 1, natom-1
        DO j = i+1, natom
           cutoffmat(j,i) = (pair_dist(j,i) .LE. dcutoff(pairkindmat(j,i) ) )
           cutoffmat(i,j) = cutoffmat(j,i)
        END DO
      END DO
   END IF
!$OMP END SINGLE
!$OMP END PARALLEL
   !t_end = OMP_GET_WTIME()                                     !>>> CPU_TIME
   !! Writing the cpu time for the subroutine                   !>>> CPU_TIME
   !WRITE(500,'(1I10, 4X, 1F10.8)') ipas, t_end -t_start        !>>> CPU_TIME

end subroutine pair_distances


module solver
  implicit none
contains

  function solve(A, B) result(x)
    !! Solve matrix equation Ax = B for x given A and B
    real, intent(in) :: A(:, :), B(:)
    real :: x(size(A, 2))

    call solve_lss(A, B, x)
  end function

  subroutine solve_lss(A, B, x)
    !! Solve matrix equation Ax = B for x given A and B
    real :: A(:, :), B(:)
    real :: A_(size(A, 1), size(A, 2))
    real :: B_(size(B, 1))
    real :: x(size(A, 2))
    real :: s(min(size(A, 1), size(A, 2)))
    real :: work(6 * max(size(A, 1), size(A, 2)))
    real :: rcond
    integer :: m, n, rank, stat

    m = size(A, 1)
    n = size(A, 2)
    A_ = A
    B_ = B
    call dgelss(m, n, 1, A_, m, B_, m, s, rcond, rank, work, size(work), stat)
    x = B_(1:size(x))
    if (stat /= 0) call abort
  end subroutine

end module solver


submodule(Mod_CauchyElement) UPCauchyElement_NH_SGS

   implicit none

contains

   module subroutine up_elm_usgs_VS_NH_dynsgs(e,nd,tn,dvol,tautau,divstr,Finv,elmat)
      !-----------------------------------------------------------------------
      !
      ! This routine computes the elemental matrix
      !            (v_h,i*(1-tau_k^-1*tau_t), (1/J)F^-1_Kl(du_l/dX_K)div(S_ij),i)
      !            remember: div(S_ij)=(mu/J)*divstr
      !-----------------------------------------------------------------------
      implicit none

      class(FiniteElement), intent(in) :: e
      integer(ip),intent(in)     :: nd,tn
      real(rp),   intent(in)     :: dvol,tautau,Finv(nd,nd),divstr(nd)
      real(rp),   intent(inout)  :: elmat(nd,e%pnode,nd,e%pnode)
      integer(ip)                :: inode,jnode
      real(rp)                   :: B(nd,nd)

      do inode=1,e%pnode
          do jnode=1,e%pnode

              call sld_calculateVTauTau_JS(e,nd,tn,inode,jnode,tautau,divstr,Finv,B)

              elmat(1:nd,inode,1:nd,jnode) = elmat(1:nd,inode,1:nd,jnode) + B(:,:)*dvol

          end do
      end do

   end subroutine up_elm_usgs_VS_NH_dynsgs

end submodule UPCauchyElement_NH_SGS


      PROGRAM xcyclic
C     driver for routine cyclic
      INTEGER N
      PARAMETER (N=20)
      REAL alpha,beta,d,ran2
      REAL a(N),b(N),c(N),r(N),x(N),aa(N,N)
      INTEGER indx(N)
      INTEGER i,j,idum
      idum= -23
      do 12 i=1,N
        do 11 j=1,N
          aa(i,j)=0.
11      continue
12    continue
      do 13 i=1,N
        b(i)=ran2(idum)
        aa(i,i)=b(i)
        r(i)=ran2(idum)
13    continue
      do 14 i=1,N-1
        a(i+1)=ran2(idum)
        aa(i+1,i)=a(i+1)
        c(i)=ran2(idum)
        aa(i,i+1)=c(i)
14    continue
      alpha=ran2(idum)
      aa(N,1)=alpha
      beta=ran2(idum)
      aa(1,N)=beta
      call cyclic(a,b,c,alpha,beta,r,x,N)
      call ludcmp(aa,N,N,indx,d)
      call lubksb(aa,N,N,indx,r)
      do 15 i=1,N
        write(*,*) i,(x(i)-r(i))/(x(i)+r(i))
15    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xcyclic.for