      subroutine dstrsol(n,l,ldiag,jptr,indr,r,task)
      character*60 task
      integer n
      integer jptr(n+1), indr(*)
      double precision l(*), ldiag(n), r(n)
c     **********
c
c     Subroutine dstrsol
c
c     This subroutine solves the triangular systems L*x = r or L'*x = r.
c
c     The subroutine statement is
c
c       subroutine dstrsol(n,l,ldiag,jptr,indr,r,task)
c
c     where
c
c       n is an integer variable.
c         On entry n is the order of L.
c         On exit n is unchanged.
c
c       l is a double precision array of dimension *.
c         On entry l must contain the nonzeros in the strict lower
c            triangular part of L in compressed column storage.
c         On exit l is unchanged.
c
c       ldiag is a double precision array of dimension n.
c         On entry ldiag must contain the diagonal elements of L.
c         On exit ldiag is unchanged.
c
c       jptr is an integer array of dimension n + 1.
c         On entry jptr must contain pointers to the columns of A.
c            The nonzeros in column j of A must be in positions
c            jptr(j), ... , jptr(j+1) - 1.
c         On exit jptr is unchanged.
c
c       indr is an integer array of dimension *.
c         On entry indr must contain row indices for the strict
c            lower triangular part of L in compressed column storage.
c         On exit indr is unchanged.
c
c       r is a double precision array of dimension n.
c         On entry r must contain the vector r.
c         On exit r contains the solution vector x.
c
c       task is a character variable of length 60.
c         On entry
c            task(1:1) = 'N' if we need to solve L*x = r
c            task(1:1) = 'T' if we need to solve L'*x = r
c         On exit task is unchanged.
c
c     MINPACK-2 Project. May 1998.
c     Argonne National Laboratory.
c
c     **********
      double precision zero
      parameter(zero=0.0d0)

      integer j,k
      double precision temp

c     Solve L*x =r and store the result in r.

      if (task(1:1) .eq. 'N') then

         do j = 1, n
            temp = r(j)/ldiag(j)
            do k = jptr(j), jptr(j+1) - 1
               r(indr(k)) = r(indr(k)) - l(k)*temp
            end do
            r(j) = temp
         end do

         return

      end if

c     Solve L'*x =r and store the result in r.

      if (task(1:1) .eq. 'T') then

         r(n) = r(n)/ldiag(n)
         do j = n - 1, 1, -1
            temp = zero
            do k = jptr(j), jptr(j+1) - 1
               temp = temp + l(k)*r(indr(k))
            end do
            r(j) = (r(j) - temp)/ldiag(j)
         end do

         return

      end if

      end


! This module solves the 4 differential equations, and calculates the three moments (moment_ode.dat),
! and superstaturation as a function of time. These values are then used for the calculation of particle
! size distribution (size_distribution.dat)

module results

      USE DVODE_F90_M
      USE rhs
      USE user_interface

      !IMPLICIT NONE
      !INTEGER ITASK, ISTATE, NEQ , IOUT, tfinal
      !DOUBLE PRECISION ATOL, RTOL,  TT, TOUT, Y
      !DIMENSION Y(4), ATOL(4)
      !double precision :: Nc, vg, temp, dp_t, dpmg, sigmag
      !double precision :: momo1 = 1.0, momo2 = 2.0
      !double precision :: y_ini(4)

contains
!
    subroutine output(Nc_initial, dpmg_initial, sigmag_initial, vapor_initial, Nc_final, dpmg_final, sigmag_final, vapor_final,t_final_output)
      implicit none
      INTEGER ITASK, ISTATE, NEQ , IOUT, tfinal
      DOUBLE PRECISION ATOL, RTOL,  TT, TOUT, Y
      DIMENSION Y(4), ATOL(4)
      double precision :: Nc, vg, temp, dp_t, dpmg, sigmag
      double precision :: momo1 = 1.0, momo2 = 2.0
      double precision :: y_ini(4)

      double precision :: Nc_final, dpmg_final, sigmag_final, vapor_final, t_final_output
      double precision :: Nc_initial, dpmg_initial, sigmag_initial, vapor_initial
      TYPE (VODE_OPTS) :: OPTIONS

      !OPEN (UNIT=6,FILE='moment_ode.dat')
      !OPEN (UNIT=7,FILE='size_disribution.dat')

      num_zero = Nc_initial;
      dpg_zero = dpmg_initial;
      sigma_g_zero = sigmag_initial;
      S_zero = vapor_initial/ (Ps / (kb*T) )

            !call read_inputfile()
      call derived(ns, mu, lam, mm1, v1, r1, s1, sig, tau, K, vg_zero, t_start, delta_t, n_d)
      !print *, Nc_initial, dpmg_initial, sigmag_initial, vapor_initial, Nc_final, dpmg_final, sigmag_final, vapor_final,t_final_output
      NEQ = 4
      y(1) = num_zero/n_d
      y(2) = moment(num_zero,vg_zero,sigma_g_zero,momo1)/(v1*n_d)
      y(3) = moment(num_zero,vg_zero,sigma_g_zero,momo2)/(v1*v1*n_d)
      y(4) = S_zero
      y_ini(1) = num_zero/n_d
      y_ini(2) = moment(num_zero,vg_zero,sigma_g_zero,momo1)/(v1*n_d)
      y_ini(3) = moment(num_zero,vg_zero,sigma_g_zero,momo2)/(v1*v1*n_d)
      y_ini(4) = S_zero

      !print*, y(1), y(2), moment(num_zero,vg_zero,sigma_g_zero,1), num_zero,vg_zero,sigma_g_zero
      TT = t0
      TOUT = delta_t

      tfinal = (t_final_output/tau)/delta_t
      print*, tfinal
      RTOL = 1.0D-5
      ATOL(1) = 1.0D-9
      ATOL(2) = 1.0D-9
      ATOL(3) = 1.0D-9
      ATOL(4) = 1.0D-9
      ITASK = 1
      ISTATE = 1

!      write (7,500) '  t(sec)      ','  N(#/cm3)     ', '  dpg (nm)    ', '  sigmag      '
!500   format (a,a,a,a)
!      write (7,600) t0, num_zero*1.0e-6, dpg_zero*1.0e9, sigma_g_zero
!600   FORMAT (ES11.2E3,4ES11.2E3)

      if (tfinal == 0) then
              Nc_final = Nc_initial * 1e-6
              dpmg_final = dpmg_initial * 1e9
              sigmag_final = sigmag_initial
              vapor_final = vapor_initial
      else

      OPTIONS = SET_NORMAL_OPTS(DENSE_J=.TRUE.,RELERR=RTOL,ABSERR_VECTOR=ATOL)
      DO IOUT = 1, tfinal
        CALL DVODE_F90(FEX,NEQ,Y,TT,TOUT,ITASK,ISTATE,OPTIONS)
!        WRITE (6,90000) TT*tau, Y(1)*n_d, Y(2)*n_d*v1, Y(3)*n_d*v1*v1, Y(4)
!90000   FORMAT (ES11.2E3,4ES11.2E3)

        !print >> f2, '[time(min)]',' [Number Conc ( /cm3)]', '[Geomteric mean diameter(nm)]', '[standard deviation]'

        Nc = n_d * Y(1)* 1e-6
        !# if else to avoid division by zero
        if ((Y(1) < 1e-40) .or. (Y(3) < 1e-40) .or. (Y(2) < 1e-40)) then
            vg = 0.0
            temp = 0.0
            dp_t = 0.0
        else
            vg = v1 * Y(2)*Y(2)/(Y(1)**(3.0/2)*Y(3)**(1.0/2))
            !pop = v1 * y_ini(1)*V_t[0]/(N_t[0]**(3.0/2)*V2_t[0]**(1.0/2))
            temp = Y(1) * Y(3) / ( Y(2) * Y(2) )
            dp_t = (vg/v1)**(1.0/3)
        end if

        !# check if dp_t is less than the diameter for 1 molecule
        if (dp_t < 1) then
            dp_t = 1.0
        !# check if the dp_t value is nan
        else if (dp_t /= dp_t) then
            dp_t = 0.0
        end if

        !# convert dp_t to dimensional form
        dpmg = 2.0*r1*dp_t*1e9

        !# check the value of temp
        if (temp >  1.0) then
            sigmag = exp(sqrt(((1.0/9)*log(temp))))

        else
            sigmag = 1.0
        end if

        !WRITE (7,90000) TT*tau, Nc, dpmg, sigmag

        IF (ISTATE/=2) then
        ISTATE = 2
        end if
        TOUT = TOUT + delta_t
      end do

      Nc_final = Nc
      dpmg_final = dpmg
      sigmag_final = sigmag
      vapor_final = Y(4) * ns

      print*, Nc,dpmg,sigmag,Y(4)*ns

      end if

    end subroutine output

end module results


************************************************************************
*
*     Subroutine OUTEQN2                              Called by: CALIBR
*
*     print out concentration regression equation
*
************************************************************************
      SUBROUTINE OUTEQN2(BESTMOD,CCONC,CCONCAML,CUNITSTR,DVNAME,LDOUT,
     &                   NEXPL,NOBSC,NPAR,PARAMLC,PVALC,RSQC,SSECONC,
     &                   SSQCOBS,STDDEV,SUMCAML,SUMCOBS,TRANS)
*
*     dimensional parameters
*
      INCLUDE 'fmodules.inc'
*
*     subroutine arguments
*
      INTEGER*4 BESTMOD,LDOUT,NEXPL,NOBSC,NPAR
      DOUBLE PRECISION RSQC,SSECONC,SSQCOBS,SUMCAML,SUMCOBS
      DOUBLE PRECISION CCONC(*),CCONCAML(*),PARAMLC(*),PVALC(*)
      DOUBLE PRECISION STDDEV(MAXPARMS+1,*)
      CHARACTER*(*) CUNITSTR
      CHARACTER*5 DVNAME(*),TRANS(*)
*
*     local vars
*
      INTEGER*4 I
      CHARACTER*2 COEFSTR(MAXPARMS) /'a0','a1','a2','a3','a4','a5','a6'/
*
*     format statements
*
 1000 FORMAT(///,1X,70('-'),//,1X,'Constituent Output File Part Ib: ',
     &       'Calibration (Concentration Regression)',//,1X,70('-'),/)
 1200 FORMAT(//,' AMLE Regression Statistics',/,1X,26('-'))
 1400 FORMAT(/,' Model #',I2,' was selected for the load regression ',
     &       '(PART Ia) and is used here:',/)
 2001 FORMAT(' Ln(Conc) = a0 + a1 LnQ')
 2002 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 LnQ^2')
 2003 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 dtime')
 2004 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 Sin(2 pi dtime) + a3 ',
     &       'Cos(2 pi dtime)')
 2005 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 LnQ^2 + a3 ',
     &       'dtime')
 2006 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 LnQ^2 + a3 ',
     &       'Sin(2 pi dtime) + a4 Cos(2 pi dtime)')
 2007 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 Sin( pi dtime) + a3 ',
     &       'Cos(2 pi dtime) + a4 dtime')
 2008 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 LnQ^2 + a3 ',
     &       'Sin(2 pi dtime) + a4 Cos(2 pi dtime)',//,12X,'+ a5 dtime')
 2009 FORMAT(' Ln(Conc) = a0 + a1 LnQ + a2 LnQ^2 + a3 Sin(2 pi dtime)',
     &       ' + a4 Cos(2 pi dtime)',//,12X,'+ a5 dtime ',
     &       '+ a6 dtime^2')
 2010 FORMAT(' Ln(Conc) = a0 + a1 per + a2 LnQ + a3 ',
     &       'LnQ*per')
 2011 FORMAT(' Ln(Conc) = a0 + a1 per + a2 LnQ + a3 ',
     &       'LnQ*per + a4 LnQ^2',//,12X,'+ a5 ',
     &       'LnQ^2*per')
 2012 FORMAT(' Ln(Conc) =   a0')
 2020 FORMAT(12X,'+ a',I1,1X,A5)
 2021 FORMAT(12X,'+ a',I1,1X,A5,'^2')
 2022 FORMAT(12X,'+ a',I1,1X,'sqrt(',A5,')')
 2023 FORMAT(12X,'+ a',I1,1X,'LnQ')
 2024 FORMAT(12X,'+ a',I1,1X,'ln(',A5,')')
 2025 FORMAT(12X,'+ a',I1,1X,'LnQ^2')
 2026 FORMAT(12X,'+ a',I1,1X,'ln(',A5,')^2')
 2027 FORMAT(12X,'+ a',I1,1X,'sin(2*Pi*',A5,')')
 2028 FORMAT(12X,'+ a',I1,1X,'sin(4*Pi*',A5,')')
 2029 FORMAT(12X,'+ a',I1,1X,'sin(6*Pi*',A5,')')
 2030 FORMAT(12X,'+ a',I1,1X,'cos(2*Pi*',A5,')')
 2031 FORMAT(12X,'+ a',I1,1X,'cos(4*Pi*',A5,')')
 2032 FORMAT(12X,'+ a',I1,1X,'cos(6*Pi*',A5,')')
 2100 FORMAT(/' where:',/,7X,'Conc  = constituent concentration',/,7X,
     &       'LnQ   = Ln(Q) - center of Ln(Q)')
 2110 FORMAT(7X,'dtime = decimal time - center of decimal time')
 2120 FORMAT(7X,'per   = period; 1 or 0 depending on defined period')
 3000 FORMAT(//,' Concentration Regression Results',/,1X,32('-'),/,
     &       ' R-Squared [%]                  : ',F5.2,/,
     &       ' Residual Variance              : ',F6.4,//,
     &       ' Coeff.',4X,'Value',9X,'Std.Dev.',5X,'t-ratio',5X,
     &       'P Value',/,1X,58('-'))
 3100 FORMAT(1X,A2,7X,0PF7.4,8X,0PF6.4,5X,0PF7.2,7X,1PE9.3)
 3200 FORMAT(1X,A2,7X,0PF7.4,8X,0PF6.4,5X,0PF7.2,7X,'See WARNING')
 4600 FORMAT(//,' Comparison of Observed and Estimated Concentrations',
     &       /,1X,51('-'),
     &       /,'   The summary statistics and bias diagnostics ',
     &         'presented below are',
     &       /,' based on a comparison of observed and estimated ',
     &         'concentrations for',
     &       /,' all dates/times within the calibration data set. ',
     &         'Although this'
     &       /,' comparison does not directly address errors in ',
     &         'concentration estimation',
     &       /,' for unsampled dates/times, large discrepancies',
     &         ' between observed and',
     &       /,' estimated concentrations are indicative of a poor ',
     &         'model fit. Additional',
     &       /,' details and warnings are ',
     &         'provided below.',
     &       //,' Note: The comparison that follows uses a ',
     &         'concentration equal to 1/2 the',
     &       /,' detection limit when an observation ',
     &         'is censored. The summary stats and',
     &       /,' bias diagnostics are therefore slightly inaccurate ',
     &         'for censored data sets.')
 4700 FORMAT(//,' Summary Stats: Est. and Obs. Concentrations in ',A9,/,
     &       1X,59('-'),/,17X,'25th',14X,'75th',5X,'90th',5X,'95th',5X,
     &       '99th',/,8X,'Min.',5X,'Pct',6X,'Med.',5X,'Pct',
     &       3(6X,'Pct'),6X,'Max.',/,7X,72('-'))
 4800 FORMAT(//,' Bias Diagnostics',/,1X,16('-'),/,' Bp [%] ',F9.3,
     &       /,' PCR',4X,F9.3,/,' E',6X,F9.3,//,' where:',//,4X,
     &       'Bp',T9,'Concentration Bias in Percent',/,T9,'Positive '
     &       '(negative) values indicate over (under) ',
     &       'estimation.',/,T9,'***The model should not be ',
     &       'used when the + or - bias exceeds 25%***',
     &       //,4X,'PCR',T9,'Partial Concentration Ratio',/,T9,'Sum of',
     &       ' est. concentrations divided by sum of obs. ',
     &       'concentrations.',/,T9,'Values > 1 indicate over',
     &       'estimation; values < 1 indicate underestimation.',/,T9,
     &       'PCR = (Bp + 100) / 100',//,4X,'E',T9,
     &       'Nash Sutcliffe Efficiency Index',/,T9,'E ranges',
     &       ' from -infinity to 1.0',/,T9,'E = 1; a perfect',
     &       ' fit to observed data.',/,T9,'E = 0; model ',
     &       'estimates are as accurate as the mean of observed ',
     &       'data.',/,T9,'E < 0; the observed mean is a',
     &       ' better estimate than the model estimates.',/)
 4900 FORMAT(' IMPORTANT WARNING:',//,' Concentration Bias (Bp) ',
     &       'Exceeds + or - 25%',/,' THE CALIBRATED MODEL SHOULD NOT ',
     &       'BE USED FOR CONCENTRATION ESTIMATION',//)
 5000 FORMAT(' IMPORTANT WARNING:',//,' Nash Sutcliffe Efficiency ',
     &       'Index (E) is less than zero.',/,' The observed mean is ',
     &       'a better estimate than the model estimates.',/,' THE ',
     &       'CALIBRATED MODEL SHOULD NOT BE USED FOR CONCENTRATION ',
     &       'ESTIMATION',//)
 5100 FORMAT(/,' NOTE: Additional information on model calibration is ',
     &       'included in the',/,7X,'residual output file. LOADEST ',
     &       'users should conduct a thorough',/,7X,'residuals ',
     &       'analysis using the data contained therein (checks for',/,
     &       7X,'heteroscedasticity and non-normality).  Example ',
     &       'residual plots',/,7X,'are shown in Figures 7, 8, 9, and',
     &       ' 17 of the LOADEST documentation',/,7X,
     &       '(Runkel et al., 2004).')
*
*     output selected model number; If the regression model is user
*     defined (MODNO=99), BESTMOD will equal NMODELS, as a user defined
*     model is the last model - output '99' rather than BESTMOD in this
*     case.
*
      WRITE(LDOUT,1000)
      WRITE(LDOUT,1200)
      IF (BESTMOD .EQ. NMODELS) THEN
         WRITE(LDOUT,1400) 99
      ELSE
         WRITE(LDOUT,1400) BESTMOD
      ENDIF
*
*     output model equation
*
      IF (BESTMOD.EQ.1) THEN
         WRITE(LDOUT,2001)
         WRITE(LDOUT,2100)
      ELSEIF (BESTMOD.EQ.2) THEN
         WRITE(LDOUT,2002)
         WRITE(LDOUT,2100)
      ELSEIF (BESTMOD.EQ.3) THEN
         WRITE(LDOUT,2003)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.4) THEN
         WRITE(LDOUT,2004)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.5) THEN
         WRITE(LDOUT,2005)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.6) THEN
         WRITE(LDOUT,2006)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.7) THEN
         WRITE(LDOUT,2007)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.8) THEN
         WRITE(LDOUT,2008)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.9) THEN
         WRITE(LDOUT,2009)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ELSEIF (BESTMOD.EQ.10) THEN
         WRITE(LDOUT,2010)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2120)
      ELSEIF (BESTMOD.EQ.11) THEN
         WRITE(LDOUT,2011)
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2120)
      ELSEIF (BESTMOD.EQ.NMODELS) THEN
         WRITE(LDOUT,2012)
         DO 20 I=1,NEXPL
            IF (TRANS(I) .EQ. 'NONE') THEN
               WRITE(LDOUT,2020) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'SQ') THEN
               WRITE(LDOUT,2021) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'SQRT') THEN
               WRITE(LDOUT,2022) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'LN') THEN
               IF (DVNAME(I) .EQ. 'Q') THEN
                  WRITE(LDOUT,2023) I
               ELSE
                  WRITE(LDOUT,2024) I,DVNAME(I)
               ENDIF
            ELSEIF(TRANS(I) .EQ. 'LNSQ') THEN
               IF (DVNAME(I) .EQ. 'Q') THEN
                  WRITE(LDOUT,2025) I
               ELSE
                  WRITE(LDOUT,2026) I,DVNAME(I)
               ENDIF
            ELSEIF(TRANS(I) .EQ. 'SIN2P') THEN
               WRITE(LDOUT,2027) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'SIN4P') THEN
               WRITE(LDOUT,2028) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'SIN6P') THEN
               WRITE(LDOUT,2029) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'COS2P') THEN
               WRITE(LDOUT,2030) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'COS4P') THEN
               WRITE(LDOUT,2031) I,DVNAME(I)
            ELSEIF(TRANS(I) .EQ. 'COS6P') THEN
               WRITE(LDOUT,2032) I,DVNAME(I)
            ENDIF
 20      CONTINUE
         WRITE(LDOUT,2100)
         WRITE(LDOUT,2110)
      ENDIF
*
*     output AMLE regression statistics
*
      WRITE(LDOUT,3000) RSQC,PARAMLC(NPAR+1)

      DO 30 I=1,NPAR
         IF (PVALC(I) .LT. 9999999.99) THEN
            WRITE(LDOUT,3100) COEFSTR(I),PARAMLC(I),STDDEV(I,BESTMOD),
     &                        PARAMLC(I)/STDDEV(I,BESTMOD),PVALC(I)
         ELSE
            WRITE(LDOUT,3200) COEFSTR(I),PARAMLC(I),STDDEV(I,BESTMOD),
     &                           PARAMLC(I)/STDDEV(I,BESTMOD)
         ENDIF
 30   CONTINUE
*
*     start a new section w/i Constituent Output File Part Ib; this new
*     section compares observed and estimated concentrations on the
*     days/times for which observations are available (the calibration
*     data set).
*
      WRITE(LDOUT,4600)
*
*     print summary statistics for estimated concentrations
*
      WRITE(LDOUT,4700) CUNITSTR
      CALL OUTSUMMC(NOBSC,CCONCAML,CCONC,LDOUT)
*
*     print bias diagnostics, including:
*
*     Bp   Concentration Bias in % (email from B Hirsch, 16Jan2013)
*     PCR  Partial Concentration Ratio (Stenback et al., 2011)
*     E    Nash-Sutcliffe Efficiency Index (Nash & Sutcliffe, 1970)
*
*     Issue WARNINGS if |Bp| > 25% or  E < 0
*
      WRITE(LDOUT,4800) 100.D0*(SUMCAML/SUMCOBS - 1.D0),
     &                  SUMCAML/SUMCOBS,
     &                  1.D0-SSECONC/(SSQCOBS - SUMCOBS*SUMCOBS/NOBSC)

      IF (ABS(100.D0*(SUMCAML/SUMCOBS-1.D0)).GT.25.D0) THEN
         CALL JROGER(LDOUT)
         WRITE(LDOUT,4900)
      ENDIF

      IF (1.D0-SSECONC/(SSQCOBS - SUMCOBS*SUMCOBS/NOBSC).LT.0.D0) THEN
         CALL JROGER(LDOUT)
         WRITE(LDOUT,5000)
      ENDIF
*
*     write final note in regard to residual analyses
*
      WRITE(LDOUT,5100)

      RETURN
      END


module Mod_lmn_InterpolateGradients
   use typre
   use Mod_lmn_BaseElmope
   implicit none
   private
   public SetPointersInterpolateGradients

   integer(ip), allocatable :: kfl_IsSet

contains

   !----------------------------------------------------------------------------
   !Setting Pointers
   subroutine SetPointersInterpolateGradients(itask)
      implicit none
      integer(ip) :: itask
      select case (itask)

      case(0)
         allocate(kfl_IsSet)
         call a%Memor%allocObj(0,'kfl_IsSet','InitProcedurePointer',1)
         kfl_IsSet = -1

      case(1)
         if (kfl_IsSet == -1) then
            kfl_IsSet = 1

            call ConcatenateProcedures(ProcHook%Interpolates,InterpolateGradients)
         endif

      case(100)
         deallocate(kfl_IsSet)
         call a%Memor%deallocObj(0,'kfl_IsSet','InitProcedurePointer',1)

      end select
   end subroutine

   !---------------------------------------------------------------------------
   !Computation Subroutines
   subroutine InterpolateGradients
      implicit none
      integer(ip) :: idime

      call e%gradient(e%ndime,elvel(:,:,1),grvel)    !Vel. gradient

      !Velocity divergence
      divvel = 0.0_rp
      do idime = 1,e%ndime
         divvel = divvel + grvel(idime,idime)
      enddo

      call e%gradient(1,elpre,grpre)            !Press. gradient
      call e%gradient(1,eltem,grtem)            !Temp. gradient

   end subroutine

end module


SUBROUTINE masmtx ()

 ! *** calculates consistent (non-diagonal) mass matrix

  USE cms_db
  USE ctrl_db, ONLY: ndime, ndofn, npoin, neq, numct, mscal, ascal, lumped
  USE outp_db, ONLY: sumat,iwrit
  USE npo_db, ONLY :  emass,ymass,label,ifact,ifpre
  USE kinc_db, ONLY : ndumn,npsdf,nesdf,ftsdf,maxav,maxa
  USE ndp_db, ONLY : nndp
  USE sms_db, ONLY : selective_mass_scaling, fibre_mass

  IMPLICIT NONE

  INTEGER (kind=4) :: i,j,k,ipoin,chnode,dpos(ndofn)
  REAL(kind=8), ALLOCATABLE :: xcmas(:) !ndofn*(ndofn+1)/2)

  INTERFACE
    INCLUDE 'elemnt.h'
    INCLUDE 'contac.h'
    INCLUDE 'colsol.h'
    INCLUDE 'lump_mass.h'
    INCLUDE 'reduce_mass.h'
  END INTERFACE

  ! compute dependencies of rigid bodies for a correct assemble for non-diagonal matrices
  IF(.NOT.lumped .AND. ndumn > 0) CALL rigbdc (nndp)   !nodal dependencies of slave DOFs
  emass = 0d0 !initializes mass matrix
  ymass = 0d0

  IF (nconm > 0) THEN  !add concentrated masses
    IF(iwrit == 1) WRITE(lures,"(5x,'Concentrated Masses')",ERR=9999)
    ALLOCATE ( xcmas(ndofn*(ndofn+1)/2) )
    xcmas = 0d0
    k = 1
    DO j=1,ndofn
      dpos(j) = k
      k = k + ndofn - j + 1
    END DO

    DO i = 1,nconm
      ipoin = nodcms(i)
      ipoin = chnode(ipoin)
      xcmas(dpos) = cmass(1:ndofn,i)
      IF(iwrit == 1)WRITE(lures,"(i8,6e12.4)",ERR=9999) label(ipoin),cmass(1:ndofn,i)
      emass(1:ndofn,ipoin) = emass(1:ndofn,ipoin) + cmass(1:ndofn,i)
      IF(.NOT.lumped)CALL ensmat(ndofn,ifpre(1,ipoin),xcmas(1),ymass(1))
    END DO
  END IF

  sumat = 0d0

  CALL elemnt ('LUMASS')  !compute element masses
  IF( numct > 0) CALL contac ('LUMASS',0)  !contact surface mass
  IF( lumped ) THEN
    CALL elemnt ('RIGBDY')  !center or mass of rigid bodies
    IF( ndumn > 0) CALL rigbdc (nndp)   !nodal dependencies of slave DOFs
  END IF

  WRITE(lures, "(//'Total Mass of the System (Without Point Masses):', &
               & e15.7)",ERR=9999) sumat

  IF(iwrit == 1) THEN
    IF(ndime == 2)WRITE(lures,"(//,'  Lumped Mass Matrix' /,          &
                              &    ' Node',6X,'X',11X,'Y',11X,'a')",ERR=9999)
    IF(ndime == 3)WRITE(lures,"(//,'  Lumped Mass Matrix' /,' Node',  &
                & 6X,'X',11X,'Y',11X,'z',10x,'RX',10X,'RY',10X,'RZ')",ERR=9999)
    DO ipoin=1,npoin
      WRITE(lures,"(i5,8e12.4)",ERR=9999) label(ipoin),emass(1:ndofn,ipoin)
    END DO
  END IF
  IF (ascal) CALL scale_mass( mscal ) ! auto-scale mass matrix factor evaluation

  emass = emass*mscal !scale mass

  IF( lumped )THEN
    CALL ensmal(ndofn*npoin,neq,ifpre(1,1),emass(1,1),ymass(1),npsdf(1),nesdf(1),ftsdf(1))
    IF( selective_mass_scaling )CALL fibre_mass( emass )  ! where ???
    DO i=1,neq
      ymass(i) = 1d0/ymass(i)
    END DO
  ELSE
    ymass = ymass*mscal !scale mass
    print *,'reducing mass matrix size'
    CALL reduce_mass(ymass(:),maxav(:),neq,maxa)
    !DO i=1,neq
    !  j = maxav(i)
    !  k = maxav(i+1)-1
    !  WRITE(58,"(i7,(7e15.4))")i,ymass(j:k)
    !END DO
    print *,'Factoring mass matrix'
    CALL colsol(ymass(:),maxav(:),neq,1,58,0,0)
    !DO i=1,neq
    !  j = maxav(i)
    !  WRITE(58,"(i7,(7e15.4))")i,ymass(j)
    !END DO
    print *,'mass matrix factorized'
  END IF

RETURN
9999 CALL runen2('')
END SUBROUTINE masmtx


C
C**************************  LOCMAS ************************************
C
C  set up LMASS, the part of the local mass matrix which is constant
C  for all elements (i.e. without the storage coefficient and without
C  the volume term)
C  per il caso mass lumping si procede come segue:
C  - si sommano i coefficienti extra diagonali al coefficiente diagonale
C  - si azzerano tutti i coefficienti extra diagonali
C
C***********************************************************************
C
      SUBROUTINE LOCMAS(LMASS,LUMP)
C
      IMPLICIT  NONE
      INTEGER   I,K
      INTEGER   LUMP
      REAL*8    R4,R10,R20
      REAL*8    LMASS(4,4)
C
      R4=1.0D0/4.0D0
      R10=1.0D0/10.0D0
      R20=1.0D0/20.0D0
      DO K=1,4
         DO I=K,4
            IF (LUMP .EQ. 0) THEN
               IF (K.EQ.I) THEN
                  LMASS(K,I)=R10
               ELSE
                  LMASS(K,I)=R20
               END IF
            ELSE
               IF (K.EQ.I) THEN
                  LMASS(K,I)=R4
               ELSE
                  LMASS(K,I)=0.0D0
               END IF
            END IF
         END DO
      END DO
      DO K=2,4
         DO I=1,K-1
            LMASS(K,I)=LMASS(I,K)
         END DO
      END DO
C
      RETURN
      END


! STOCH algorithm following sheffi book
! input a network strcture
! output loading and cost

module STOCHLoading
use GraphLib
use constpara
implicit none

type,public::DialLoad
    type(graphclass)::nwk
    real*8,ALLOCATABLE::lt(:),lf(:)  ! link flow and link time
    real*8,ALLOCATABLE::prob(:,:)   ! prob
    real*8,ALLOCATABLE::linklike(:,:)
    real*8,ALLOCATABLE::rlabel(:,:),slabel(:,:)
    integer,ALLOCATABLE::rorder(:,:),sorder(:,:) ! ascend order
    real*8,ALLOCATABLE::Wsd(:,:)
    real*8::theta
contains
    procedure,pass::ini=>ini
    procedure,pass::del=>del
    procedure,pass::loadmain=>loadmain
    procedure,pass::get_sub_graph=>get_sub_graph
    procedure,pass::get_link_like=>get_link_like
    procedure,pass::forward=>forward
    procedure,pass::backward=>backward
end type DialLoad

contains

subroutine ini(this)
  use constpara
  implicit none
  class(dialload)::this
  if (.not.allocated(this%lt) then
    allocate(this%lt(nl),this%lf(nl))
    allocate(this%linklike(nl,ndest))
    allocate(this%rlabel(nn,ndest),this%slabel(nn,ndest))
    allocate(this%rorder(nn,ndest),this%sorder(nn,ndest))
    allocate(this%Wsd(nl,ndest),this%prob(nl,ndest))
  endif
  this%wsd = 0
  this%rorder = 0
  this%sorder = 0
  this%linklike = 0
  this%rlabel = -1
  this%slabel = -1
  this%lt = 0
  this%lf = 0
  this%prob = 0
  call this%nwk%inigraph
end subroutine

subroutine del(this)
implicit none
class(dialload)::this

call this%nwk%delgraph
deallocate(this%lt,this%lf,this%prob,this%linklike)
deallocate(this%slabel,this%rlabel,this%rorder,this%sorder)

end subroutine

subroutine loadmain(this)
implicit none
CLASS(DialLoad)::this

this%theta = 1.0

call this%nwk%readnwt
this%lt= this%nwk%scost
call this%get_sub_graph
call this%get_link_like
call this%backward
call this%forward

end subroutine

subroutine get_sub_graph(this)
use constpara
implicit none

integer::r,s,w,i,nr,l,j
class(dialload)::this
this%nwk%sublink =.false.
this%nwk%subnode =.false.
do w = 1,nod
    r = this%nwk%origin(w)
    s = this%nwk%dest(w)
    do i = 1, ndest
        if (s.eq.this%nwk%roots(i)) then
            nr = i
            exit
        end if
    enddo
    ! from r to all nodes
    call sp(r,this%lt,this%nwk%firstout,this%nwk%lastout,this%nwk%pa(:,nr),this%nwk%bnode)
    this%rlabel(:,nr) = dist(:)
    ! from s to all nodes
    call rsp(s,this%nwk%scost,this%nwk%firstin,this%nwk%lastin,this%nwk%pa(:,nr),this%nwk%backbnode,this%nwk%backtoforward)
    this%slabel(:,nr) = dist(:)

    do l = 1,nl
        i = this%nwk%anode(l)
        j = this%nwk%bnode(l)
        if ((this%rlabel(i,r).lt.this%rlabel(j,nr)).and.(this%slabel(i,nr).gt.this%slabel(j,nr))) then
            this%nwk%sublink(l,nr) = .true.
            this%nwk%subnode(i,nr) = .true.
            this%nwk%subnode(j,nr) = .true.
        end if
    end do
enddo

end subroutine

! compute the link likelyhood
subroutine get_link_like(this)
implicit none

integer::l,nr,i,j
CLASS(DialLoad)::this

do nr = 1, ndest
    do l = 1, nl
        i = this%nwk%anode(l)
        j = this%nwk%bnode(l)
        if (this%nwk%sublink(l,nr)) then
            this%linklike(l,nr) = exp(this%theta*(this%rlabel(j,nr)-this%rlabel(i,nr)-this%lt(l)))
            write(*,*) "i = ",i," j = ",j," val = ",this%rlabel(j,nr)-this%rlabel(i,nr)-this%lt(l),&
                        " L = ", this%linklike(l,nr)
        else
            this%linklike(l,nr) = 0
        endif
    end do
end do

end subroutine

subroutine backward(this)
implicit none
integer::nr,i,now,l,ol,link
class(DialLoad)::this
real*8::sumwsd

do nr = 1, ndest
    this%Wsd(:,nr) = 0
    call sort(-1*this%slabel(:,nr),this%sorder(:,nr),nn)
    do i = 1, nn
        now = this%sorder(i,nr)
        do link = this%nwk%firstin(now),this%nwk%lastin(now)
            l=this%nwk%backtoforward(link)
           if (now.eq.this%nwk%roots(nr)) then
                this%Wsd(l,nr) = 1
           else
                sumwsd = 0
                do ol = this%nwk%firstout(now), this%nwk%lastout(now)
                    sumwsd = sumwsd + this%Wsd(ol,nr)
                enddo
                this%Wsd(l,nr) = this%linklike(l,nr)*sumwsd
           endif
           write(*,*) "i = ",this%nwk%anode(l), " j =",this%nwk%bnode(l), " val=",this%Wsd(l,nr)
        enddo
    enddo
end do

end subroutine

subroutine forward(this)
implicit none

class(dialload)::this
integer::nr,i,now,l,a,b
real*8::sumwsd

do nr = 1, ndest
    call sort(-1*this%rlabel(:,nr),this%rorder(:,nr),nn)
    do i = 1, nn
        now = this%rorder(i,nr)
        sumwsd = 0
        do l = this%nwk%firstout(now), this%nwk%lastout(now)
            sumwsd = this%Wsd(l,nr) + sumwsd
        enddo
        do l = this%nwk%firstout(now), this%nwk%lastout(now)
            if (sumwsd .eq.0) then
                this%prob(l,nr) = 0
            else
                this%prob(l,nr) = this%Wsd(l,nr)/sumwsd
            end if
        enddo
    enddo
    do l = 1, nl
       a = this%nwk%anode(l)
       b = this%nwk%bnode(l)
    enddo
end do

end subroutine

end module


!>
!! @file m_fftw.f90
!! @brief Contains module m_fftw

!> @brief The module contains the subroutines for the FFT routines
MODULE m_fftw

    ! Dependencies =============================================================
    USE, INTRINSIC :: ISO_C_BINDING

    USE m_derived_types        !< Definitions of the derived types

    USE m_global_parameters    !< Definitions of the global parameters

    USE m_mpi_proxy            !< Message passing interface (MPI) module proxy
    ! ==========================================================================

    IMPLICIT NONE

    PRIVATE; PUBLIC :: s_initialize_fftw_module,   &
                       s_apply_fourier_filter,     &
                       s_finalize_fftw_module

    INCLUDE 'fftw3.f03'

    TYPE(C_PTR) :: fwd_plan, bwd_plan
    TYPE(C_PTR) :: fftw_real_data, fftw_cmplx_data, fftw_fltr_cmplx_data
    INTEGER :: real_size, cmplx_size

    REAL(C_DOUBLE), POINTER :: data_real(:) !< Real data

    COMPLEX(C_DOUBLE_COMPLEX), POINTER :: data_cmplx(:) !<
    !! Complex data in Fourier space

    COMPLEX(C_DOUBLE_COMPLEX), POINTER :: data_fltr_cmplx(:) !<
    !! Filtered complex data in Fourier space

    CONTAINS

        !>  The purpose of this subroutine is to create the fftw plan
        !!      that will be used in the forward and backward DFTs when
        !!      applying the Fourier filter in the azimuthal direction.
        SUBROUTINE s_initialize_fftw_module() ! ----------------------------------

            ! Size of input array going into DFT
            real_size = p+1
            ! Size of output array coming out of DFT
            cmplx_size = (p+1)/2+1

            ! Allocate input and output DFT data sizes
            fftw_real_data       = fftw_alloc_real   (int( real_size, C_SIZE_T))
            fftw_cmplx_data      = fftw_alloc_complex(int(cmplx_size, C_SIZE_T))
            fftw_fltr_cmplx_data = fftw_alloc_complex(int(cmplx_size, C_SIZE_T))
            ! Associate input and output data pointers with allocated memory
            CALL c_f_pointer(fftw_real_data ,      data_real ,      [ real_size])
            CALL c_f_pointer(fftw_cmplx_data,      data_cmplx,      [cmplx_size])
            CALL c_f_pointer(fftw_fltr_cmplx_data, data_fltr_cmplx, [cmplx_size])

            ! Generate plans for forward and backward DFTs
            fwd_plan = fftw_plan_dft_r2c_1d(real_size, data_real      , data_cmplx, FFTW_ESTIMATE)
            bwd_plan = fftw_plan_dft_c2r_1d(real_size, data_fltr_cmplx, data_real , FFTW_ESTIMATE)

        END SUBROUTINE s_initialize_fftw_module ! ------------------------------

        !>  The purpose of this subroutine is to apply a Fourier low-
        !!      pass filter to the flow variables in the azimuthal direction
        !!      to remove the high-frequency content. This alleviates the
        !!      restrictive CFL condition arising from cells near the axis.
        SUBROUTINE s_apply_fourier_filter(q_cons_vf) ! --------------------------

            TYPE(scalar_field), DIMENSION(sys_size), INTENT(INOUT) :: q_cons_vf

            INTEGER :: Nfq !< Number of kept modes

            INTEGER :: i,j,k !< Generic loop iterators

            ! Restrict filter to processors that have cells adjacent to axis
            IF (bc_y%beg >= 0) RETURN

            ! Keeping only the mean value for cells directly adjacent to axis
            Nfq = 3
            DO j = 0, m
                DO k = 1, sys_size
                    data_fltr_cmplx(:) = (0d0,0d0)
                    data_real(1:p+1) = q_cons_vf(k)%sf(j,0,0:p)
                    CALL fftw_execute_dft_r2c(fwd_plan, data_real, data_cmplx)
                    data_fltr_cmplx(1:Nfq) = data_cmplx(1:Nfq)
                    CALL fftw_execute_dft_c2r(bwd_plan, data_fltr_cmplx, data_real)
                    data_real(:) = data_real(:)/REAL(real_size,KIND(0d0))
                    q_cons_vf(k)%sf(j,0,0:p) = data_real(1:p+1)
                END DO
            END DO

            ! Apply Fourier filter to additional rings
            DO i = 1, fourier_rings
                Nfq = MIN(FLOOR(2d0*REAL(i,KIND(0d0))*pi),cmplx_size)
                DO j = 0, m
                    DO k = 1, sys_size
                        data_fltr_cmplx(:) = (0d0,0d0)
                        data_real(1:p+1) = q_cons_vf(k)%sf(j,i,0:p)
                        CALL fftw_execute_dft_r2c(fwd_plan, data_real, data_cmplx)
                        data_fltr_cmplx(1:Nfq) = data_cmplx(1:Nfq)
                        CALL fftw_execute_dft_c2r(bwd_plan, data_fltr_cmplx, data_real)
                        data_real(:) = data_real(:)/REAL(real_size,KIND(0d0))
                        q_cons_vf(k)%sf(j,i,0:p) = data_real(1:p+1)
                    END DO
                END DO
            END DO

        END SUBROUTINE s_apply_fourier_filter ! --------------------------------

        !>  The purpose of this subroutine is to destroy the fftw plan
        !!      that will be used in the forward and backward DFTs when
        !!      applying the Fourier filter in the azimuthal direction.
        SUBROUTINE s_finalize_fftw_module() ! ------------------------------------
            CALL fftw_free(fftw_real_data)
            CALL fftw_free(fftw_cmplx_data)
            CALL fftw_free(fftw_fltr_cmplx_data)

            CALL fftw_destroy_plan(fwd_plan)
            CALL fftw_destroy_plan(bwd_plan)

        END SUBROUTINE s_finalize_fftw_module ! --------------------------------

END MODULE


	subroutine hermite(s,ds,etall,n,svec,nn,bt,tk,pk,hk,
     &           vk,gk,fk,mk,rt,rp,rh,rv,rg,rf,rm,mnodos)

        implicit real*4 (a-h,o-z)
	include 'PARAMETER' !por kt
        parameter (kt16=16*kt)
        parameter (dl10=2.3025851)

	integer n,nn
	real*4 svec(4)
        integer*4 mnodos(*)

c internas
        real*4 sol(4,kt),tau(kt),taue(kt),s0(kt)
        real*4 deltae(kt),deltai(kt),delt2i(kt)
	real*4 ds(kt), detal(4,4,kt), etal(4,4,kt), etall(4,4,kt)
	real*4 etal2(4,4,kt)
	real*4 s(kt), den(4), num(4,4), den2(4,4)
	real*4 OO(4,4,kt)
        real*4 tk(kt16),pk(kt16),hk(kt16),vk(kt16),gk(kt16),fk(kt16),mk(kt16)
	real*4 bt(kt)
	real*4 rt(4,kt),rp(4,kt),rh(4,kt),rv(4,kt),rg(4,kt),rf(4,kt),rm(4,kt)

        common/segunda/tau,taue,deltae,deltai,delt2i

	integer :: error_code
	common/Error/error_code

c se calcula donde poner el contorno

        icontorno=1
	do i=1,n-1

	   ti=abs(etall(1,1,i))
           tq=abs(etall(1,2,i))
           tu=abs(etall(1,3,i))
           tv=abs(etall(1,4,i))
c	   print*,'ti,tq,tu,tv=',i,ti,tq,tu,tv

           taunu=max(ti,tq,tu,tv)*deltae(i)
           if(taunu.gt.5.)icontorno=i

        end do
c	icontorno=1

c se calcula la derivada de la matriz de absorcion

	do i=1,n
	   xx = taue(i)*dl10
c	   print*,'tau,taue,deltae,deltai,delt2i=',tau(i),taue(i),deltae(i),deltai(i),delt2i(i)
	   do jj=1,4
	      do kk=1,4
	         etal(jj,kk,i) = etall(jj,kk,i)*xx
c		 print*,'etal,jj,kk,i=',jj,kk,i,etal(jj,kk,i),xx
	      enddo
	   enddo
  	end do
	call deriva4cuad(etal,detal,n,tau)

c se integra
        call inicializa(icontorno,etal,s,ds,oo,sol,ierror)
	if(ierror.eq.1)return
c	ic=icontorno
c	do while(ierror .eq. 1 .and. icontorno .lt. n-3 )
c	  icontorno=icontorno+3
c         call inicializa(icontorno,etal,s,ds,oo,sol,ierror)
c	end do

	do i=icontorno,n
	   do jj=1,4
	      do ii=1,4
                ssum=0.
	         do k=1,4
	            ssum = ssum +  etal(ii,k,i)*etal(k,jj,i)
	         enddo
	         etal2(ii,jj,i) = ssum
	      enddo
	   enddo
	enddo

 	do i=icontorno+1,n
           delta=deltai(i)
           delt2=delt2i(i)
	   do jj=1,4
              e0=etal(jj,1,i-1)
	      e1=etal(jj,1,i)
              s00=s(i-1)
              s01=s(i)
	      den(jj) =-( e0*s00 + e1*s01 )*
     &	                 delta + sol(jj,i-1)
	      den(jj) =-(detal(jj,1,i-1)*s00 - detal(jj,1,i)*s01  +
     &                  e0*ds(i-1) -  e1*ds(i) +
     &                  etal2(jj,1,i-1)*s00 - etal2(jj,1,i)*s01 )*
     &                  delt2 + den(jj)

	      do ii=1,4
	         den2(ii,jj)=etal(ii,jj,i-1)*delta+
     & delt2*(detal(ii,jj,i-1)+etal2(ii,jj,i-1))
	         den(jj)=den(jj) + (etal(jj,ii,i-1)*delta+
     & delt2*(detal(jj,ii,i-1)+etal2(jj,ii,i-1)))*sol(ii,i-1)
	         num(ii,jj) = - etal(ii,jj,i)*delta +
     & delt2*(detal(ii,jj,i)+etal2(ii,jj,i))
	      enddo
	      num(jj,jj) = 1.0 + num(jj,jj)
	      den2(jj,jj) = 1.0 + den2(jj,jj)
	   enddo

c	   do ll=1,4
c		write(*,*) 'hola hermite',(num(ll,lll),lll=1,4),delta,
c     & delt2,etal(ii,jj,icontorno+1),detal(ii,jj,icontorno+1),etal2(ii,jj,icontorno+1)
c	   enddo

	   call matinx(num)

	   if (error_code == 1) return

	   do jj=1,4
              sum=0.
	      do ii=1,4
	         sum = sum + num(jj,ii)*den(ii)
	         sumoo= 0.e0
	         do k=1,4
	            sumoo = sumoo + num(ii,k)*den2(k,jj)
	         enddo
	         OO(ii,jj,i-1) = sumoo
	      enddo
	      sol(jj,i) = sum
	   enddo
	enddo

	do ii=1,4
	   svec(ii) = sol(ii,n)
	enddo

	do jj=1,4
	   do ii=1,4
	      OO(ii,jj,n) = 0.e0
	   enddo
	   OO(jj,jj,n) = 1.e0
	enddo

	do i=n-2,1,-1
	   do jj=1,4
	      do kk=1,4
                 sum=0.e0
	         do k=1,4
	            sum=sum+OO(kk,k,i+1)*OO(k,jj,i)
	         enddo
	         den2(kk,jj) = sum
              enddo
	   enddo
	   do jj=1,4
	      do kk=1,4
	         OO(kk,jj,i)=den2(kk,jj)
	      enddo
	   enddo
	enddo

	do i=1,n
	   s0(i) = 0.e0
	   sol(1,i) = sol(1,i)-s(i)
	enddo

	if(mnodos(1).ne.0)call DELTA1(n,tk,bt,sol,OO,etall,rt)
c	if(mnodos(2).ne.0)call DELTA1(n,pk,s0,sol,OO,etall,rp)
	if(mnodos(1).ne.0.or.mnodos(2).ne.0.or.mnodos(4).ne.0.or.
     &     mnodos(6).ne.0)call DELTA1(n,pk,s0,sol,OO,etall,rp)
	if(mnodos(3).ne.0)call DELTA1(n,mk,s0,sol,OO,etall,rm)
	if(mnodos(4).ne.0)call DELTA1(n,hk,s0,sol,OO,etall,rh)
	if(mnodos(5).ne.0)call DELTA1(n,vk,s0,sol,OO,etall,rv)
	if(mnodos(6).ne.0)call DELTA1(n,gk,s0,sol,OO,etall,rg)
	if(mnodos(7).ne.0)call DELTA1(n,fk,s0,sol,OO,etall,rf)

	return
	end

c ___________________________________________________________________
       subroutine inicializa(icontorno,etal,s,ds,oo,sol,ierror)

       implicit real*4 (a-h,o-z)

       include 'PARAMETER' !por kt
       parameter (kt16=16*kt)
       real*4 etal(4,4,kt),inveta(4,4),s(*),ds(*),oo(4,4,kt),sol(4,kt)

       do k=1,icontorno
	  do j=1,4
	     do i=1,4
	        inveta(i,j)=etal(i,j,k)
c		 print*,'inveta(i,j)=',i,j,inveta(i,j)
	     end do
	  end do

	  call matinx2(inveta,ierror)	!calcula la matriz inversa 4*4

	  do i=1,4
c	     print*,'en hermite.f, inveta(i,k)=',i,k,inveta(i,k),ds(k)
	     sol(i,k)=inveta(i,1)*ds(k)
	  end do
	  sol(1,k)=sol(1,k)+s(k)
       end do

	do l=2,icontorno+1   !aprox. de difusion para el op. evolucion
	   do j=1,4
              do i=1,4
                OO(i,j,l)=0.
	      enddo
c	      if(i.eq.j)OO(i,j,l)=0. !1.
            enddo
c           smed=.5*(s(l)-s(l-1))
c	    smed=s(l)
	    OO(1,1,l-1)=0.   !(sol(1,l)-smed)/(sol(1,i-1)-smed)
	enddo

       return
       end


c gmm01f
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
      subroutine cofnv0(nmax)
      include 'gmm01f.par'
      integer n,v
      double precision c1,lnfacd,cnv(np,np)
      common/cfnv/cnv
      do n=1,nmax
         do v=n,nmax
            c1=lnfacd(dble(2*n))+lnfacd(dble(2*v))
            c1=c1-lnfacd(dble(2*n+2*v))
            c1=c1+2.d0*lnfacd(dble(n+v))
            c1=c1-lnfacd(dble(n))-lnfacd(dble(v))
            cnv(n,v)=c1
         enddo
      enddo
      return
      end


C
      SUBROUTINE CONLAB(IX,JX,II,JJ,X,Y,F,FCON,XWT,YWT,
     &           CH,NDIG,ISIDE)
      DIMENSION X(IX,JX), Y(IX,JX)
      DIMENSION F(IX,JX)
C---------------------------------------------------------------------
C     Puts numerical labels on the contour with value FCON at the
C     edge of the domain specified by ISIDE.  The number of digits
C     in the label(s) after the decimal point is given by NDIG.
C
C     Input:
C        IX JX     dimensions of arrays   X, Y, F
C        II JJ     array limits of arrays X, Y, F
C        X(i,j)    coordinates of grid point (i,j)
C        Y(i,j)
C        F(i,j)    function value at grid point (i,j)
C        FCON      value of F on the contour to be labeled
C        XWT YWT   plotting scale factors for X,Y:
C                       Xplot = X(i,j)*XWT
C                       Yplot = Y(i,j)*YWT
C        CH        absolute character height (no scaling is done)
C        NDIG      number of digits after decimal point in labels
C        ISIDE     domain side on which labels are to appear:
C
C           .     3     .
C
C           4           2
C
C           .     1     .
C
C
C     Output:      direct plotting calls using Versatec routines
C
C---------------------------------------------------------------------
      LOGICAL LABEL
C
      DATA PI, RTOD / 3.141592654, 57.2957795 /
C
C---- total number of digits + decimal point
      RDIG = 3.25 + FLOAT(NDIG)
C
      IF(ISIDE.EQ.1) THEN
       JO = 1
       JP = 2
       KLO = 1
       KHI = II-1
      ELSE IF(ISIDE.EQ.2) THEN
       IO = II-1
       IP = II
       KLO = 1
       KHI = JJ-1
      ELSE IF(ISIDE.EQ.3) THEN
       JO = JJ-1
       JP = JJ
       KLO = 1
       KHI = II-1
      ELSE IF(ISIDE.EQ.4) THEN
       IO = 1
       IP = 2
       KLO = 1
       KHI = JJ-1
      ENDIF
C
C---- check domain edge specified by ISIDE if the contour touches it
      DO 10 K=KLO, KHI
C
        IF(ISIDE.EQ.1) THEN
         IO = K
         IP = K+1
        ELSE IF(ISIDE.EQ.2) THEN
         JO = K
         JP = K+1
        ELSE IF(ISIDE.EQ.3) THEN
         IO = K
         IP = K+1
        ELSE IF(ISIDE.EQ.4) THEN
         JO = K
         JP = K+1
        ENDIF
C
C------ flag indicating if contour crosses current cell
        LABEL = .FALSE.
C
C           op    3    pp
C
C           4           2
C
C           oo    1    po
C
        XOO = X(IO,JO)
        XOP = X(IO,JP)
        XPO = X(IP,JO)
        XPP = X(IP,JP)
C
        YOO = Y(IO,JO)
        YOP = Y(IO,JP)
        YPO = Y(IP,JO)
        YPP = Y(IP,JP)
C
        FOO = F(IO,JO)
        FOP = F(IO,JP)
        FPO = F(IP,JO)
        FPP = F(IP,JP)
C
C------ bottom edge (side 1)
        IF(FCON.GE.FOO .AND. FCON.LT.FPO .OR.
     &     FCON.LT.FOO .AND. FCON.GE.FPO     ) THEN
         IF(ISIDE.EQ.1) THEN
          XCON2 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
          YCON2 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
          YCON1 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
         ENDIF
        ENDIF
C
C------ left edge (side 4)
        IF(FCON.GE.FOO .AND. FCON.LT.FOP .OR.
     &     FCON.LT.FOO .AND. FCON.GE.FOP     ) THEN
         IF(ISIDE.EQ.4) THEN
          XCON2 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
          YCON2 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
          YCON1 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
         ENDIF
        ENDIF
C
C------ right edge (side 2)
        IF(FCON.GE.FPO .AND. FCON.LT.FPP .OR.
     &     FCON.LT.FPO .AND. FCON.GE.FPP     ) THEN
         IF(ISIDE.EQ.2) THEN
          XCON2 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
          YCON2 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
          YCON1 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
         ENDIF
        ENDIF
C
C------ top edge (side 3)
        IF(FCON.GE.FOP .AND. FCON.LT.FPP .OR.
     &     FCON.LT.FOP .AND. FCON.GE.FPP     ) THEN
         IF(ISIDE.EQ.3) THEN
          XCON2 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
          YCON2 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
          YCON1 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
         ENDIF
        ENDIF
C
        IF(LABEL) THEN
C
C------- a contour reaching the domain edge has been found - set coordinates
C        of contour on the cell edges
         X1 = XWT*XCON1
         X2 = XWT*XCON2
         Y1 = YWT*YCON1
         Y2 = YWT*YCON2
C
         DX = X2 - X1
         DY = Y2 - Y1
C
C------- contour angle
         ACON = ATAN2( DY , DX )
         SA = SIN(ACON)
         CA = COS(ACON)
C
C------- if contour points to the right ...
         IF(ABS(ACON) .LT. 0.5*PI) THEN
C
C-------- set angle and lower left coordinates of number
          ANUM = RTOD*ACON
          XN = X2 + CH*CA + 0.5*CH*SA
          YN = Y2 + CH*SA - 0.5*CH*CA
C
C------- if contour points to the left ...
         ELSE
C
C-------- add +/- 180 degrees to number angle to make it read right to left
          ANUM = RTOD*ACON - SIGN(180.0,ACON)
C
C-------- set lower left coordinates of number
          XN = X2 + CH*RDIG*CA - 0.5*CH*SA
          YN = Y2 + CH*RDIG*SA + 0.5*CH*CA
C
         ENDIF
C
C------- draw number
         CALL NUMBER(XN,YN,CH,FCON,ANUM,NDIG)
C
        ENDIF
C
   10 CONTINUE
C
      RETURN
      END ! CONLAB

      SUBROUTINE CONLABC(IX,JX,II,JJ,X,Y,F,FCON,CLAB,XWT,YWT,
     &           CH,NDIG,ISIDE)
      DIMENSION X(IX,JX), Y(IX,JX)
      DIMENSION F(IX,JX)
      CHARACTER*(*) CLAB
C---------------------------------------------------------------------
C     Puts numerical labels on the contour with value FCON at the
C     edge of the domain specified by ISIDE.  The number of digits
C     in the label(s) after the decimal point is given by NDIG.
C
C     Input:
C        IX JX     dimensions of arrays   X, Y, F
C        II JJ     array limits of arrays X, Y, F
C        X(i,j)    coordinates of grid point (i,j)
C        Y(i,j)
C        F(i,j)    function value at grid point (i,j)
C        FCON      value of F on the contour to be labeled
C        CLAB      label string
C        XWT YWT   plotting scale factors for X,Y:
C                       Xplot = X(i,j)*XWT
C                       Yplot = Y(i,j)*YWT
C        CH        absolute character height (no scaling is done)
C        NDIG      number of digits after decimal point in labels
C        ISIDE     domain side on which labels are to appear:
C
C           .     3     .
C
C           4           2
C
C           .     1     .
C
C
C     Output:      direct plotting calls using Versatec routines
C
C---------------------------------------------------------------------
      LOGICAL LABEL
C
      DATA PI, RTOD / 3.141592654, 57.2957795 /
C
C---- total number of digits + decimal point
      RDIG = 3.25 + FLOAT(NDIG)
C
      IF(ISIDE.EQ.1) THEN
       JO = 1
       JP = 2
       KLO = 1
       KHI = II-1
      ELSE IF(ISIDE.EQ.2) THEN
       IO = II-1
       IP = II
       KLO = 1
       KHI = JJ-1
      ELSE IF(ISIDE.EQ.3) THEN
       JO = JJ-1
       JP = JJ
       KLO = 1
       KHI = II-1
      ELSE IF(ISIDE.EQ.4) THEN
       IO = 1
       IP = 2
       KLO = 1
       KHI = JJ-1
      ENDIF
C
C---- check domain edge specified by ISIDE if the contour touches it
      DO 10 K=KLO, KHI
C
        IF(ISIDE.EQ.1) THEN
         IO = K
         IP = K+1
        ELSE IF(ISIDE.EQ.2) THEN
         JO = K
         JP = K+1
        ELSE IF(ISIDE.EQ.3) THEN
         IO = K
         IP = K+1
        ELSE IF(ISIDE.EQ.4) THEN
         JO = K
         JP = K+1
        ENDIF
C
C------ flag indicating if contour crosses current cell
        LABEL = .FALSE.
C
C           op    3    pp
C
C           4           2
C
C           oo    1    po
C
        XOO = X(IO,JO)
        XOP = X(IO,JP)
        XPO = X(IP,JO)
        XPP = X(IP,JP)
C
        YOO = Y(IO,JO)
        YOP = Y(IO,JP)
        YPO = Y(IP,JO)
        YPP = Y(IP,JP)
C
        FOO = F(IO,JO)
        FOP = F(IO,JP)
        FPO = F(IP,JO)
        FPP = F(IP,JP)
C
C------ bottom edge (side 1)
        IF(FCON.GE.FOO .AND. FCON.LT.FPO .OR.
     &     FCON.LT.FOO .AND. FCON.GE.FPO     ) THEN
         IF(ISIDE.EQ.1) THEN
          XCON2 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
          YCON2 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
          YCON1 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
         ENDIF
        ENDIF
C
C------ left edge (side 4)
        IF(FCON.GE.FOO .AND. FCON.LT.FOP .OR.
     &     FCON.LT.FOO .AND. FCON.GE.FOP     ) THEN
         IF(ISIDE.EQ.4) THEN
          XCON2 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
          YCON2 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
          YCON1 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
         ENDIF
        ENDIF
C
C------ right edge (side 2)
        IF(FCON.GE.FPO .AND. FCON.LT.FPP .OR.
     &     FCON.LT.FPO .AND. FCON.GE.FPP     ) THEN
         IF(ISIDE.EQ.2) THEN
          XCON2 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
          YCON2 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
          LABEL = .TRUE.
         ELSE
          XCON1 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
          YCON1 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
         ENDIF
        ENDIF
C
C------ top edge (side 3)
        IF(FCON.GE.FOP .AND. FCON.LT.FPP .OR.
     &     FCON.LT.FOP .AND. FCON.GE.FPP     ) THEN
         IF(ISIDE.EQ.3) THEN
          XCON2 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
          YCON2 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
          LABEL = .TRUE.
         ELSE
          XCON1 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
          YCON1 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
         ENDIF
        ENDIF
C
        IF(LABEL) THEN
C
C------- a contour reaching the domain edge has been found - set coordinates
C        of contour on the cell edges
         X1 = XWT*XCON1
         X2 = XWT*XCON2
         Y1 = YWT*YCON1
         Y2 = YWT*YCON2
C
         DX = X2 - X1
         DY = Y2 - Y1
C
C------- contour angle
         ACON = ATAN2( DY , DX )
         SA = SIN(ACON)
         CA = COS(ACON)
C
C------- if contour points to the right ...
         IF(ABS(ACON) .LT. 0.5*PI) THEN
C
C-------- set angle and lower left coordinates of number
          ANUM = RTOD*ACON
          XN = X2 + CH*CA + 0.5*CH*SA
          YN = Y2 + CH*SA - 0.5*CH*CA
C
C------- if contour points to the left ...
         ELSE
C
C-------- add +/- 180 degrees to number angle to make it read right to left
          ANUM = RTOD*ACON - SIGN(180.0,ACON)
C
C-------- set lower left coordinates of number
          XN = X2 + CH*RDIG*CA - 0.5*CH*SA
          YN = Y2 + CH*RDIG*SA + 0.5*CH*CA
C
         ENDIF
C
C------- draw number
         CALL PLCHAR(XN,YN,CH,CLAB,ANUM,-1)
C
        ENDIF
C
   10 CONTINUE
C
      RETURN
      END ! CONLABC


      SUBROUTINE CFEER (EED,METHOD,NFOUND)
C
C     PREVIOUS THIS ROUITNE IS CALLED CFCNTL
C
C     GIVEN REAL OR COMPLEX MATRICES, CFEER WILL SOLVE FOR THE
C     REQUESTED NUMBER OF EIGENVALUES AND EIGENVECTORS CLOSEST TO A
C     SPECIFIED POINT IN THE COMPLEX PLANE, FOR UP TO TEN POINTS,
C     VIA THE TRIDIAGONAL REDUCTION (FEER) METHOD.
C     THE SUBROUTINE NAME  CFEER  STANDS FOR COMPLEX FEER CONTROL.
C
C     DEFINITION OF INPUT AND OUTPUT PARAMETERS
C
C     IK(7)    = MATRIX CONTROL BLOCK FOR THE INPUT STIFFNESS MATRIX K
C     IM(7)    = MATRIX CONTROL BLOCK FOR THE INPUT MASS      MATRIX M
C     IB(7)    = MATRIX CONTROL BLOCK FOR THE INPUT DAMPING   MATRIX B
C     ILAM(7)  = MATRIX CONTROL BLOCK FOR THE OUTPUT EIGENVALUES
C     IPHI(7)  = MATRIX CONTROL BLOCK FOR THE OUTPUT EIGENVECTORS
C     IDMPFL   = FILE CONTAINING THE EIGENVALUE SUMMARY
C     ISCR(11) = SCRATCH FILES USED INTERNALLY
C     REG(1,I) = INPUT REAL      PART OF CENTER I (LAMBDA)
C     REG(2,I) = INPUT IMAGINARY PART OF CENTER I (LAMBDA)
C     REG(5,I) = PROBLEM SIZE MAXIMUM FOR SETTING QPR
C     REG(6,I) = SUPPRESSES ANY SPECIAL SYMMETRY LOGIC
C     REG(7,I) = NUMBER OF DESIRED ROOTS AROUND CENTER I
C     REG(8,1) = CONVERGENCE CRITERION (EQUIV. TO REG(1,2) TEMPORARILY)
C
      LOGICAL           NO B     ,SYMMET   ,QPR
      INTEGER           METHOD   ,EED      ,NAME(2)  ,IZ(1)     ,
     1                  EIGC(2)  ,WANT(10) ,HAVE(10)
      DOUBLE PRECISION  LAMBDA   ,EPS
      DIMENSION         IREG(7,1),IHEAD(10)
      CHARACTER         UFM*23   ,UWM*25   ,UIM*29
      COMMON  /XMSSG /  UFM      ,UWM      ,UIM
      COMMON  /FEERAA/  IK(7)    ,IM(7)    ,IB(7)    ,ILAM(7)   ,
     1                  IPHI(7)  ,IDMPFL   ,ISCR(11) ,REG(7,10) ,
     2                  MCBLT(7) ,MCBUT(7) ,MCBVEC(7),MCBLMB(7)
      COMMON  /FEERXC/  LAMBDA(2),SYMMET   ,MREDUC   ,NORD      ,
     1                  IDIAG    ,EPS      ,NORTHO   ,NORD2     ,
     2                  NORD4    ,NORDP1   ,NSWP     ,JSKIP     ,
     3                  NO B     ,IT       ,TEN2MT   ,TENMHT    ,
     4                  NSTART   ,QPR      ,JREG     ,NOREG     ,
     5                  NZERO    ,TENMTT   ,MINOPN   ,NUMORT    ,
     6                  NUMRAN
      COMMON  /ZZZZZZ/  Z(1)
      COMMON  /NAMES /  RD       ,RDREW    ,WRT      ,WRTREW    ,
     1                  REW      ,NOREW    ,EOFNRW   ,RSP       ,
     2                  RDP
      COMMON  /SYSTEM/  KSYSTM(65)
      COMMON  /OUTPUT/  HEAD(1)
      EQUIVALENCE       (IREG(1,1),REG(1,1)),(ANODES,NODES)     ,
     1                  (KSYSTM(2),NOUT)    ,(KSYSTM(40),NBPW)  ,
     2                  (ASYM,NONSYM)       ,(Z(1),IZ(1))
      DATA    EIGC   /  207,2/
      DATA    IHEAD  /  0,1009,2,7*0/
      DATA    NAME   /  4HCFCN,4HTL  /
C
C     FILE ALLOCATION
C
C     ISCR( 1)  CONTAINS  (LAMBDA**2*M + LAMBDA*B + K) = DYNAMIC MATRIX
C     ISCR( 2)  CONTAINS -(LAMBDA*M + B) = NOT REQUIRED WHEN B = 0
C     ISCR( 3)  CONTAINS LOWER TRIANGLE OF DECOMPOSED DYNAMIC MATRIX
C     ISCR( 4)  CONTAINS UPPER TRIANGLE OF DECOMPOSED DYNAMIC MATRIX
C     ISCR( 5)  CONTAINS REDUCED TRIDIAGONAL MATRIX ELEMENTS
C     ISCR( 6)  CONTAINS SPECIAL UPPER TRIANGLE FOR TRANSPOSED SWEEP
C     ISCR( 7)  CONTAINS THE ORTHOGONAL VECTORS
C     ISCR( 8)  CONTAINS OUTPUT EIGENVALUES , FOR INPUT TO CEAD1A
C     ISCR( 9)  CONTAINS OUTPUT EIGENVECTORS, FOR INPUT TO CEAD1A
C     ISCR(10)  SCRATCH FILE USED IN CFEER4
C     ISCR(11)  NOT USED
C
C     DEFINITION OF INTERNAL PARAMETERS
C
C     NODES  = NUMBER OF DESIRED ROOTS IN CURRENT NEIGHBORHOOD
C     EPS    = ACCURACY CRITERION - USED FOR REJECTING EIGENSOLUTIONS
C     NOREG  = TOTAL NUMBER OF CENTERS (NEIGHBORHOODS) INPUT,
C              EQUIVALENT TO THE NUMBER OF EIGC CONTINUATION CARDS
C     JREG   = COUNTER FOR CURRENT NEIGHBORHOOD
C     MREDUC = SIZE OF THE REDUCED PROBLEM IN CURRENT NEIGHBORHOOD
C     NFOUND = ACCUMULATED NUMBER OF ACCEPTABLE EIGENSOLUTIONS
C     NORD   = 2*N IF B.NE.0 AND = N IF B.EQ.0, WHERE B IS THE
C              DAMPING MATRIX AND N IS THE PROBLEM SIZE
C     NORD2  = VECTOR SIZE OF ORIGINAL PROBLEM (COMPLEX SINGLE
C              PRECISION OR COMPLEX DOUBLE PRECISION)
C     NSWP   = COMPLEX VECTOR SIZE FOR SWEEP ALGORITHM
C     NO B   = LOGICAL INDICATOR FOR ABSENCE OF DAMPING MATRIX B
C     SYMMET = LOGICAL INDICATOR FOR SYMMETRIC DYNAMIC MATRIX
C     NONSYM = PROGRAM INPUT WHICH FORCES THE PROGRAM TO CONSIDER
C              THE DYNAMIC MATRIX AS NON-SYMMETRIC
C     IT     = NUMBER OF DECIMAL DIGITS OF ACCURACY FOR THE COMPUTER
C     TEN2MT = 10**(2-T) CONVERGENCE CRITERION
C     TENMHT = 10**(-HALF*T) CONVERGENCE CRITERION
C     TENMTT = 10**(-THIRD*T) RIGID BODY ROOT CRITERION
C     NORTHO = TOTAL CURRENT NUMBER OF ORTHOGONAL VECTOR PAIRS ON
C              ORTHOGONAL VECTOR FILE. INITIALIZED TO NUMBER OF
C              EIGENVECTOR PAIRS ON THE RESTART FILE.
C     MINOPN = MINIMUM OPEN CORE NOT USED (WORDS)
C     NSTART = NUMBER OF INITIAL REORTHOGONALIZATION ATTEMPTS
C     IDIAG  = DIAG 12 PRINT CONTROL
C     QPR    = LOGICAL INDICATOR FOR VERY DETAILED PRINTOUT
C     WANT   = ARRAY OF DESIRED NUMBER OF ROOTS IN EACH NEIGHBORHOOD
C     HAVE   = ARRAY OF ACTUAL  NUMBER OF ROOTS IN EACH NEIGHBORHOOD
C
      NORTHO = 0
      NFOUND = NORTHO
      NZERO  = NORTHO
      JSKIP  = 0
      CALL SSWTCH (12,IDIAG)
C
C     TEST COMPUTING MACHINE TYPE AND SET PRECISION PARAMETERS
C
      IF (NBPW .GE. 60) GO TO 20
      IT = 8*KSYSTM(55)
      GO TO 21
   20 IT = 14*KSYSTM(55)
   21 TEN2MT = 10.**(2-IT)
      TENMHT = 10.**(-IT/2)
      TENMTT = 10.**(-IT/3)
      IK(1)  = 101
      CALL RDTRL (IK)
      IM(1)  = 103
      CALL RDTRL (IM)
      IB(1)  = 102
      CALL RDTRL (IB)
      IF (IB(1).LT.0 .OR. IB(6).EQ.0) IB(1) = 0
C
C     DETERMINE IF THE DYNAMIC MATRIX IS SYMMETRIC
C
      SYMMET = .FALSE.
      IF (IK(1).NE.0 .AND. IK(4).NE.6) GO TO 30
      IF (IM(1).NE.0 .AND. IM(4).NE.6) GO TO 30
      IF (IB(1).NE.0 .AND. IB(4).NE.6) GO TO 30
      SYMMET = .TRUE.
   30 DO 40 I = 1,11
   40 ISCR(I)= 300+I
      IDMPFL = 203
      NZ     = KORSZ(Z)
      IBUF   = NZ - KSYSTM(1) - 2
      LIMSUM = 12
      IOPN   = IBUF - LIMSUM
      IF (IDIAG .NE. 0) WRITE (NOUT,600) IOPN
      IF (IOPN  .LE. 0) CALL MESAGE (-8,0,NAME)
      MINOPN = IOPN
      ILAM(1)= 308
      IPHI(1)= 309
      IFILE  = ILAM(1)
      CALL OPEN (*500,ILAM,Z(IBUF),WRTREW)
      CALL CLOSE (ILAM,REW)
      IFILE  = IPHI(1)
      CALL OPEN (*500,IPHI,Z(IBUF),WRTREW)
      CALL CLOSE (IPHI,REW)
      CALL GOPEN (IDMPFL,Z(IBUF),WRTREW)
      CALL CLOSE (IDMPFL,EOFNRW)
C
C     PROCURE DATA FROM MAIN EIGC CARD
C
      IFILE = EED
      CALL PRELOC (*500,Z(IBUF),EED)
      CALL LOCATE (*500,Z(IBUF),EIGC(1),FLAG)
   50 CALL FREAD (EED,IREG,10,0)
      IF (IREG(1,1) .EQ. METHOD) GO TO 70
   60 CALL FREAD (EED,IREG,7,0)
      IF (IREG(6,1) .NE. -1) GO TO 60
      GO TO 50
   70 JREG  = 1
      EPS   =.1D0/IK(2)/100.D0
      IF (REG(1,2) .GT. 0.) EPS = DBLE(REG(1,2))/100.D0
      UNIDUM= SNGL(EPS)*100.
      IF (IDIAG .NE. 0) WRITE (NOUT,75) UNIDUM,REG(1,2)
   75 FORMAT (1H0,5HCFEER,6X,18HACCURACY CRITERION,1P,E16.8,
     2        8X,12H(INPUT VALUE,E16.8,1H))
C
C     PROCURE DATA FROM EIGC CONTINUATION CARDS
C
   80 CALL FREAD (EED,IREG(1,JREG),7,0)
      IF (IREG(6,JREG) .EQ. -1) GO TO 90
      JREG  = JREG + 1
      IF (JREG .GT. 10) GO TO 90
      GO TO 80
   90 CALL CLOSE (EED,REW)
      NOREG  = JREG - 1
      NODCMP = 0
      NUMORT = 0
      NUMRAN = 0
      JREG   = 0
C
C     PICK UP PARAMETERS FOR NEIGHBORHOOD I
C
  100 JREG = JREG + 1
      IF (JREG .LE. NOREG) GO TO 105
      JREG = NOREG
      IF (NZERO .GT. 0) JSKIP = -1
      GO TO 175
  105 X1 = REG(1,JREG)
      Y1 = REG(2,JREG)
      ANODES = REG(7,JREG)
      ASYM   = REG(6,JREG)
      IF (NONSYM .NE. 0) SYMMET = .FALSE.
      NPRINT = IFIX(REG(5,JREG))
      QPR = .FALSE.
      IF (IDIAG.NE.0 .AND. NPRINT.GE.IK(2)) QPR = .TRUE.
      IF (IDIAG .NE. 0) WRITE (NOUT,110) JREG,X1,Y1,NODES,NONSYM
  110 FORMAT (1H0,5HCFEER,6X,12HNEIGHBORHOOD,I3,8X,8HCENTER =,2F18.8,
     1        8X,15HNO. DES. RTS. =,I5,8X,8HNONSYM =,I2/1H )
C
C     TEST IF USER PICKED THE ORIGIN
C
      IF (X1.NE.0. .OR. Y1.NE.0.) GO TO 120
      X1 = X1 + .001
      WRITE (NOUT,601) UWM
  120 IF (NODES .GT. 0) GO TO 130
      WRITE (NOUT,602) UWM,NODES
      NODES = 1
  130 WANT(JREG) = NODES
      HAVE(JREG) = 0
      NORD  = 2*IK(2)
      NO B  = .FALSE.
      IF (IB(1) .GT. 0) GO TO 140
      NO B  = .TRUE.
      NORD  = IK(2)
  140 NSWP  = IK(2)
      NORD2 = 2*NORD
      NORD4 = 2*NORD2
      NORDP1= NORD + 1
      MREDUC= 2*NODES + 10
      NOMNF = NORD - NFOUND
      IF (MREDUC .GT. NOMNF) MREDUC = NOMNF
      LAMBDA(1) = X1
      LAMBDA(2) = Y1
      IF (NODES .GT. NORD) WRITE (NOUT,606) UWM,NODES,JREG,NOREG,LAMBDA,
     1                                      NORD
      ISING = 0
C
C      FORM (LAMBDA**2*M + LAMBDA*B + K) = THE DYNAMIC MATRIX
C
  150 CALL CFEER1
C
C     CALL IN CDCOMP TO DECOMPOSE THE DYNAMIC MATRIX
C
      NODCMP = NODCMP + 1
      CALL CFEER2 (IRET)
      IF (IRET .NE. 0) GO TO 160
      GO TO 170
  160 IRET = IRET + ISING
      WRITE (NOUT,603) UWM,IRET,LAMBDA
      IF (ISING .EQ. 1) GO TO 100
C
C     SINGULAR MATRIX. INCREMENT LAMBDA AND TRY ONCE MORE.
C
      ISING = 1
      LAMBDA(1) = LAMBDA(1) + .02D0
      LAMBDA(2) = LAMBDA(2) + .02D0
      GO TO 150
C
C     CALL IN DRIVER TO GENERATE REDUCED TRIDIAGONAL MATRIX
C
  170 CALL CFEER3
      IF (NSTART .GT. 2) GO TO 100
C
C     OBTAIN EIGENVALUES AND EIGENVECTORS
C
      CALL CFEER4
      HAVE(JREG) = MREDUC
      IF (MREDUC .LE. NODES) GO TO 180
      I = MREDUC - NODES
      WRITE (NOUT,607) UIM,I,NODES,JREG,NOREG,LAMBDA
  180 NFOUND = NFOUND + MREDUC
      IF (JREG.LT.NOREG .AND. NFOUND.LT.NORD) GO TO 100
C
C     FEER IS FINISHED. PERFORM WRAP-UP OPERATIONS.
C
  175 IF (JSKIP  .LT. 0) CALL CFEER4
      IF (NFOUND .EQ. 0) GO TO 250
      IF (NFOUND .GE. NORD) GO TO 220
  200 DO 210 I = 1,JREG
      IF (HAVE(I) .LT. WANT(I)) GO TO 240
  210 CONTINUE
      GO TO 230
C
C     ALL SOLUTIONS FOUND
C
  220 WRITE (NOUT,604) UIM
      IF (JREG .LT. NOREG) GO TO 240
      GO TO 200
C
C     EACH REQUESTED NEIGHBORHOOD HAS THE DESIRED NUMBER OF ROOTS
C
  230 ITERM = 0
      GO TO 260
C
C     AT LEAST ONE REQUESTED NEIGHBORHOOD FAILS TO HAVE THE DESIRED
C     NUMBER OF ROOTS
C
  240 ITERM = 1
      GO TO 260
C
C     ABNORMAL TERMINATION. NO ROOTS FOUND.
C
  250 ITERM = 2
C
C     WRITE INFORMATION ON NASTRAN SUMMARY FILE
C
  260 IFILE = IDMPFL
      CALL OPEN (*500,IDMPFL,Z(IBUF),WRT)
      DO 270 I = 1,LIMSUM
  270 IZ(I) = 0
      I = 0
      IZ(I+2) = NORTHO
      IZ(I+3) = NUMRAN
      IZ(I+5) = NODCMP
      IZ(I+6) = NUMORT
      IZ(I+7) = ITERM
      IZ(I+8) = 1
      I = 2
      CALL WRITE (IDMPFL,IHEAD(1),10,0)
      CALL WRITE (IDMPFL,IZ(I),40,0)
      CALL WRITE (IDMPFL,HEAD(1),96,1)
      CALL WRITE (IDMPFL,IZ(1),0,1)
      CALL CLOSE (IDMPFL,EOFNRW)
C
C     WRITE DUMMY TRAILER
C
      IXX   = IK(1)
      IK(1) = IDMPFL
      CALL WRTTRL (IK(1))
      IK(1) = IXX
C
C     INFORM USER IF RUN REGION SIZE CAN BE REDUCED
C
      IF (NBPW-36) 300,310,320
  300 I = 4
      GO TO 330
  310 I = 6
      GO TO 330
  320 I = 10
      IF (NBPW .EQ. 64) I = 8
  330 I = (I*MINOPN)/1000
      IF (I .LT. 0) I = 0
      WRITE (NOUT,605) UIM,MINOPN,I
      RETURN
C
  500 CALL MESAGE (-1,IFILE,NAME)
      RETURN
C
C
  600 FORMAT (1H1,27X,'*****  F E E R  *****  (FAST EIGENVALUE',
     1        ' EXTRACTION ROUTINE)  *****',  ////,1H ,I10,' SINGLE ',
     2        'PRECISION WORDS OF OPEN CORE, NOT USED (SUBROUTINE ',
     3        'CFEER)', //)
  601 FORMAT (A25,' 3149',//5X,'USER SPECIFIED NEIGHBORHOOD CENTERED AT'
     1,      ' ORIGIN NOT ALLOWED, CENTER SHIFTED TO THE RIGHT .001',//)
  602 FORMAT (A25,' 3150',//5X,'DESIRED NUMBER OF EIGENVALUES',I8,3X,
     1       'INVALID. SET = 1.',//)
  603 FORMAT (A25,' 3151',//5X,'DYNAMIC MATRIX IS SINGULAR (OCCURRENCE',
     1       I3,') IN NEIGHBORHOOD CENTERED AT ',1P,2D16.8,//)
  604 FORMAT (A29,' 3159',//5X,'ALL SOLUTIONS HAVE BEEN FOUND.',//)
  605 FORMAT (A29,' 3160',//5X,'MINIMUM OPEN CORE NOT USED BY FEER',I9,
     1       ' WORDS (',I9,'K BYTES).',//)
  606 FORMAT (A25,' 3161',//5X,'DESIRED NUMBER OF EIGENSOLUTIONS',I5,
     1       ' FOR NEIGHBORHOOD',I3,' OF',I3,' CENTERED AT ',1P,2D16.8,
     2       //5X,'EXCEEDS THE EXISTING NUMBER',I5,
     3       ', ALL EIGENSOLUTIONS WILL BE SOUGHT.',//)
  607 FORMAT (A29,' 3166',//1X,I5,' MORE ACCURATE EIGENSOLUTIONS THAN ',
     1       'THE',I5,' REQUESTED HAVE BEEN FOUND FOR NEIGHBORHOOD',I3,
     2       ' OF',I3, //5X,'CENTERED AT ',1P,2D16.8,
     3       '. USE DIAG 12 TO DETERMINE ERROR ESTIMATES.',//)
      END


      double precision function t(j1,j2,j3)
      implicit none
      include 'constants.f'
      include 'sprods_com.f'
      integer j1,j2,j3
      t=s(j1,j2)+s(j2,j3)+s(j1,j3)
      end


SUBROUTINE Atmosphere(alt, sigma, delta, theta)
!   -------------------------------------------------------------------------
! PURPOSE - Compute the properties of the 1976 standard atmosphere to 86 km.
! AUTHOR - Ralph Carmichael, Public Domain Aeronautical Software
! NOTE - If alt > 86, the values returned will not be correct, but they will
!   not be too far removed from the correct values for density.
!   The reference document does not use the terms pressure and temperature
!   above 86 km.
  IMPLICIT NONE
!============================================================================
!     A R G U M E N T S                                                     |
!============================================================================
  REAL,INTENT(IN)::  alt        ! geometric altitude, km.
  REAL,INTENT(OUT):: sigma      ! density/sea-level standard density
  REAL,INTENT(OUT):: delta      ! pressure/sea-level standard pressure
  REAL,INTENT(OUT):: theta      ! temperature/sea-level standard temperature
!============================================================================
!     L O C A L   C O N S T A N T S                                         |
!============================================================================
  REAL,PARAMETER:: REARTH = 6369.0                 ! radius of the Earth (km)
  REAL,PARAMETER:: GMR = 34.163195                             ! gas constant
  INTEGER,PARAMETER:: NTAB=8       ! number of entries in the defining tables
!============================================================================
!     L O C A L   V A R I A B L E S                                         |
!============================================================================
  INTEGER:: i,j,k                                                  ! counters
  REAL:: h                                       ! geopotential altitude (km)
  REAL:: tgrad, tbase      ! temperature gradient and base temp of this layer
  REAL:: tlocal                                           ! local temperature
  REAL:: deltah                             ! height above base of this layer
!============================================================================
!     L O C A L   A R R A Y S   ( 1 9 7 6   S T D.  A T M O S P H E R E )   |
!============================================================================
  REAL,DIMENSION(NTAB),PARAMETER:: htab= &
                          (/0.0, 11.0, 20.0, 32.0, 47.0, 51.0, 71.0, 84.852/)
  REAL,DIMENSION(NTAB),PARAMETER:: ttab= &
          (/288.15, 216.65, 216.65, 228.65, 270.65, 270.65, 214.65, 186.946/)
  REAL,DIMENSION(NTAB),PARAMETER:: ptab= &
               (/1.0, 2.233611E-1, 5.403295E-2, 8.5666784E-3, 1.0945601E-3, &
                                     6.6063531E-4, 3.9046834E-5, 3.68501E-6/)
  REAL,DIMENSION(NTAB),PARAMETER:: gtab= &
                                (/-6.5, 0.0, 1.0, 2.8, 0.0, -2.8, -2.0, 0.0/)
!----------------------------------------------------------------------------
  h=alt*REARTH/(alt+REARTH)      ! convert geometric to geopotential altitude

  i=1
  j=NTAB                                       ! setting up for binary search
  DO
    k=(i+j)/2                                              ! integer division
    IF (h < htab(k)) THEN
      j=k
    ELSE
      i=k
    END IF
    IF (j <= i+1) EXIT
  END DO

  tgrad=gtab(i)                                     ! i will be in 1...NTAB-1
  tbase=ttab(i)
  deltah=h-htab(i)
  tlocal=tbase+tgrad*deltah
  theta=tlocal/ttab(1)                                    ! temperature ratio

  IF (tgrad == 0.0) THEN                                     ! pressure ratio
    delta=ptab(i)*EXP(-GMR*deltah/tbase)
  ELSE
    delta=ptab(i)*(tbase/tlocal)**(GMR/tgrad)
  END IF

  sigma=delta/theta                                           ! density ratio
  RETURN
END Subroutine Atmosphere   ! -----------------------------------------------


      MODULE PRIMEBAG	!Need prime numbers? Plenty are available.
C   Creates and expands a disc file for a sieve of Eratoshenes, representing odd numbers only and starting with three.
C   Storage requirements: an array of N prime numbers in 16/32/64 bits vs. a bit array up to the 16/32/64 bit limit.
C Word size               N            Prime   N words in bits           Bit array in bits.
C     8 bit            P(31) =           127               248                         128
C                      P(54) =           251               432                         256
C    16 bit         P(3,512) =        32,749            56,192                      32,768
C                   P(6,542) =        65,521           104,672                      65,536
C    32 bit   P(105,097,565) = 2,147,483,647     3,363,122,080               2,147,483,648
C             P(203,280,221) = 4,294,967,291     6,504,967,072               4,294,967,296
C    64 bit        2.112E17                ?          1.352E19   9,223,372,036,854,775,808 ~ 9.22E18
C from n/Ln(n)     4.158E17                ?          2.661E19  18,446,744,073,709,551,616 ~ 1.84E19
       INTEGER MSG	!I/O unit number.
       INTEGER SSTASH	!For attachment to my stash file.
       INTEGER SRECLEN,SCHARS,SBITS	!Sizes.
       INTEGER SORG	!Where the sieve starts. This must be three.
       INTEGER SLAST	!Last record in my stash file.
       DATA SSTASH,SREC,SLAST/0,0,0/	!Prepared by PRIMEBAG.
       PARAMETER (SRECLEN = 1024)	!4K disc bloc size, but RECL (in OPEN) is in terms of four-byte integers.
       PARAMETER (SCHARS = (SRECLEN - 1)*4)	!Reserving space for one number at the start.
       PARAMETER (SBITS = SCHARS*8)	!Known size of a character.
       PARAMETER (SORG = 3)		!First odd number past two, which is not odd.
       CHARACTER*(*) SFILE		!A name is needed.
       PARAMETER (SFILE = "C:/Nicky/RosettaCode/Primes/PrimeSieve.bit")	!I don't have to count the characters.
Components of a buffered record for the stash.
       INTEGER SREC	!The record number.
       CHARACTER*1 C4(4)	!The start of the record - a counter.
       CHARACTER*1 SCHAR(0:SCHARS - 1)	!The majority of the record - a bit array, packed in 8-bit blobs...
Collect some bit twiddling assistants for AND and OR, rather than bit shifting.
       CHARACTER*1 BITON(0:7),BITOFF(0:7)	!Functions IBSET and IBCLR may not be available, and are little-endian anyway.
       PARAMETER (BITON =(/CHAR(2#10000000),CHAR(2#01000000),	!128,  64,	Reading strictly left-to-right.
     1                     CHAR(2#00100000),CHAR(2#00010000),	! 32,  16,	Uncompromising bigendery.
     1                     CHAR(2#00001000),CHAR(2#00000100),	!  8,   4,	Not just for bytes in words,
     3                     CHAR(2#00000010),CHAR(2#00000001)/))	!  2,   1.	But also bits in bytes.
       PARAMETER (BITOFF=(/CHAR(2#01111111),CHAR(2#10111111),	!127, 191,	BITON + BITOFF = 255.
     2                     CHAR(2#11011111),CHAR(2#11101111),	!223, 239,
     1                     CHAR(2#11110111),CHAR(2#11111011),	!247, 251,
     3                     CHAR(2#11111101),CHAR(2#11111110)/))	!253, 254.
       CONTAINS
        INTEGER FUNCTION I4UNPACK(C4)	!Convert four successive characters into an integer.
         CHARACTER*1 C4(4)	!The characters.
          I4UNPACK = ((ICHAR(C4(1))*256 + ICHAR(C4(2)))*256	!Convert the first four bytes
     1               + ICHAR(C4(3)))*256 + ICHAR(C4(4))		!To a four-byte integer.
        END FUNCTION I4UNPACK	!Big-endian style, irrespective of cpu endianness.
        SUBROUTINE C4PACK(I4)	!Convert an integer into successive bytes.
Could return the result via a fancy function, but for now a global variable will do.
         INTEGER I4,N	!The integer, and a copy to damage.
         INTEGER I	!A stepper.
          N = I4	!Keep the original safe.
          DO I = 4,1,-1	!Know that four characters will do. Fixed format makes this easy.
            C4(I) = CHAR(MOD(N,256))	!Grab the low-order eight bits.
            N = N/256			!And shift right eight.
          END DO			!Do it again.
        END SUBROUTINE C4PACK	!Stored big-endianly, irrespective of cpu endianness.

        LOGICAL FUNCTION GRASPPRIMEBAG(F)
         INTEGER F		!The I/O unit number to use.
         LOGICAL EXIST		!Use the keyword as a name
         INTEGER IOSTAT		!And don't worry over assignment direction.
         CHARACTER*3 STYLE	!One way or another.
          SSTASH = F		!I shall use it.
          INQUIRE (FILE = SFILE,EXIST = EXIST)	!Trouble with a missing "path" may arise.
          IF (EXIST) THEN	!If the file exists,
            STYLE = "OLD"	!I shall read it.
           ELSE			!But if it doesn't,
            STYLE = "NEW"	!I shall create it.
          END IF		!Enough prevarication.
          OPEN(SSTASH,FILE = SFILE, STATUS = STYLE,	!Go for the file.
     &     ACCESS = "DIRECT", RECL = SRECLEN, FORM = "UNFORMATTED",	!I have plans.
     &     ERR = 666, IOSTAT = IOSTAT)					!Which may be thwarted.
          IF (EXIST) THEN	!If there is one...
            CALL READSCHAR(1)	!The first record is also a header.
            SLAST = I4UNPACK(C4)	!The number of records stored.
           ELSE			!Otherwise, start from scratch.
            SLAST = 0			!No saved records.
            CALL PSURGE(SCHAR)		!During preparation of the first batch of bits.
          END IF		!All should now be in readiness.
          GRASPPRIMEBAG = .TRUE.!So, feel confidence.
         RETURN			!And escape.
  666     WRITE (*,667) IOSTAT,SFILE	!But, something may have gone wrong.
  667     FORMAT ("Pox! Error code ",I0,	!A "hole" in the directory path?
     1     " when attempting to open file ",A)	!Read-only access allowed when I want "update"?
          GRASPPRIMEBAG = .FALSE.		!Whatever, it didn't work.
        END FUNCTION GRASPPRIMEBAG	!So much for that.

        SUBROUTINE READSCHAR(R)	!Get record R into SCHAR, which may already hold it.
         INTEGER R		!The record number desired.
          IF (R.EQ.SREC) RETURN	!Perhaps it is already to hand.
          SREC = R		!If not, move attention to it.
          READ (SSTASH,REC = SREC) C4,SCHAR	!And read the record.
        END SUBROUTINE READSCHAR!Thus, I have a buffer too.

        LOGICAL FUNCTION PSURGE(BIT8)	!Add another record to the stash.
C   Surges forward into the next batch of primes, to be stored via a bit array in the file.
C   Each record starts with a count of the number of primes that have gone before.
C   Except that for the first record, this is the record counter for the stash file.
C   Except that when starting the second record, one is also the number of primes before SORG.
         CHARACTER*1 BIT8(0:SCHARS - 1)	!Watch out! This may be SCHAR itself!
         INTEGER IST,LST	!The numbers spanned by the surge.
         INTEGER F		!A factor.
         INTEGER I		!Another factor and a stepper.
         INTEGER C		!Index for array BIT8.
         INTEGER NP		!Number of primes.
Carry forward the count of previous primes to start the following record..
   10     IF (SLAST.GT.0) THEN	!Is there a previous record?
            CALL READSCHAR(SLAST)	!Yes. Grab it. A good chance this is already in C4,SCHAR.
            NP = I4UNPACK(C4)		!Its count of the primes accumulated before it.
            DO I = 0,SCHARS - 1		!Find out how namy primes it fingered by scanning its bits.
              NP = NP + COUNT(IAND(ICHAR(SCHAR(I)),ICHAR(BITON)).NE.0)	!Whee! Eight at a go!
            END DO			!On to the next byte.
          END IF		!When creating a new record, its follower may not be sought in this run.
Concoct the next batch of bits. Contorted calculations avoid integer overflow.
   20     BIT8 = CHAR(255)		!All bits are aligned with numbers that might prove to be prime.
          IST = SORG + SLAST*(2*SBITS)	!Bit(0) of BIT8(0) corresponds to IST.
          LST = IST + 2*(SBITS - 1)	!Bit(last) to this number. Remember, only odd numbers have bits.
          IF (IST.LE.0) THEN		!Humm. I'd better check.
            WRITE (MSG,21) SLAST,IST,LST	!This works only with two's complement integers.
   21       FORMAT (/,"Integer overflow in the sieve of Eratosthenes!",	!Oh dear.
     1      /,"Advancing from surge ",I0," to span ",I0," to ",I0)	!These numbers will look odd.
            PSURGE = .FALSE.			!But it is better than no indication of what went wrong.
           RETURN			!Give in.
          END IF		!Enough worrying.
          F = 3			!The first possible factor. Zapping will start at F²
c         DO WHILE(F.LE.LST/F)	!If F² is past the end, so will be still larger F: enough.
          DO WHILE(F.LE.IST/F + (MOD(IST,F) + 2*(SBITS - 1))/F)	!"Synthetic division" avoiding overflow.
            I = (IST - 1)/F + 1		!I want the first multiple of F in IST:LST. F may be a factor of IST.
            IF (MOD(I,2).EQ.0) I = I + 1!If even, advance to the next odd multiple. Even numbers are omitted by design.
            IF (I.LT.F) I = F		!Less than F is superfluous: the position was zapped by earlier action.
c           I = (I*F - IST)/2			!Current bit positions are for IST, IST+2, IST+4, etc.
            I = ((I - IST/F)*F - MOD(IST,F))/2	!Avoids overflow when calculating the start value, I*F.
            DO I = I,SBITS - 1,F	!Zap every F'th bit along. This is the sieve of Eratosthenes.
              C = I/8				!Eight bits per character.
              BIT8(C) = CHAR(IAND(ICHAR(BIT8(C)),	!For F = 3 and 5, characters will be hit more than once.
     1                            ICHAR(BITOFF(MOD(I,8)))))	!Whack a bit. All the above just for this!
            END DO			!On to the next bit.
   22       F = NEXTPRIME(F)		!So much for F. Next, please.
          END DO		!Are we there yet?
Correct the count in the header, if this is an added record.
   30     IF (SLAST.GT.0) THEN	!So, was there a pre-existing header record?
            CALL READSCHAR(1)		!Yes. Get the header record into C4,SCHAR.
            CALL C4PACK(SLAST + 1)	!This is the new record count.
            WRITE (SSTASH,REC = 1) C4,SCHAR	!Write it all back.
            SCHAR = BIT8	!Ensure that SCHAR and SREC will be agreed.
          END IF		!So much for the header's count.
Cast the bits into the stash by writing record SLAST + 1..
   40     IF (SLAST.EQ.0) THEN	!If we're writing the first record,
            CALL C4PACK(1)		!Then this is the record count.
           ELSE			!Otherwise,
            CALL C4PACK(NP)		!Place the previous primes count.
          END IF		!All this to help PRIME(i).
          SLAST = SLAST + 1	!This is now the last stashed record.
          WRITE (SSTASH,REC = SLAST) C4,BIT8	!I/O directly from the work area?
          SREC = SLAST		!This is where BIT8 was written.
          PSURGE = .TRUE.	!That assumes BIT8 is not SCHAR for SLAST > 1.
        END FUNCTION PSURGE	!That was fun!

        RECURSIVE SUBROUTINE GETSREC(R)	!Make present the bit array belonging to record R.
         INTEGER R		!The record number..
         CHARACTER*1 BIT8(0:SCHARS - 1)	!A scratchpad. Others may be relying on SCHAR.
          IF (SLAST.LE.0) RETURN!DANGER! The first record is being initialised!
          DO WHILE(SLAST.LT.R)	!If we haven't reached so far,
            IF (.NOT.PSURGE(BIT8)) THEN	!Slog forwards one record's worth.
              WRITE (MSG,1) R			!Or maybe not.
    1         FORMAT ("Cannot prepare surge ",I0)	!Explain.
              STOP "No bits, no go."			!And quit.
            END IF			!And having prepared the next block of bits,
          END DO		!Check afresh.
          CALL READSCHAR(R)	!Read the desired record's bits.
        END SUBROUTINE GETSREC	!Done.

        INTEGER FUNCTION PRIME(N)	!P(1) = 2, P(2) = 3, etc.
C   Calculate P(n) ~ n.ln(n)
C                  ~ n{ln(n) + ln(ln(n)) - 1 + (ln(ln(n)) - 2)/ln(n) - [ln(ln(n))**2 - 6*log(log(n)) + 11]/[2*(ln(n))**2] + ....}
C   J.B.Rosser's 1938 Theorem: n[ln(n) + ln(ln(n)) - 1] < P(n) < n[ln(n) + ln(ln(n))]
C    or, with E = ln(n) + ln(ln(n)),           n[E - 1] < P(n) < n[E]
C   Experimentation shows that the undershoot of the first two terms involves many records worth of bits.
C   Including additional terms does much better, but can overshoot.
         INTEGER N		!The desired one.
         INTEGER R,NP		!Counts.
         INTEGER B,C		!Bit and character indices.
         DOUBLE PRECISION EST,LN,LLN	!Hope, if not actuality.
          IF (N.LE.0) STOP "Primes are counted positively!"	!Something must be wrong!
          IF (N.LE.1) THEN	!The start of the bit array being preempted.
            PRIME = 2			!So, no array access.
           ELSE			!Otherwise, the fun begins.
            LN = LOG(DFLOAT(N))	!Here we go.
            LLN = LOG(LN)	!A popular term.
            EST = N*(LN		!Estimate the value of the N'th prime.
     1               + LLN - 1		!Second term
     2               + (LLN - 2)/LN		!Third term.
     3               - (LLN**2 - 6*LLN + 11)/(2*LN**2))	!Fourth term.
            R = (EST - SORG)/(2*SBITS) + 1	!Thereby selecting a record to scan.
            IF (R.LE.0) R = 1			!And not making a mess with N < 6 or so.
    9       CALL GETSREC(R)	!Go for the record.
            IF (R.LE.1) THEN	!The first record starts with the record count.
              NP = 1		!And I know how many primes precede its start point
             ELSE		!While for all subsequent records,
              NP = I4UNPACK(C4)	!This counts the number of primes that precede record R's start number.
            END IF		!So now I'm ready to count onwards.
            IF (N.LE.NP) THEN	!Maybe not.
              R = R - 1			!The estimate took me too far ahead.
              GO TO 9			!Try again.
            END IF		!Could escalate to a binary search or even an interpolating search.
Commence scanning the bits.
            C = 0		!Start with the first character of SREC..
            B = -1		!Syncopation. The formula is known to always under-estimate.
   10       IF (NP.LT.N) THEN	!Are we there yet?
   11         B = B + 1			!No. Advance to the next bit.
              IF (B.GE.8) THEN		!Overflowed a character yet?
                B = 0			!Yes. Start afresh at the first bit.
                C = C + 1		!And advance one character.
                IF (C.GE.SCHARS) THEN	!Overflowed the record yet?
                  C = 0			!Yes. Start afresh at its first character.
                  R = R + 1		!And advance to the next record.
                  CALL GETSREC(R)	!Possibly, create it.
                END IF			!So much for records.
              END IF			!We're now ready to test bit B of character C of record R.
              IF (IAND(ICHAR(SCHAR(C)),ICHAR(BITON(B))).EQ.0) GO TO 11	!Not a prime. Search on.
              NP = NP + 1		!Count another prime.
              GO TO 10			!Pehaps this will be the one.
            END IF		!So much for the search.
            PRIME = SORG + (R - 1)*(2*SBITS) + (C*8 + B)*2	!The corresponding number.
            IF (PRIME.LE.0) WRITE (MSG,666) N,PRIME	!Or, possibly not.
  666       FORMAT ("Integer overflow! Prime(",I0,") gives ",I0,"!")	!Let us hope the caller notices.
          END IF		!So, all going well,
        END FUNCTION PRIME	!It is found.

        RECURSIVE INTEGER FUNCTION NEXTPRIME(N)	!Keep right on to the end of the road.
Can invoke GETSREC, which can invoke PSURGE, which ... invokes NEXTPRIME. Oh dear.
         INTEGER N	!Not necessarily itself a prime number.
         INTEGER NN	!A value to work with.
         INTEGER R	!A record number into the stash.
         INTEGER I,IST	!Number offsets.
         INTEGER C,B	!Character and bit index.
          IF (N.LE.1) THEN	!Suspicion prevails.
            NN = 2			!This is not represented in my bit array.
           ELSE			!Otherwise, the fun begins.
            NN = N + 1			!Advance, with a copy I can mess with.
            IF (MOD(NN,2).EQ.0) NN = NN + 1	!Thus, NN is now odd.
            IF (NN.LE.0) GO TO 666		!But perhaps not proper, due to overflow.
            R = (NN - SORG)/(2*SBITS)		!SORG is odd, so (NN - SORG) is even.
            CALL GETSREC(R + 1)		!The first record is numbered one, not zero.
            IST = SORG + R*(2*SBITS)	!The number for its first bit: even numbers are omitted..
            I = (NN - IST)/2		!Offset into the record. NN - IST is even.
            C = I/8			!Which character in SCHAR(0:SCHARS - 1)?
            B = MOD(I,8)		!Which bit in SCHAR(C)?
   10       IF (IAND(ICHAR(SCHAR(C)),ICHAR(BITON(B))).EQ.0) THEN	!On for a prime.
              NN = NN + 2	!Alas, it is off, so NN is not a prime. Perhaps this will be.
              B = B + 1		!Advance one bit. Each bit steps two.
              IF (B.GE.8) THEN	!Past the end of the character?
                B = 0			!Yes. Back to bit zero.
                C = C + 1		!And advance one chracter.
                IF (C.GE.SCHARS) THEN	!Past the end of the record?
                  IF (NN.LE.0) GO TO 666!Yes. If NN has overflowed, the end of the rope is reached.
                  C = 0			!Back to the start of a record.
                  R = R + 1		!Advance one record.
                  CALL GETSREC(R + 1)	!And read it. (Count is from 1, not 0).
                END IF		!So much for overflowing a record.
              END IF		!So much for overflowing a character.
              GO TO 10	!Try again.
            END IF		!So much for the bit array.
          END IF		!If there had been a scan.
          NEXTPRIME = NN	!The number for which the scan stopped.
          IF (NN.GT.0) RETURN	!All is well.
  666     WRITE (MSG,667) N,NN	!Or, maybe not. Careful: this won't appear if NEXTPRIME is invoked in a WRITE list.
  667     FORMAT ("Integer overflow! NextPrime(",I0,") gives ",I0,"!")	!The recipient could do a two's complement.
          NEXTPRIME = NN	!Prefer to return the bad value rather than fail to return anything.
        END FUNCTION NEXTPRIME	!No divisions, no sieving. Here, anyway

        INTEGER FUNCTION PREVIOUSPRIME(N)	!If N is good, this can't overflow.
         INTEGER N	!The number, not necessarily a prime.
         INTEGER NN	!A value to mess with.
         INTEGER R	!A record number.
         INTEGER I	!Offset.
         INTEGER C,B	!Character and bit fingers.
          IF (N.LE.3) THEN	!Suppress annoyances.
            NN = 2		!This is now called the first prime, not one.
           ELSE			!Otherwise, some work is to be done.
            NN = N - 1			!Step back one to ensure previousness.
            IF (MOD(NN,2).EQ.0) NN = NN - 1	!And here, oddness is a minimal requirement.
            R = (NN - SORG)/(2*SBITS)	!Finger the record containing the bit for NN.
            CALL GETSREC(R + 1)		!Record counting starts with one.
            I = (NN - (SORG + R*(2*SBITS)))/2	!Offset into that record.
            C = I/8			!Finger the character in SCHAR.
            B = MOD(I,8)		!And the bit within the character.
   10       IF (IAND(ICHAR(SCHAR(C)),ICHAR(BITON(B))).EQ.0) THEN	!On for a prime.
              NN = NN - 2	!Alas, it is off, so NN is not a prime. Perhaps this will be.
              B = B - 1		!Retreat one bit. Each bit steps two.
              IF (B.LT.0) THEN	!Past the start of the character?
                B = 7			!Yes. Back to the last bit.
                C = C - 1		!And retreat one chracter.
                IF (C.LT.0) THEN	!Past the start of the record?
                  C = SCHARS - 1	!Yes. Back to the end of a record.
                  R = R - 1		!Retreat one record.
                  CALL GETSREC(R + 1)	!And read it. (Count is from 1, not 0).
                END IF		!So much for overflowing a record.
              END IF		!So much for overflowing a character.
              GO TO 10		!Try again.
            END IF		!So much for the bit array.
          END IF		!Possibly, it was not needed.
          PREVIOUSPRIME = NN	!There.
        END FUNCTION PREVIOUSPRIME	!Doesn't overflow, either.

        LOGICAL FUNCTION ISPRIME(N)	!Could fool around explicity testing 2 and 3 and say 5,
         INTEGER N			!But that means also checking that N > 2, N > 3, and N > 5.
c        ISPRIME = N .EQ. NEXTPRIME(N - 1)	!This is so much easier, but involves scanning to reach the next prime.
         INTEGER R,IST,I,C,B		!Assistants for indexing the bit array.
          IF (N.LE.1) THEN	!First, preclude sillyness.
            ISPRIME = .FALSE.		!Not a prime.
          ELSE IF (N.EQ.2) THEN	!This is the only even number
            ISPRIME = .TRUE.		!That is a prime.
          ELSE IF (MOD(N,2).EQ.0) THEN	!Other even numbers
            ISPRIME = .FALSE.		!Are not prime numbers.
          ELSE			!Righto, now N is an odd number and there is a bit array for them.
            R = (N - SORG)/(2*SBITS)	!SORG is odd, so (N - SORG) is even.
            CALL GETSREC(R + 1)		!The first record is numbered one, not zero.
            IST = SORG + R*(2*SBITS)	!The number for its first bit: even numbers are omitted.
            I = (N - IST)/2		!Offset into the record. N - IST is even.
            C = I/8			!Which character in SCHAR(0:SCHARS - 1)?
            B = MOD(I,8)		!Which bit in SCHAR(C), indexing from zero?
            ISPRIME = IAND(ICHAR(SCHAR(C)),ICHAR(BITON(B))).GT.0	!The bit is on for a prime.
          END IF			!All that fuss to find a single bit.
        END FUNCTION ISPRIME		!But, no divisions up to SQRT(N) or the like.
      END MODULE PRIMEBAG	!Functions updating a disc file as a side effect...

      PROGRAM POKE
      USE PRIMEBAG
      INTEGER I,P,N,N1,N2	!Assorted assistants.
      INTEGER ORDER		!A collection of special values.
      PARAMETER (ORDER = 6)	!For one, two, and four byte integers.
      INTEGER EDGE(ORDER)	!Considered as two's complement and unsigned.
      PARAMETER (EDGE = (/31,54,3512,6542,105097565,203280221/))	!These primes are of interest.
      MSG = 6		!Standard output.

      IF (.NOT.GRASPPRIMEBAG(66)) STOP "Gan't grab my file!"	!Attempt in hope.

Case 1.
C     FORALL(I = 1:20) LIST(I) = PRIME(I) is rejected because function Prime(i) is rather impure.
   10 WRITE (MSG,11)
   11 FORMAT (19X,"First twenty primes: ", $)
      DO I = 1,20
        P = PRIME(I)
        WRITE (MSG,12) P
   12   FORMAT (I0,",",$)
      END DO

Case 2.
   20 WRITE (MSG,21)
   21 FORMAT (/,12X,"Primes between 100 and 150: ",$)
      P = 100
   22 P = NEXTPRIME(P)		!While (P:=NextPrime(P)) <= 150 do Print P;
      IF (P.LE.150) THEN	!But alas, no assignment within an expression.
        WRITE (MSG,23) P
   23   FORMAT (I0,",",$)
        GO TO 22
      END IF

Case 3.
   30 N1 = 7700	!Might as well parameterise this.
      N2 = 8000	!Rather than litter the source with explicit integers.
      N = 0
      P = N1
   31 P = NEXTPRIME(P)
      IF (P.LE.N2) THEN
        N = N + 1
        GO TO 31
      END IF
      WRITE (MSG,32) N1,N2,N
   32 FORMAT (/"Number of primes between ",I0," and ",I0,": ",I0)

Case 4.
   40 WRITE (MSG,41)
   41 FORMAT (/,"Tenfold steps...")
      N = 1
      DO I = 1,9	!This goes about as far as it can go.
        P = PRIME(N)
        WRITE (MSG,42) N,P
   42   FORMAT ("Prime(",I0,") = ",I0)
        N = N*10
      END DO

Cast forth some interesting values.
  100 WRITE (MSG,101)
  101 FORMAT (/,"Primes close to number sizes")
      DO N = 1,ORDER	!Step through the list.
        N1 = EDGE(N) - 1	!Syncopation for the special value.
        DO I = 1,2		!I want the prime on either side.
          N1 = N1 + 1			!So, there are two successive primes to finger.
          WRITE (MSG,102) N1			!Identify the index.
  102     FORMAT ("Prime(",I0,") = ",$)		!Piecemeal writing to the output,
          P = PRIME(N1)				!As this may fling forth a complaint.
          WRITE (MSG,103) P			!Show the value returned.
  103     FORMAT (I0,", ",$)			!Which may be unexpected.
        END DO			!On to the second.
        WRITE (MSG,*)		!End the line after the second result.
      END DO		!On to the next in the list.

      END	!Whee!