      SUBROUTINE DBAR
C
C     THIS ROUTINE COMPUTES THE 2 6X6 DIFFERENTIAL STIFFNESS MATRICES
C     K(NPVT,NPVT) AND K(NPVT,J) FOR A BEAM HAVING END POINTS OF SIL
C     NOS. NPVT AND J.
C
C     ECPT FOR THE BEAM
C
C     ECPT( 1)  -  IELID          ELEMENT ID. NO.
C     ECPT( 2)  -  ISILNO(2)      SCALAR INDEX NOS.
C     ECPT( 3)  -   ...
C     ECPT( 4)  -  SMALLV(3)      REFERENCE VECTOR
C     ECPT( 5)  -   ...
C     ECPT( 6)  -   ...
C     ECPT( 7)  -  IGSUB0         OPTION FOR DEFINING REFERENCE NUMBER.
C     ECPT( 8)  -  IPINFL(2)      PIN FLAGS
C     ECPT( 9)  -   ...
C     ECPT(10)  -  ZA(3)          OFFSET VECTOR AT POINT A
C     ECPT(11)  -   ...
C     ECPT(12)  -   ...
C     ECPT(13)  -  ZB(3)          OFFSET VECTOR AT POINT B
C     ECPT(14)  -   ...
C     ECPT(15)  -   ...
C     ECPT(16)  -  GEF(4)         ECCENTRICITIES FOR FORCE
C     ECPT(17)  -   ...
C     ECPT(18)  -   ...
C     ECPT(19)  -   ...
C     ECPT(20)  -  IMATID         MATERIAL ID.
C     ECPT(21)  -  A              CROSS-SECTIONAL AREA
C     ECPT(22)  -  C1             STRESS COEFFICIENTS
C     ECPT(23)  -  C2                    ...
C     ECPT(24)  -  I1             AREA MOMENTS OF INERTIA
C     ECPT(25)  -  I2                    ...
C     ECPT(26)  -  I3                    ...
C     ECPT(27)  -  FJ             TORSIONAL CONSTANT
C     ECPT(28)  -  FMU            NON-STRUCTURAL MASS
C     ECPT(29)  -  K1             AREA FACTORS FOR SHEAR
C     ECPT(30)  -  K2                    ...
C     ECPT(31)  -  C3 (D1)        STRESS COEFFICIENTS
C     ECPT(32)  -  C4 (D2)               ...
C     ECPT(33)  -  B1             WIDTHS FOR FORCE
C     ECPT(34)  -  B2                    ...
C     ECPT(35)  -  HS1            DEPTHS FOR FORCE
C     ECPT(36)  -  HS2                   ...
C     ECPT(37)  -  HT1                   ...
C     ECPT(38)  -  HT2                   ...
C     ECPT(39)  -  MCSIDA         COOR. SYS. ID. FOR GRID PT. A
C     ECPT(40)  -  GPA(3)         BASIC COORDINATES FOR PT. A
C     ECPT(41)  -   ...                  ...
C     ECPT(42)  -   ...                  ...
C     ECPT(43)  -  MCSIDB         COOR. SYS. ID. FOR GRID PT. B
C     ECPT(44)  -  GPB(3)         BASIC COORDINATES FOR PT. B
C     ECPT(45)  -   ...                  ...
C     ECPT(46)  -   ...                  ...
C     ECPT(47)  -  ELTEMP         ELEMENT TEMPERATURE
C     ECPT(48)  -  ELDEF          ELEMENT DEFORMATION
C     ECPT(49)  -  TEMPER         ELEMENT LOADING TEMPERATURE
C     ECPT(50)  -  UAS(1)                ...
C     ECPT(51)  -  UAS(2)                ...
C     ECPT(52)  -  UAS(3)         SINGLE PRECISION DISPLACEMENTS
C     ECPT(53)  -  UAS(4)               FOR GRID POINT A
C     ECPT(54)  -  UAS(5)                ...
C     ECPT(55)  -  UAS(6)                ...
C     ECPT(56)  -  UBS(1)                ...
C     ECPT(57)  -  UBS(2)                ...
C     ECPT(58)  -  UBS(3)         SINGLE PRECISION DISPLACEMENTS
C     ECPT(59)  -  UBS(4)               FOR GRID POINT B
C     ECPT(60)  -  UBS(5)                ...
C     ECPT(61)  -  UBS(6)                ...
C
      LOGICAL          ABASIC,BBASIC,BASIC,AOFSET,BOFSET,OFFSET
      REAL             K1,K2,I1,I2
      DOUBLE PRECISION TA(18),TB(9),SMALV0(6),DELA,DELB,KE,KEP,VECI,
     1                 VECJ,VECK,FL,FLL,EI1,EI2,GAK1,GAK2,RRV1,RRV2,
     2                 SK1,SK2,SK3,SK4,TERM1,TERM2,TERM3,TERM4,L,LSQ,
     3                 LCUBE,DP(8)
      DOUBLE PRECISION E,DA,ALPHA,T SUB 0,SA(72),SB(36),UA(6),UB(6),
     1                 DPVECA(6),DPVECB(6),FX,VY,VZ,MAY,MAZ,MBY,MBZ,
     2                 KD(144),KC(12,12),TERM5,TERM6,TERM7,TERM8,TERM9,
     3                 TERM10,TERM11,KES(144),KDP(144),DFJ
      DIMENSION        VECI(3),VECJ(3),VECK(3),ECPT(100),IECPT(100),
     1                 IPIN(10),IZ(1)
      COMMON /ZZZZZZ/  Z(1)
      COMMON /DS1AAA/  NPVT,ICSTM,NCSTM,DUMCL(32),NOGO
      COMMON /DS1AET/  IELID,ISILNO(2),SMALLV(3),IGSUB0,IPINFL(2),ZA(3),
     1                 ZB(3),GEF(4),IMATID,A,DUMMY1,DUMMY2,I1,I2,DUMMY3,
     2                 FJ,FMU,K1,K2,DUM2(8),MCSIDA,GPA(3),MCSIDB,GPB(3),
     3                 TEMPEL,ELDEF,TEMPER,UAS(6),UBS(6),DUM3(38)
      COMMON /DS1ADP/  KE(144),KEP(144),DELA(6),DELB(6)
      COMMON /MATIN /  MATIDC,MATFLG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  E S,G S,NU,RHO,ALPHA S,T SUB 0 S,GSUBE,SIGT,
     1                 SIGC,SIGS
      EQUIVALENCE      (IELID,ECPT(1),IECPT(1)),(IZ(1),Z(1)),
     1                 (TA(10),TB(1)),(ECPT(71),DP(1)),(KC(1,1),KD(1)),
     2                 (SA(37),SB(1))
C
C     DETERMINE WHICH SIL IS THE PIVOT POINT.
C
C     IPVT = 0
      IPVT = 1
      IF (ISILNO(1) .EQ. NPVT) GO TO 20
      IPVT = 2
      IF (ISILNO(2) .NE. NPVT) CALL MESAGE (-30,34,IECPT(1))
C
C     JCSIDA IS AN INDEX WHICH POINTS TO THE COOR. SYS. ID. OF POINT A.
C     JOFSTA IS AN INDEX WHICH POINTS TO THE OFFSET VECTOR FOR POINT A.
C     SIMILARY FOR JCSIDB AND JOFSTB AND POINT B.
C
   20 JCSIDA = 39
      JCSIDB = 43
      JOFSTA = 10
      JOFSTB = 13
      JPINA  = 8
      JPINB  = 9
      ICSIDA = IECPT(JCSIDA)
      ICSIDB = IECPT(JCSIDB)
C
C     NORMALIZE THE REFERENCE VECTOR WHICH LIES IN THE FIRST PRINCIPAL
C     AXIS PLANE  (FMMS - 36 P. 4)
C     WE STORE SMALLV IN SMALV0 SO THAT ARITHMETIC WILL BE DOUBLE
C     PRECISION
C
      DO 50 I = 1,3
   50 SMALV0(I) = SMALLV(I)
      FL = DSQRT(SMALV0(1)**2 + SMALV0(2)**2 + SMALV0(3)**2)
      IF (FL .LE. 0.0D0) GO TO 700
      DO 60 I = 1,3
   60 SMALV0(I) = SMALV0(I)/FL
C
C     DETERMINE IF POINT A AND B ARE IN BASIC COORDINATES OR NOT.
C
      ABASIC = .TRUE.
      BBASIC = .TRUE.
      IF (ICSIDA .NE. 0) ABASIC = .FALSE.
      IF (ICSIDB .NE. 0) BBASIC = .FALSE.
C
C     COMPUTE THE TRANSFORMATION MATRICES TA AND TB IF NECESSARY
C
      IF (.NOT.ABASIC) CALL TRANSD (ECPT(JCSIDA),TA)
      IF (.NOT.BBASIC) CALL TRANSD (ECPT(JCSIDB),TB)
C
C     DETERMINE IF WE HAVE NON-ZERO OFFSET VECTORS.
C
      AOFSET = .TRUE.
      J = JOFSTA - 1
      DO 70 I = 1,3
      J = J + 1
      IF (ECPT(J) .NE. 0.0) GO TO 80
   70 CONTINUE
      AOFSET = .FALSE.
   80 BOFSET = .TRUE.
      J = JOFSTB - 1
      DO 90 I = 1,3
      J = J + 1
      IF (ECPT(J) .NE. 0.0) GO TO 100
   90 CONTINUE
      BOFSET = .FALSE.
C
C     FORM THE CENTER AXIS OF THE BEAM WITHOUT OFFSETS.
C     FIRST WE STORE THE COORDINATES IN THE ARRAY DP SO THAT ALL
C     ARITHMETIC WILL BE DOUBLE PRECISION.
C
  100 DP(1)   = ECPT(JCSIDA+1)
      DP(2)   = ECPT(JCSIDA+2)
      DP(3)   = ECPT(JCSIDA+3)
      DP(4)   = ECPT(JCSIDB+1)
      DP(5)   = ECPT(JCSIDB+2)
      DP(6)   = ECPT(JCSIDB+3)
      VECI(1) = DP(1) - DP(4)
      VECI(2) = DP(2) - DP(5)
      VECI(3) = DP(3) - DP(6)
C
C     TRANSFORM THE OFFSET VECTORS IF NECESSARY
C
      IF (.NOT.AOFSET .AND. .NOT.BOFSET) GO TO 150
C
C     TRANSFORM THE OFFSET VECTOR FOR POINT A IF NECESSARY.
C
      IDELA = 1
      J = JOFSTA - 1
      DO 110 I = 1,3
      J = J + 1
  110 DELA(I) = ECPT(J)
      IF (ABASIC) GO TO 120
      IDELA = 4
      CALL GMMATD (TA,3,3,0, DELA(1),3,1,0, DELA(4))
C
C     TRANSFORM THE OFFSET VECTOR FOR POINT B IF NECESSARY
C
  120 IDELB = 1
      J = JOFSTB - 1
      DO 130 I = 1,3
      J = J + 1
  130 DELB(I) = ECPT(J)
      IF (BBASIC) GO TO 140
      IDELB = 4
      CALL GMMATD (TB,3,3,0, DELB(1),3,1,0, DELB(4))
C
C     SINCE THERE WAS AT LEAST ONE NON-ZERO OFFSET VECTOR RECOMPUTE VECI
C
  140 VECI(1) = VECI(1) + DELA(IDELA  ) - DELB(IDELB  )
      VECI(2) = VECI(2) + DELA(IDELA+1) - DELB(IDELB+1)
      VECI(3) = VECI(3) + DELA(IDELA+2) - DELB(IDELB+2)
C
C     COMPUTE THE LENGTH OF THE BIG V (VECI) VECTOR AND NORMALIZE
C
  150 FL = DSQRT(VECI(1)**2 + VECI(2)**2 + VECI(3)**2)
      IF (FL .EQ. 0.0D0) GO TO 700
      DO 160 I = 1,3
  160 VECI(I) = VECI(I)/FL
C
C     COMPUTE THE SMALL V SUB 0 VECTOR, SMALV0.  ***CHECK THIS LOGIC***
C
      ITA = 1
      ISV = 1
      IF (MCSIDA.EQ.0 .OR. IGSUB0.EQ.0) GO TO 180
      IF (JCSIDA .NE. 39) ITA = 10
      ISV = 4
      CALL GMMATD (TA(ITA),3,3,0, SMALV0(1),3,1,0, SMALV0(4))
C
C     COMPUTE THE K VECTOR, VECK = VECI X SMALV0, AND NORMALIZE
C
  180 VECK(1) =  VECI(2)*SMALV0(ISV+2) - VECI(3)*SMALV0(ISV+1)
      VECK(2) =  VECI(3)*SMALV0(ISV  ) - VECI(1)*SMALV0(ISV+2)
      VECK(3) =  VECI(1)*SMALV0(ISV+1) - VECI(2)*SMALV0(ISV  )
      FLL = DSQRT(VECK(1)**2 + VECK(2)**2 + VECK(3)**2)
      IF (FLL .EQ. 0.0D0) GO TO 700
      VECK(1) =  VECK(1)/FLL
      VECK(2) =  VECK(2)/FLL
      VECK(3) =  VECK(3)/FLL
C
C     COMPUTE THE J VECTOR, VECJ = VECK X VECI, AND NORMALIZE
C
      VECJ(1) =  VECK(2)*VECI(3) - VECK(3)*VECI(2)
      VECJ(2) =  VECK(3)*VECI(1) - VECK(1)*VECI(3)
      VECJ(3) =  VECK(1)*VECI(2) - VECK(2)*VECI(1)
      FLL = DSQRT(VECJ(1)**2 + VECJ(2)**2 + VECJ(3)**2)
      IF (FLL .EQ. 0.0D0) GO TO 700
      VECJ(1) =  VECJ(1)/FLL
      VECJ(2) =  VECJ(2)/FLL
      VECJ(3) =  VECJ(3)/FLL
C
C     SEARCH THE MATERIAL PROPERTIES TABLE FOR E,G AND THE DAMPING
C     CONSTANT.
C
      MATIDC = IMATID
      MATFLG = 1
      ELTEMP = TEMPEL
      CALL MAT (IECPT(1))
C
C     COMPUTE THE RECIPROCALS OF RV1 AND RV2 (CALLING THEM RRV1 AND
C     RRV2)
C
      L = FL
      LSQ = L**2
      LCUBE = LSQ*L
C
C     STORE ECPT AND MPT VARIABLES IN DOUBLE PRECISION LOCATIONS.
C
      DP(1) = E S
      DP(2) = G S
      DP(3) = I1
      DP(4) = I2
      DP(5) = A
      EI1   = DP(1)*DP(3)
      EI2   = DP(1)*DP(4)
      IF (K1 .EQ. 0.0) GO TO 210
      DP(6) = K1
      GAK1  = DP(2)*DP(5)*DP(6)
      RRV1  = (12.0D0*EI1*GAK1)/(GAK1*LCUBE+12.0D0*L*EI1)
      GO TO 220
  210 RRV1  = 12.0D0*EI1/LCUBE
  220 IF (K2 .EQ. 0.0) GO TO 230
      DP(7) = K2
      GAK2  = DP(2)*DP(5)*DP(7)
      RRV2  = (12.0D0*EI2*GAK2)/(GAK2*LCUBE+12.0D0*L*EI2)
      GO TO 240
  230 RRV2  = 12.0D0*EI2/LCUBE
C
C     COMPUTE THE -SMALL- K-S, SK1, SK2, SK3 AND SK4
C
  240 SK1 = 0.25D0*RRV1*LSQ + EI1/L
      SK2 = 0.25D0*RRV2*LSQ + EI2/L
      SK3 = 0.25D0*RRV1*LSQ - EI1/L
      SK4 = 0.25D0*RRV2*LSQ - EI2/L
C
C     COMPUTE THE TERMS THAT WILL BE NEEDED FOR THE 12 X 12 MATRIX KE
C
      TERM1 = DP(5)*DP(1)/L
      TERM2 = 0.5D0*L*RRV1
      TERM3 = 0.5D0*L*RRV2
      DP(8) = FJ
      TERM4 = DP(2)*DP(8)/L
C
C     CONSTRUCT THE 12 X 12 MATRIX KE
C
      DO 250 I = 1,144
  250 KE(  I) =  0.0D0
      KE(  1) =  TERM1
      KE(  7) = -TERM1
      KE( 14) =  RRV1
      KE( 18) = -TERM2
      KE( 20) = -RRV1
      KE( 24) = -TERM2
      KE( 27) =  RRV2
      KE( 29) =  TERM3
      KE( 33) = -RRV2
      KE( 35) =  TERM3
      KE( 40) =  TERM4
      KE( 46) = -TERM4
      KE( 51) =  TERM3
      KE( 53) =  SK2
      KE( 57) = -TERM3
      KE( 59) =  SK4
      KE( 62) = -TERM2
      KE( 66) =  SK1
      KE( 68) =  TERM2
      KE( 72) =  SK3
      KE( 73) = -TERM1
      KE( 79) =  TERM1
      KE( 86) = -RRV1
      KE( 90) =  TERM2
      KE( 92) =  RRV1
      KE( 96) =  TERM2
      KE( 99) = -RRV2
      KE(101) = -TERM3
      KE(105) =  RRV2
      KE(107) = -TERM3
      KE(112) = -TERM4
      KE(118) =  TERM4
      KE(123) =  TERM3
      KE(125) =  SK4
      KE(129) = -TERM3
      KE(131) =  SK2
      KE(134) = -TERM2
      KE(138) =  SK3
      KE(140) =  TERM2
      KE(144) =  SK1
C
C     DETERMINE IF THERE ARE NON-ZERO PIN FLAGS.
C
      KA = IECPT(JPINA)
      KB = IECPT(JPINB)
      IF (KA.EQ.0 .AND. KB.EQ.0) GO TO 325
C
C     SAVE THE KE (UNPINNED) MATRIX IN KES.
C
      DO 255 I = 1,144
  255 KES(I) = KE(I)
C
C     SET UP THE IPIN ARRAY
C
      DO 260 I = 1,5
      IPIN(I  ) = MOD(KA,10)
      IPIN(I+5) = MOD(KB,10) + 6
      IF (IPIN(I+5) .EQ. 6) IPIN(I+5) = 0
      KA = KA/10
  260 KB = KB/10
C
C     ALTER KE MATRIX DUE TO PIN FLAGS.
C
      DO 320 I = 1,10
      IF (IPIN(I) .EQ. 0) GO TO 320
      II = 13*IPIN(I) - 12
      IF (KE(II) .NE. 0.0D0) GO TO 280
      IL = IPIN(I)
      II = II - IL
      DO 270 J = 1,12
      II = II + 1
      KE(II) = 0.0D0
      KE(IL) = 0.0D0
      IL = IL + 12
  270 CONTINUE
      GO TO 320
  280 DO 300 J = 1,12
      JI  = 12*(J-1) + IPIN(I)
      IJ  = 12*(IPIN(I)-1) + J
      DO 290 LL = 1,12
      JLL = 12*(J-1) + LL
      ILL = 12*(IPIN(I)-1) + LL
      KEP(JLL) = KE(JLL) - (KE(ILL)/KE(II))*KE(JI)
  290 CONTINUE
      KEP(IJ) = 0.0D0
      KEP(JI) = 0.0D0
  300 CONTINUE
      DO 310 K = 1,144
  310 KE(K) = KEP(K)
  320 CONTINUE
C
C            E
C     STORE K   IN KEP(1),...,KEP(36) AND
C            AA
C
C            E
C     STORE K   IN KEP(37),...,KEP(72)
C            AB
C
  325 J = 0
      DO 340 I = 1,72,12
      LOW = I
      LIM = LOW + 5
      DO 330 K = LOW,LIM
      J = J + 1
      KEP(J   ) = KE(K  )
  330 KEP(J+36) = KE(K+6)
  340 CONTINUE
C
C                                                            T
C     STORE VECI, VECJ, VECK IN KE(1),...,KE(9) FORMING THE A  MATRIX.
C
      KE(1) = VECI(1)
      KE(2) = VECI(2)
      KE(3) = VECI(3)
      KE(4) = VECJ(1)
      KE(5) = VECJ(2)
      KE(6) = VECJ(3)
      KE(7) = VECK(1)
      KE(8) = VECK(2)
      KE(9) = VECK(3)
C
C     SET POINTERS SO THAT WE WILL BE WORKING WITH POINT A.
C
      BASIC  = ABASIC
      JCSID  = JCSIDA
      OFFSET = AOFSET
      JOFSET = JOFSTA
      IWBEG  = 0
      IKEL   = 1
      IAB    = 1
C
C     ZERO OUT THE ARRAY WHERE THE 3 X 3 MATRIX H AND THE W  AND W
C     6 X 6 MATRICES WILL RESIDE.                          A      B
C
      DO 360 I = 28,108
  360 KE(I) = 0.0D0
C
C     SET UP THE -G- MATRIX.  IG POINTS TO THE BEGINNING OF THE G MATRIX
C     G = AT X TI
C
  365 IG = 1
      IF (BASIC) GO TO 370
      CALL TRANSD (ECPT(JCSID),KE(10))
      CALL GMMATD (KE(1),3,3,0, KE(10),3,3,0, KE(19))
      IG = 19
C
C     IF THERE IS A NON-ZERO OFFSET FOR THE POINT, SET UP THE D 3 X 3
C     MATRIX.
C
  370 IF (.NOT.OFFSET) GO TO 380
      KE(10) =  0.0D0
      KE(11) =  ECPT(JOFSET+2)
      KE(12) = -ECPT(JOFSET+1)
      KE(13) = -KE(11)
      KE(14) =  0.0D0
      KE(15) =  ECPT(JOFSET)
      KE(16) = -KE(12)
      KE(17) = -KE(15)
      KE(18) =  0.0D0
C
C     FORM THE 3 X 3 PRODUCT H = G X D, I.E., KE(28) = KE(IG) X KE(10)
C
      CALL GMMATD (KE(IG),3,3,0, KE(10),3,3,0, KE(28))
C
C
C     FORM THE W  MATRIX OR THE W  MATRIX IN KE(37) OR KE(73) DEPENDING
C               A                B
C     UPON WHICH POINT - A OR B - IS UNDER CONSIDERATION.  G WILL BE
C     STORED IN THE UPPER LEFT AND LOWER RIGHT CORNERS.  H, IF NON-ZERO,
C     WILL BE STORED IN THE UPPER RIGHT CORNER.
C
  380 KE(IWBEG+37) = KE(IG  )
      KE(IWBEG+38) = KE(IG+1)
      KE(IWBEG+39) = KE(IG+2)
      KE(IWBEG+43) = KE(IG+3)
      KE(IWBEG+44) = KE(IG+4)
      KE(IWBEG+45) = KE(IG+5)
      KE(IWBEG+49) = KE(IG+6)
      KE(IWBEG+50) = KE(IG+7)
      KE(IWBEG+51) = KE(IG+8)
      KE(IWBEG+58) = KE(IG  )
      KE(IWBEG+59) = KE(IG+1)
      KE(IWBEG+60) = KE(IG+2)
      KE(IWBEG+64) = KE(IG+3)
      KE(IWBEG+65) = KE(IG+4)
      KE(IWBEG+66) = KE(IG+5)
      KE(IWBEG+70) = KE(IG+6)
      KE(IWBEG+71) = KE(IG+7)
      KE(IWBEG+72) = KE(IG+8)
      IF (.NOT.OFFSET) GO TO 390
      KE(IWBEG+40) = KE(28)
      KE(IWBEG+41) = KE(29)
      KE(IWBEG+42) = KE(30)
      KE(IWBEG+46) = KE(31)
      KE(IWBEG+47) = KE(32)
      KE(IWBEG+48) = KE(33)
      KE(IWBEG+52) = KE(34)
      KE(IWBEG+53) = KE(35)
      KE(IWBEG+54) = KE(36)
C
C                                 E                     E
C     COMPUTE THE PRODUCT S   =  K   X  W   OR  S   =  K    X  W
C                          A      AA     A       B      AB      B
C     WHERE
C                  T                           T
C           W  =  T   X  C  X  E   AND  W  =  T   X  C   X  E
C            A     EB     A     A        B     EB     B      B
C
C     W AT KE(37) AND W AT KE(73) WILL BE USED AGAIN BEFORE FINAL STEPS.
C      A               B
C
  390 CALL GMMATD (KEP(IKEL),6,6,0, KE(IWBEG+37),6,6,0, SA(IAB))
C
C     IF THE POINT UNDER CONSIDERATION IS POINT B WE ARE FINISHED. IF
C     NOT, SET UP POINTS AND INDICATORS FOR WORKING WITH POINT B.
C
      IF (IWBEG .EQ. 36) GO TO 500
      BASIC  = BBASIC
      JCSID  = JCSIDB
      OFFSET = BOFSET
      JOFSET = JOFSTB
      IWBEG  = 36
      IKEL   = 37
      IAB    = 37
      DO 400 I = 28,36
  400 KE(I)  = 0.0D0
      GO TO 365
C
C     BEGIN DIFFERENTIAL STIFFNESS PORTION OF THIS ROUTINE.
C
C     STORE DISPLACEMENT VECTORS IN DOUBLE PRECISION LOCATIONS
C
  500 DO 510 I = 1,6
      UA(I) = ECPT(I+49)
  510 UB(I) = ECPT(I+55)
C
C     COMPUTE  S  X  U   AND  S  X  U
C               A     A        B     B
C
      CALL GMMATD (SA(1),6,6,0, UA,6,1,0, DPVECA)
      CALL GMMATD (SB(1),6,6,0, UB,6,1,0, DPVECB)
C
C     COMPUTE THE NEEDED COMPONENTS OF THE FORCE VECTOR.
C
      FX  = DPVECA(1) + DPVECB(1)
      VY  = DPVECA(2) + DPVECB(2)
      VZ  = DPVECA(3) + DPVECB(3)
      MAY = DPVECA(5) + DPVECB(5)
      MAZ = DPVECA(6) + DPVECB(6)
      MBZ = -MAZ - VY*L
      MBY = -MAY + VZ*L
      E   = E S
      FX  = FX - E*ELDEF/L
      IF (IECPT(49) .EQ. -1) GO TO 520
      ALPHA = ALPHAS
      TSUB0 = TSUB0S
      DP(1) = TEMPER
      FX  = FX - A*ALPHA*E*(DP(1)-TSUB0)
C
C     ZERO OUT THE KD (KC) MATRIX
C
  520 DO 530 I = 1,144
  530 KD(I) = 0.0D0
C
C     FORM THE ELEMENT DIFFERENTIAL STIFFNESS MATRIX (UPPER HALF)
C
      TERM1  = 6.0D0*FX/(5.0D0*L)
      TERM2  = -MAY/L
      TERM3  = FX/10.0D0
      TERM4  = -MBY/L
      TERM5  = -MAZ/L
      TERM6  = -MBZ/L
      DFJ    = I1 + I2
      DA     = A
      TERM7  = DFJ*FX/(L*DA)
      TERM8  = L*VY/6.0D0
      TERM9  = L*VZ/6.0D0
      TERM10 = 2.0D0*L*FX/15.0D0
      TERM11 = L*FX/30.0D0
      KC( 2, 2) =  TERM1
      KC( 2, 4) =  TERM2
      KC( 2, 6) = -TERM3
      KC( 2, 8) = -TERM1
      KC( 2,10) =  TERM4
      KC( 2,12) = -TERM3
      KC( 3, 3) =  TERM1
      KC( 3, 4) =  TERM5
      KC( 3, 5) =  TERM3
      KC( 3, 9) = -TERM1
      KC( 3,10) =  TERM6
      KC( 3,11) =  TERM3
      KC( 4, 4) =  TERM7
      KC( 4, 5) = -TERM8
      KC( 4, 6) = -TERM9
      KC( 4, 8) = -TERM2
      KC( 4, 9) = -TERM5
      KC( 4,10) = -TERM7
      KC( 4,11) =  TERM8
      KC( 4,12) =  TERM9
      KC( 5, 5) =  TERM10
      KC( 5, 9) = -TERM3
      KC( 5,10) =  TERM8
      KC( 5,11) = -TERM11
      KC( 6, 6) =  TERM10
      KC( 6, 8) =  TERM3
      KC( 6,10) =  TERM9
      KC( 6,12) = -TERM11
      KC( 8, 8) =  TERM1
      KC( 8,10) = -TERM4
      KC( 8,12) =  TERM3
      KC( 9, 9) =  TERM1
      KC( 9,10) = -TERM6
      KC( 9,11) = -TERM3
      KC(10,10) =  TERM7
      KC(10,11) = -TERM8
      KC(10,12) = -TERM9
      KC(11,11) =  TERM10
      KC(12,12) =  TERM10
C
C     STORE THE UPPER HALF IN THE LOWER HALF.
C
      DO 550 I = 2,10
      LOW = I + 1
      DO 540 J = LOW,12
      KC(J,I) = KC(I,J)
  540 CONTINUE
  550 CONTINUE
C
C     IF THERE PIN FLAGS, ALTER THE KD MATRIX
C
      IF (KA.EQ.0 .AND. KB.EQ.0) GO TO 620
C
C     ALTER KD DUE TO PIN FLAGS.
C
      DO 610 J = 1,10
      IF (IPIN(J) .EQ. 0) GO TO 610
      JJ = 12*(IPIN(J)-1) + IPIN(J)
      IF (KES(JJ) .EQ. 0.0D0) GO TO 605
      DO 590 I = 1,12
      JI = 12*(IPIN(J)-1) + I
      IJ = 12*(I-1) + IPIN(J)
      DO 580 L1 = 1,12
      IL = 12*(I-1) + L1
      LJ = 12*(L1-1) + IPIN(J)
      KDP(IL) = KD(IL) - KES(LJ)*KD(JI)/KES(JJ) - KES(JI)*KD(LJ)/KES(JJ)
     2        + KES(LJ)* KES(JI)*KD(JJ)/KES(JJ)**2
  580 CONTINUE
  590 CONTINUE
      DO 600 KK = 1,144
  600 KD(KK) = KDP(KK)
C
C     ZERO OUT THE IPIN(J) TH ROW AND COLUMN OF KD.
C
  605 J1 = JJ - IPIN(J)
      J2 = IPIN(J)
      DO 608 KK = 1,12
      J1 = J1 + 1
      KD(J1) = 0.0D0
      KD(J2) = 0.0D0
  608 J2 = J2 + 12
  610 CONTINUE
C
C            D
C     STORE K        AT KEP(1),...,KEP(36)  AND
C            NPVT,A
C
C            D
C           K        AT KEP(37),...,KEP(72)
C            NPVT,B
C
C
  620 J = 0
      IF (IPVT .EQ. 2) GO TO 625
      ILOW = 1
      ILIM = 72
      GO TO 628
  625 ILOW = 73
      ILIM = 144
  628 DO 640 I = ILOW,ILIM,12
      LOW  = I
      LIM  = LOW +5
      DO 630 K = LOW,LIM
      J = J + 1
      KEP(J   ) = KD(K  )
  630 KEP(J+36) = KD(K+6)
  640 CONTINUE
C
C     COMPUTE THE FINAL 2 6X6 DIFFERENTIAL STIFFNESS MATRICES FOR THIS
C     BEAM.
C
      IWLEFT = 37
      IF (IPVT .EQ. 2) IWLEFT = 73
      I = 1
      IKDE = 1
      IWRGHT = 37
  650 CALL GMMATD (KE(IWLEFT),6,6,1, KEP(IKDE),6,6,0, KEP(73))
      CALL GMMATD (KEP(73),6,6,0, KE(IWRGHT),6,6,0, KEP(109))
      CALL DS1B (KEP(109),ISILNO(I))
      IF (I .EQ. 2) RETURN
      I = 2
      IKDE = 37
      IWRGHT = 73
      GO TO 650
C
C     FATAL ERROR
C
  700 CALL MESAGE (30,26,IECPT(1))
C
C     SET FLAG FOR FATAL ERROR WHILE ALLOWING ERROR MESSAGES TO
C     ACCUMULATE
C
      NOGO = 1
      RETURN
      END


      subroutine evptzc(amu,aslm,ipbtmx,jpfcmx,jptffl,nmut,nmutmx,
     $ noutpt,nttyo,nslt,nsltmx,pmu,pslamn,tempc)
c
c     This subroutine computes the S-lambda(n) (pslamn) and mu (pmu)
c     coefficients of Pitzer's equations at the temperature tempc.
c
c     This subroutine is called by:
c
c       EQLIB/evdata.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       amu    = array of coefficients for calculating Pitzer mu
c                coefficients (pmu) as a function of temperature
c       aslm   = array of coefficients for calculating Pitzer
c                  S-lambda(n) coefficients (pslamn) as a function
c                  of temperature
c       jptffl = Pitzer parameter temperature coefficient flag:
c                  -1 = 25C centric Taylor's series truncated at
c                         second order
c                   0 = 25C centric LLNL 5TERM function
c                         (maximal 5th order)
c                   1 = non-25C centric eight-term Greenberg and
c                         Moller (1989) function
c       nmut   = the number of species triples for which there are
c                  mu coefficients
c       nslt   = the number of species pairs for which there are
c                  S-lambda(n) coefficients
c       tempc  = the temperature (C)
c
c     Principal output:
c
c       pmu    = array of Pitzer mu coefficients
c       pslamn = array of Pitzer S-lambda(n) coefficients
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ipbtmx,jpfcmx,nmutmx,nsltmx
c
      integer noutpt,nttyo
c
      integer jptffl,nmut,nslt
c
      real(8) amu(jpfcmx,nmutmx),aslm(jpfcmx,0:ipbtmx,nsltmx),
     $ pmu(nmutmx),pslamn(0:ipbtmx,nsltmx)
c
      real(8) tempc
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer j,jpfclm,j2,k,nmu,nsl
c
      integer ilnobl
c
      character(len=8) ux8
c
      real(8) px,t,tr
c
c     Note: the dimension of dtf must match the maximum number of terms
c     in any programmed temperature function.
c
      real(8) dtf(2:8)
c
c-----------------------------------------------------------------------
c
      t = tempc + 273.15
      tr = 298.15
c
      if (jptffl .eq. -1) then
c
c       Classical 25C-centric Taylor's series truncated at second order.
c
        dtf(2) = t - tr
        dtf(3) = 0.5*dtf(2)*dtf(2)
        jpfclm = min(jpfcmx,3)
c
      elseif (jptffl .eq. 0) then
c
c       LLNL maximal 5-term equation.
c
        dtf(2) = (1./t) - (1./tr)
        dtf(3) = log(t/tr)
        dtf(4) = t - tr
        dtf(5) = t**2 - tr**2
        jpfclm = min(jpfcmx,5)
c
      elseif (jptffl .eq. 1) then
c
c       Greenberg and Moller (1989) eight-term equation.
c
        if ((abs(t - 227.) .le. 1.e-3)
     $    .or. (abs(t - 263.) .le. 1.e-3)
     $    .or. (abs(t - 680.) .le. 1.e-3)) then
          write (noutpt,1000) t,tempc
          write (nttyo,1000) t,tempc
 1000     format(/' * Error - (EQLIBG/evptzc) The temperature of ',
     $    f7.4,'K (',f7.4,'C) is',/7x,'too close to a singularity',
     $    ' in the TEQUIL eight-parameter Pitzer',/7x,'parameter',
     $    ' temperature function.')
          stop
        endif
c
        dtf(2) = t
        dtf(3) = 1./t
        dtf(4) = log(t)
        dtf(5) = 1./(t - 263.)
        dtf(6) = t*t
        dtf(7) = 1./(680. - t)
        dtf(8) = 1./(t - 227.)
        jpfclm = min(jpfcmx,8)
c
      else
        write (ux8,'(i5)') jptffl
        call lejust(ux8)
        j2 = ilnobl(ux8)
        write (noutpt,1010) ux8(1:j2)
        write (nttyo,1010) ux8(1:j2)
 1010   format(/' * Error - (EQLIBG/evptzc) Programming error trap:',
     $  ' Have an',/7x,'illegal value of ',a,' for the variable',
     $  ' jptffl, which determines',/7x,'the Pitzer parameter',
     $  ' temperature function. Do not have such a',/7x,'function',
     $  ' programmed that matches this value.')
        stop
      endif
c
      do nsl = 1,nslt
        do k = 0,2
          px = aslm(1,k,nsl)
          do j = 2,jpfclm
            px = px + aslm(j,k,nsl)*dtf(j)
          enddo
          pslamn(k,nsl) = px
        enddo
      enddo
c
      do nmu = 1,nmut
        px = amu(1,nmu)
        do j = 2,jpfclm
          px = px + amu(j,nmu)*dtf(j)
        enddo
        pmu(nmu) = px
      enddo
c
      end


      subroutine derforcex(force,force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv, &
                           dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc,lo,hi,domlo, &
                           domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine computes the x-component of the forcing term
!
      use amrex_fort_module, only : rt => amrex_real
      use turbforce_module
      use amrex_constants_module, only : TWO, HALF, ZERO, M_PI
      use probdata_module    , only : prob_lo, prob_hi

      implicit none

      integer          lo(3), hi(3)
      integer          force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      real(rt) delta(3), xlo(3), time, dt
      real(rt) force(force_l1:force_h1,force_l2:force_h2,force_l3:force_h3,nv)
      real(rt) dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer :: i,j,k
      integer :: kx,ky,kz
      integer :: xstep,ystep,zstep
      real(rt) :: x,  y,  z
      real(rt) :: Lx, Ly, Lz, freqx, freqy, freqz
      real(rt) :: cosx,cosy,cosz,sinx,siny,sinz
      real(rt) :: HLx,HLy,HLz
      real(rt) :: kxd,kyd,kzd
      real(rt) :: kappa,kappaMax,Lmin,xT
      real(rt) :: f1,twicePi

      twicePi = TWO*M_PI

      Lx = prob_hi(1)-prob_lo(1)
      Ly = prob_hi(2)-prob_lo(2)
      Lz = prob_hi(3)-prob_lo(3)

      Lmin = min(Lx,Ly,Lz)
      kappaMax = dble(nmodes)/Lmin + 1.0d-8
      nxmodes = nmodes*int(HALF+Lx/Lmin)
      nymodes = nmodes*int(HALF+Ly/Lmin)
      nzmodes = nmodes*int(HALF+Lz/Lmin)

      xstep = int(Lx/Lmin+HALF)
      ystep = int(Ly/Lmin+HALF)
      zstep = int(Lz/Lmin+HALF)

      HLx = Lx
      HLy = Ly
      HLz = Lz

      do k = lo(3),hi(3)
         z = (dble(k) + HALF) * delta(3)

         do j = lo(2),hi(2)
            y =  (dble(j) + HALF) * delta(2)

            do i = lo(1),hi(1)
               x = (dble(i) + HALF) * delta(1)

               f1 = ZERO
               do kz = mode_start*zstep, nzmodes, zstep
                  kzd = dble(kz)
                  freqz = twicePi*kzd*HLz
                  do ky = mode_start*ystep, nymodes, ystep
                     kyd = dble(ky)
                     freqy=twicePi*kyd/HLy
                     do kx = mode_start*xstep, nxmodes, xstep
                        kxd = dble(kx)
                        kappa = sqrt( (kxd*kxd)/(Lx*Lx) + (kyd*kyd)/(Ly*Ly) + (kzd*kzd)/(Lz*Lz) )
                        freqx = twicePi*kxd/HLx
                        if (kappa.le.kappaMax) then
                           xT = cos(FTX(kx,ky,kz)*time+TAT(kx,ky,kz))
                           f1 = f1 + xT * ( FAZ(kx,ky,kz)*freqy*sin(freqx*x+FPZX(kx,ky,kz)) * cos(freqy*y+FPZY(kx,ky,kz)) * &
                                                                sin(freqz*z+FPZZ(kx,ky,kz)) &
                                           -FAY(kx,ky,kz)*freqz*sin(freqx*x+FPYX(kx,ky,kz)) * sin(freqy*y+FPYY(kx,ky,kz)) * &
                                                                cos(freqz*z+FPYZ(kx,ky,kz)) )
                        endif
                     enddo
                  enddo
               enddo

               force(i,j,k,1) = dat(i,j,k,1)*f1

            enddo
         enddo
      enddo

      end subroutine derforcex

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

      subroutine derforcey(force,force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv, &
                           dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc,lo,hi,domlo, &
                           domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine computes the y-component of the forcing term
!
      use amrex_fort_module, only : rt => amrex_real
      use turbforce_module
      use amrex_constants_module, only : TWO, HALF, ZERO, M_PI
      use probdata_module    , only : prob_lo, prob_hi

      implicit none

      integer          lo(3), hi(3)
      integer          force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      real(rt) delta(3), xlo(3), time, dt
      real(rt) force(force_l1:force_h1,force_l2:force_h2,force_l3:force_h3,nv)
      real(rt) dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer :: i,j,k
      integer :: kx,ky,kz
      integer :: xstep,ystep,zstep
      real(rt) :: x,  y,  z
      real(rt) :: Lx, Ly, Lz, freqx, freqy, freqz
      real(rt) :: cosx,cosy,cosz,sinx,siny,sinz
      real(rt) :: HLx,HLy,HLz
      real(rt) :: kxd,kyd,kzd
      real(rt) :: kappa,kappaMax,Lmin,xT
      real(rt) :: f2,twicePi

      twicePi = TWO*M_PI

      Lx = prob_hi(1)-prob_lo(1)
      Ly = prob_hi(2)-prob_lo(2)
      Lz = prob_hi(3)-prob_lo(3)

      Lmin = min(Lx,Ly,Lz)
      kappaMax = dble(nmodes)/Lmin + 1.0d-8
      nxmodes = nmodes*int(HALF+Lx/Lmin)
      nymodes = nmodes*int(HALF+Ly/Lmin)
      nzmodes = nmodes*int(HALF+Lz/Lmin)

      xstep = int(Lx/Lmin+HALF)
      ystep = int(Ly/Lmin+HALF)
      zstep = int(Lz/Lmin+HALF)

      HLx = Lx
      HLy = Ly
      HLz = Lz

      do k = lo(3),hi(3)
         z = (dble(k) + HALF) * delta(3)

         do j = lo(2),hi(2)
            y =  (dble(j) + HALF) * delta(2)

            do i = lo(1),hi(1)
               x = (dble(i) + HALF) * delta(1)

               f2 = ZERO
               do kz = mode_start*zstep, nzmodes, zstep
                  kzd = dble(kz)
                  freqz = twicePi*kzd*HLz
                  do ky = mode_start*ystep, nymodes, ystep
                     kyd = dble(ky)
                     freqy=twicePi*kyd/HLy
                     do kx = mode_start*xstep, nxmodes, xstep
                        kxd = dble(kx)
                        kappa = sqrt( (kxd*kxd)/(Lx*Lx) + (kyd*kyd)/(Ly*Ly) + (kzd*kzd)/(Lz*Lz) )
                        freqx = twicePi*kxd/HLx
                        if (kappa.le.kappaMax) then
                           xT = cos(FTX(kx,ky,kz)*time+TAT(kx,ky,kz))
                           f2 = f2 + xT * ( FAX(kx,ky,kz)*freqz*sin(freqx*x+FPXX(kx,ky,kz)) * sin(freqy*y+FPXY(kx,ky,kz)) * &
                                                                cos(freqz*z+FPXZ(kx,ky,kz)) &
                                           -FAZ(kx,ky,kz)*freqx*cos(freqx*x+FPZX(kx,ky,kz)) * sin(freqy*y+FPZY(kx,ky,kz)) * &
                                                                sin(freqz*z+FPZZ(kx,ky,kz)) )
                        endif
                     enddo
                  enddo
               enddo

               force(i,j,k,1) = dat(i,j,k,1)*f2

            enddo
         enddo
      enddo

      end subroutine derforcey

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

      subroutine derforcez(force,force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv, &
                           dat,dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc,lo,hi,domlo, &
                           domhi,delta,xlo,time,dt,bc,level,grid_no)
!
!     This routine computes the z-component of the forcing term
!
      use amrex_fort_module, only : rt => amrex_real
      use turbforce_module
      use amrex_constants_module, only : TWO, HALF, ZERO, M_PI
      use probdata_module    , only : prob_lo, prob_hi

      implicit none

      integer          lo(3), hi(3)
      integer          force_l1,force_l2,force_l3,force_h1,force_h2,force_h3,nv
      integer          dat_l1,dat_l2,dat_l3,dat_h1,dat_h2,dat_h3,nc
      integer          domlo(3), domhi(3)
      integer          bc(3,2,nc)
      real(rt) delta(3), xlo(3), time, dt
      real(rt) force(force_l1:force_h1,force_l2:force_h2,force_l3:force_h3,nv)
      real(rt) dat(dat_l1:dat_h1,dat_l2:dat_h2,dat_l3:dat_h3,nc)
      integer    level, grid_no

      integer :: i,j,k
      integer :: kx,ky,kz
      integer :: xstep,ystep,zstep
      real(rt) :: x,  y,  z
      real(rt) :: Lx, Ly, Lz, freqx, freqy, freqz
      real(rt) :: cosx,cosy,cosz,sinx,siny,sinz
      real(rt) :: HLx,HLy,HLz
      real(rt) :: kxd,kyd,kzd
      real(rt) :: kappa,kappaMax,Lmin,xT
      real(rt) :: f3,twicePi

      twicePi = TWO*M_PI

      Lx = prob_hi(1)-prob_lo(1)
      Ly = prob_hi(2)-prob_lo(2)
      Lz = prob_hi(3)-prob_lo(3)

      Lmin = min(Lx,Ly,Lz)
      kappaMax = dble(nmodes)/Lmin + 1.0d-8
      nxmodes = nmodes*int(HALF+Lx/Lmin)
      nymodes = nmodes*int(HALF+Ly/Lmin)
      nzmodes = nmodes*int(HALF+Lz/Lmin)

      xstep = int(Lx/Lmin+HALF)
      ystep = int(Ly/Lmin+HALF)
      zstep = int(Lz/Lmin+HALF)

      HLx = Lx
      HLy = Ly
      HLz = Lz

      do k = lo(3),hi(3)
         z = (dble(k) + HALF) * delta(3)

         do j = lo(2),hi(2)
            y =  (dble(j) + HALF) * delta(2)

            do i = lo(1),hi(1)
               x = (dble(i) + HALF) * delta(1)

               f3 = ZERO
               do kz = mode_start*zstep, nzmodes, zstep
                  kzd = dble(kz)
                  freqz = twicePi*kzd*HLz
                  do ky = mode_start*ystep, nymodes, ystep
                     kyd = dble(ky)
                     freqy=twicePi*kyd/HLy
                     do kx = mode_start*xstep, nxmodes, xstep
                        kxd = dble(kx)
                        kappa = sqrt( (kxd*kxd)/(Lx*Lx) + (kyd*kyd)/(Ly*Ly) + (kzd*kzd)/(Lz*Lz) )
                        freqx = twicePi*kxd/HLx
                        if (kappa.le.kappaMax) then
                           xT = cos(FTX(kx,ky,kz)*time+TAT(kx,ky,kz))
                           f3 = f3 + xT * ( FAY(kx,ky,kz)*freqx*cos(freqx*x+FPYX(kx,ky,kz)) * sin(freqy*y+FPYY(kx,ky,kz)) * &
                                                                sin(freqz*z+FPYZ(kx,ky,kz)) &
                                           -FAX(kx,ky,kz)*freqy*sin(freqx*x+FPXX(kx,ky,kz)) * cos(freqy*y+FPXY(kx,ky,kz)) * &
                                                                sin(freqz*z+FPXZ(kx,ky,kz)) )
                        endif
                     enddo
                  enddo
               enddo

               force(i,j,k,1) = dat(i,j,k,1)*f3

            enddo
         enddo
      enddo

      end subroutine derforcez


C-----------------------------------------------------------------------
      SUBROUTINE SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR)
C$$$  SUBPROGRAM DOCUMENTATION BLOCK
C
C SUBPROGRAM:  SPFFT1     PERFORM MULTIPLE FAST FOURIER TRANSFORMS
C   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-02-20
C
C ABSTRACT: THIS SUBPROGRAM PERFORMS MULTIPLE FAST FOURIER TRANSFORMS
C           BETWEEN COMPLEX AMPLITUDES IN FOURIER SPACE AND REAL VALUES
C           IN CYCLIC PHYSICAL SPACE.
C           SUBPROGRAM SPFFT1 INITIALIZES TRIGONOMETRIC DATA EACH CALL.
C           USE SUBPROGRAM SPFFT TO SAVE TIME AND INITIALIZE ONCE.
C           THIS VERSION INVOKES THE IBM ESSL FFT.
C
C PROGRAM HISTORY LOG:
C 1998-12-18  IREDELL
C
C USAGE:    CALL SPFFT1(IMAX,INCW,INCG,KMAX,W,G,IDIR)
C
C   INPUT ARGUMENT LIST:
C     IMAX     - INTEGER NUMBER OF VALUES IN THE CYCLIC PHYSICAL SPACE
C                (SEE LIMITATIONS ON IMAX IN REMARKS BELOW.)
C     INCW     - INTEGER FIRST DIMENSION OF THE COMPLEX AMPLITUDE ARRAY
C                (INCW >= IMAX/2+1)
C     INCG     - INTEGER FIRST DIMENSION OF THE REAL VALUE ARRAY
C                (INCG >= IMAX)
C     KMAX     - INTEGER NUMBER OF TRANSFORMS TO PERFORM
C     W        - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR>0
C     G        - REAL(INCG,KMAX) REAL VALUES IF IDIR<0
C     IDIR     - INTEGER DIRECTION FLAG
C                IDIR>0 TO TRANSFORM FROM FOURIER TO PHYSICAL SPACE
C                IDIR<0 TO TRANSFORM FROM PHYSICAL TO FOURIER SPACE
C
C   OUTPUT ARGUMENT LIST:
C     W        - COMPLEX(INCW,KMAX) COMPLEX AMPLITUDES IF IDIR<0
C     G        - REAL(INCG,KMAX) REAL VALUES IF IDIR>0
C
C SUBPROGRAMS CALLED:
C   SCRFT        IBM ESSL COMPLEX TO REAL FOURIER TRANSFORM
C   SRCFT        IBM ESSL REAL TO COMPLEX FOURIER TRANSFORM
C
C ATTRIBUTES:
C   LANGUAGE: FORTRAN 90
C
C REMARKS:
C   THE RESTRICTIONS ON IMAX ARE THAT IT MUST BE A MULTIPLE
C   OF 1 TO 25 FACTORS OF TWO, UP TO 2 FACTORS OF THREE,
C   AND UP TO 1 FACTOR OF FIVE, SEVEN AND ELEVEN.
C
C   THIS SUBPROGRAM IS THREAD-SAFE.
C
C$$$
        IMPLICIT NONE
        INTEGER,INTENT(IN):: IMAX,INCW,INCG,KMAX,IDIR
        COMPLEX,INTENT(INOUT):: W(INCW,KMAX)
        REAL,INTENT(INOUT):: G(INCG,KMAX)
        REAL:: AUX1(25000+INT(0.82*IMAX))
        REAL:: AUX2(20000+INT(0.57*IMAX))
        INTEGER:: NAUX1,NAUX2
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
        NAUX1=25000+INT(0.82*IMAX)
        NAUX2=20000+INT(0.57*IMAX)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  FOURIER TO PHYSICAL TRANSFORM.
        SELECT CASE(IDIR)
          CASE(1:)
            CALL SCRFT(1,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
     &                 AUX1,NAUX1,AUX2,NAUX2,0.,0)
            CALL SCRFT(0,W,INCW,G,INCG,IMAX,KMAX,-1,1.,
     &                 AUX1,NAUX1,AUX2,NAUX2,0.,0)
C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C  PHYSICAL TO FOURIER TRANSFORM.
          CASE(:-1)
            CALL SRCFT(1,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
     &               AUX1,NAUX1,AUX2,NAUX2,0.,0)
            CALL SRCFT(0,G,INCG,W,INCW,IMAX,KMAX,+1,1./IMAX,
     &               AUX1,NAUX1,AUX2,NAUX2,0.,0)
        END SELECT
      END SUBROUTINE


c=======================================================================
c
c     GENEXP
c
c     Exponential distribution generator
c
c     Generates a single random deviate from an exponential
c     distribution with mean AV.
c
c-----------------------------------------------------------------------
c
c-----------------------------------------------------------------------
      DOUBLE PRECISION FUNCTION genexp(av)
c-----------------------------------------------------------------------
c
c     INPUT :
c      AV : the mean of the exponential distribution from which
c           a random deviate is to be generated (AV >= 0)         double
c
c     Method
c
c     Renames SEXPO from TOMS as slightly modified by BWB to use RANF
c     instead of SUNIF.
c
c     For details see:
c               Ahrens, J.H. and Dieter, U.
c               Computer Methods for Sampling From the
c               Exponential and Normal Distributions.
c               Comm. ACM, 15,10 (Oct. 1972), 873 - 882.
c
c----------------------------------------------------------------------
c
c     scalar arguments
      DOUBLE PRECISION av
c
c     external functions
      DOUBLE PRECISION sexpo
      EXTERNAL sexpo
c
c     executable statements
 10   genexp = sexpo()*av
      RETURN
      END


subroutine transition (n, ising, iterations, p)
  logical ising(n, n, n), flips(n, n, n)
  integer ones(n, n, n), count (n, n, n)
  real threshold (n, n, n), p(6)

  do i = 1, iterations
     ones = 0
     where (ising) ones = 1
     count = cshift(ones, -1, 1) + cshift(ones, 1, 1) &
          + cshift(ones, -1, 2) + cshift(ones, 1, 2) &
          + cshift(ones, -1, 3) + cshift(ones, 1, 3)
     where (.not. ising) count = 6 - count
     threshold = 1.0
     where (count == 4) threshold = p(4)
     where (count == 5) threshold = p(5)
     where (count == 6) threshold = p(6)
     flips = rand(n) <= threshold
     where(flips) ising = .not. ising
  end do

contains
  function rand(n)
    real rand(n,n,n)
    call random_number(harvest = rand)
    return
  end function rand
end


! Copyright (C) 2017-2019 Matthieu Ancellin
! See LICENSE file at <https://github.com/mancellin/libDelhommeau>
MODULE GREEN_WAVE

  USE CONSTANTS
  USE INITIALIZE_GREEN_WAVE
  USE GREEN_RANKINE, ONLY: COMPUTE_ASYMPTOTIC_RANKINE_SOURCE

  IMPLICIT NONE

  ! Dependancies between the functions of this module:
  ! (from top to bottom: "is called by")
  !
  !            LAGRANGE_POLYNOMIAL_INTERPOLATION
  !                          |
  !              COMPUTE_INTEGRALS_WRT_THETA       (COMPUTE_ASYMPTOTIC_RANKINE_SOURCE)
  !                        /   \                    /
  ! WAVE_PART_INFINITE_DEPTH   WAVE_PART_FINITE_DEPTH
  !                        \   /
  !                  (build_matrices.f90)
  !                          |
  !                    (python code)

CONTAINS

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

  SUBROUTINE LAGRANGE_POLYNOMIAL_INTERPOLATION &
    (dimless_r, dimless_Z,                                 &
     X_AXIS, Z_AXIS, TABULATION,               &
     D1, D2, Z1, Z2)
   ! Helper function used in the following subroutine to interpolate between the tabulated integrals.

    ! Inputs
    REAL(KIND=PRE),                        INTENT(IN) :: dimless_r, dimless_Z
    REAL(KIND=PRE), DIMENSION(3),          INTENT(IN) :: X_AXIS
    REAL(KIND=PRE), DIMENSION(3),          INTENT(IN) :: Z_AXIS
    REAL(KIND=PRE), DIMENSION(3, 3, 2, 2), INTENT(IN) :: TABULATION

    ! Output
    REAL(KIND=PRE), INTENT(OUT) :: D1, D2, Z1, Z2

    ! Local variable
    REAL(KIND=PRE), DIMENSION(3) :: XL, ZL

    XL(1) = PL2(X_AXIS(2), X_AXIS(3), X_AXIS(1), dimless_r)
    XL(2) = PL2(X_AXIS(3), X_AXIS(1), X_AXIS(2), dimless_r)
    XL(3) = PL2(X_AXIS(1), X_AXIS(2), X_AXIS(3), dimless_r)
    ZL(1) = PL2(Z_AXIS(2), Z_AXIS(3), Z_AXIS(1), dimless_Z)
    ZL(2) = PL2(Z_AXIS(3), Z_AXIS(1), Z_AXIS(2), dimless_Z)
    ZL(3) = PL2(Z_AXIS(1), Z_AXIS(2), Z_AXIS(3), dimless_Z)

    D1 = DOT_PRODUCT(XL, MATMUL(TABULATION(:, :, 1, 1), ZL))
    D2 = DOT_PRODUCT(XL, MATMUL(TABULATION(:, :, 2, 1), ZL))
    Z1 = DOT_PRODUCT(XL, MATMUL(TABULATION(:, :, 1, 2), ZL))
    Z2 = DOT_PRODUCT(XL, MATMUL(TABULATION(:, :, 2, 2), ZL))

  CONTAINS

    REAL(KIND=PRE) FUNCTION PL2(U1, U2, U3, XU)
      REAL(KIND=PRE) :: U1, U2, U3, XU
      PL2 = ((XU-U1)*(XU-U2))/((U3-U1)*(U3-U2))
      RETURN
    END FUNCTION

  END SUBROUTINE LAGRANGE_POLYNOMIAL_INTERPOLATION

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

  SUBROUTINE COMPUTE_INTEGRALS_WRT_THETA                         &
      (XI, XJ, wavenumber,                                       &
      tabulated_r_range, tabulated_Z_range, tabulated_integrals, &
      FS, VS)
    ! Compute the expression FS = 1/π Re[ ∫(J(ζ) - 1/ζ)dθ ] + i Re[ ∫(e^ζ)dθ ] and the integrals appearing in its gradient.
    ! For this, this function uses tabulated values of the following integrals:
    ! D1 = Re[ ∫(-i cosθ)(J(ζ) - 1/ζ)dθ ]
    ! D2 = Re[ ∫(-i cosθ)(e^ζ)dθ ]
#ifdef XIE_CORRECTION
    ! Z1 = Re[ ∫(J(ζ))dθ ]
#else
    ! Z1 = Re[ ∫(J(ζ) - 1/ζ)dθ ]
#endif
    ! Z2 = Re[ ∫(e^ζ)dθ ]
    ! (See theory manual for the definition of the symbols above.)

    ! Inputs
    REAL(KIND=PRE), DIMENSION(3),             INTENT(IN) :: XI, XJ
    REAL(KIND=PRE),                           INTENT(IN) :: wavenumber

    ! Tabulated data
    REAL(KIND=PRE), DIMENSION(328),           INTENT(IN) :: tabulated_r_range
    REAL(KIND=PRE), DIMENSION(46),            INTENT(IN) :: tabulated_Z_range
    REAL(KIND=PRE), DIMENSION(328, 46, 2, 2), INTENT(IN) :: tabulated_integrals

    ! Outputs
    COMPLEX(KIND=PRE),                        INTENT(OUT) :: FS  ! the integral
    COMPLEX(KIND=PRE), DIMENSION(3),          INTENT(OUT) :: VS  ! its gradient

    ! Local variables
    INTEGER        :: KI, KJ
    REAL(KIND=PRE) :: r, dimless_r, Z, dimless_Z, R1, dimless_R1
    REAL(KIND=PRE) :: sin_kr, cos_kr, expz_sqr
    REAL(KIND=PRE) :: D1, D2, Z1, Z2

    r = NORM2(XI(1:2) - XJ(1:2))
    dimless_r = wavenumber*r

    Z = XI(3) + XJ(3)
    dimless_Z = wavenumber*Z

    R1 = SQRT(r**2 + Z**2)
    dimless_R1 = wavenumber*R1

    IF ((R1 < 1e-5) .OR. (wavenumber == 0)) THEN
      PRINT*, "Error: Impossible to compute the wave part of the Green function (division by zero)."
      ERROR STOP
    ENDIF

    !=====================================================================================
    ! Evaluate the elementary integrals PDnX and PDnZ depending on dimless_Z and dimless_r
    !=====================================================================================
    IF ((MINVAL(tabulated_Z_range) < dimless_Z) .AND. (dimless_Z < MAXVAL(tabulated_Z_range))) THEN
      IF ((MINVAL(tabulated_r_range) <= dimless_r) .AND. (dimless_r < MAXVAL(tabulated_r_range))) THEN
        ! Within the range of tabulated data
        ! Note that MINVAL(tabulated_r_range) == 0, so one of the conditions is not actually useful.

        ! Get the nearest point in the tabulation
        IF (dimless_r < 1) THEN
          KI = INT(5*(LOG10(dimless_r+1e-20)+6)+1)
        ELSE
          KI = INT(3*dimless_r+28)
        ENDIF
        KI = MAX(MIN(KI, 327), 2)

        IF (dimless_Z < -1e-2) THEN
          KJ = INT(8*(LOG10(-dimless_Z)+4.5))
        ELSE
          KJ = INT(5*(LOG10(-dimless_Z)+6))
        ENDIF
        KJ = MAX(MIN(KJ, 45), 2)

        ! Interpolate near this point to get the actual value
        CALL LAGRANGE_POLYNOMIAL_INTERPOLATION                           &
             (dimless_r, dimless_Z,                                      &
             tabulated_r_range(KI-1:KI+1), tabulated_Z_range(KJ-1:KJ+1), &
             tabulated_integrals(KI-1:KI+1, KJ-1:KJ+1, :, :),            &
             D1, D2, Z1, Z2)

      ELSE  ! MAXVAL(tabulated_r_range) < dimless_r
        ! Asymptotic expression for (horizontally) distant panels

        expz_sqr = EXP(dimless_Z) * SQRT(2*PI/dimless_r)
        cos_kr  = COS(dimless_r - PI/4)
        sin_kr  = SIN(dimless_r - PI/4)

        D1 = PI*(expz_sqr*(cos_kr - sin_kr/(2*dimless_r)) - dimless_r/dimless_R1**3)
        D2 =     expz_sqr*(sin_kr + cos_kr/(2*dimless_r))
#ifdef XIE_CORRECTION
        Z1 = PI*(-expz_sqr*sin_kr + dimless_Z/dimless_R1**3 - ONE/dimless_R1)
#else
        Z1 = PI*(-expz_sqr*sin_kr + dimless_Z/dimless_R1**3)
#endif
        Z2 =     expz_sqr*cos_kr
      ENDIF

      !================================================
      ! Add the elementary integrals to build FS and VS
      !================================================

#ifdef XIE_CORRECTION
      FS    = CMPLX(Z1/PI + ONE/dimless_R1, Z2, KIND=PRE)
      VS(3) = CMPLX(Z1/PI + ONE/dimless_R1, Z2, KIND=PRE)
#else
      FS    = CMPLX(Z1/PI, Z2, KIND=PRE)
      VS(3) = CMPLX(Z1/PI, Z2, KIND=PRE)
#endif
      VS(1) = (XJ(1) - XI(1))/r * CMPLX(D1/PI, D2, KIND=PRE)
      VS(2) = (XJ(2) - XI(2))/r * CMPLX(D1/PI, D2, KIND=PRE)

      IF (r < REAL(1e-5, KIND=PRE)) THEN
        ! Limit case r ~ 0 ?
        VS(1:2) = CMPLX(0.0, 0.0, KIND=PRE)
      END IF

    ELSE  ! dimless_Z < MINVAL(tabulated_Z_range) or MAXVAL(tabulated_Z_range) < dimless_Z
      FS      = CMPLX(dimless_Z/(PI*dimless_R1**3), 0.0, KIND=PRE)
      VS(1:3) = CMPLX(0.0, 0.0, KIND=PRE)
    ENDIF

    RETURN
  END SUBROUTINE COMPUTE_INTEGRALS_WRT_THETA

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

  SUBROUTINE WAVE_PART_INFINITE_DEPTH &
      (wavenumber, X0I, X0J,          &
      X_AXIS, Z_AXIS, TABULATION,     &
      SP, VSP)
    ! Compute the wave part of the Green function in the infinite depth case.
    ! This is mostly the integral computed by the subroutine above.

    ! Inputs
    REAL(KIND=PRE),                           INTENT(IN)  :: wavenumber
    REAL(KIND=PRE), DIMENSION(3),             INTENT(IN)  :: X0I   ! Coordinates of the source point
    REAL(KIND=PRE), DIMENSION(3),             INTENT(IN)  :: X0J   ! Coordinates of the center of the integration panel

    ! Tabulated data
    REAL(KIND=PRE), DIMENSION(328),           INTENT(IN) :: X_AXIS
    REAL(KIND=PRE), DIMENSION(46),            INTENT(IN) :: Z_AXIS
    REAL(KIND=PRE), DIMENSION(328, 46, 2, 2), INTENT(IN) :: TABULATION

    ! Outputs
    COMPLEX(KIND=PRE),               INTENT(OUT) :: SP  ! Integral of the Green function over the panel.
    COMPLEX(KIND=PRE), DIMENSION(3), INTENT(OUT) :: VSP ! Gradient of the integral of the Green function with respect to X0I.

    ! Local variables
    REAL(KIND=PRE), DIMENSION(3) :: XJ_REFLECTION

    ! The integrals
    CALL COMPUTE_INTEGRALS_WRT_THETA(X0I, X0J, wavenumber, X_AXIS, Z_AXIS, TABULATION, SP, VSP(:))
    SP  = 2*wavenumber*SP
    VSP = 2*wavenumber**2*VSP

    ! Only one singularity is missing in the derivative
    XJ_REFLECTION(1:2) = X0J(1:2)
    XJ_REFLECTION(3) = - X0J(3)
    VSP = VSP - 2*(X0I - XJ_REFLECTION)/(NORM2(X0I-XJ_REFLECTION)**3)

    RETURN
  END SUBROUTINE WAVE_PART_INFINITE_DEPTH

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

  SUBROUTINE WAVE_PART_FINITE_DEPTH &
      (wavenumber, X0I, X0J, depth, &
      X_AXIS, Z_AXIS, TABULATION,                  &
      NEXP, AMBDA, AR,              &
      SP, VSP_SYM, VSP_ANTISYM)
    ! Compute the frequency-dependent part of the Green function in the finite depth case.

    ! Inputs
    REAL(KIND=PRE),                           INTENT(IN) :: wavenumber, depth
    REAL(KIND=PRE), DIMENSION(3),             INTENT(IN) :: X0I  ! Coordinates of the source point
    REAL(KIND=PRE), DIMENSION(3),             INTENT(IN) :: X0J  ! Coordinates of the center of the integration panel

    REAL(KIND=PRE), DIMENSION(328),           INTENT(IN) :: X_AXIS
    REAL(KIND=PRE), DIMENSION(46),            INTENT(IN) :: Z_AXIS
    REAL(KIND=PRE), DIMENSION(328, 46, 2, 2), INTENT(IN) :: TABULATION

    INTEGER,                                  INTENT(IN) :: NEXP
    REAL(KIND=PRE), DIMENSION(NEXP),          INTENT(IN) :: AMBDA, AR

    ! Outputs
    COMPLEX(KIND=PRE),               INTENT(OUT) :: SP  ! Integral of the Green function over the panel.
    COMPLEX(KIND=PRE), DIMENSION(3), INTENT(OUT) :: VSP_SYM, VSP_ANTISYM ! Gradient of the integral of the Green function with respect to X0I.

    ! Local variables
    INTEGER                              :: KE
    REAL(KIND=PRE)                       :: AMH, AKH, A
    REAL(KIND=PRE)                       :: AQT, R
    REAL(KIND=PRE),    DIMENSION(3)      :: XI, XJ
    REAL(KIND=PRE),    DIMENSION(4)      :: FTS, PSR
    REAL(KIND=PRE),    DIMENSION(3, 4)   :: VTS
    COMPLEX(KIND=PRE), DIMENSION(4)      :: FS
    COMPLEX(KIND=PRE), DIMENSION(3, 4)   :: VS

    !========================================
    ! Part 1: Solve 4 infinite depth problems
    !========================================

    XI(:) = X0I(:)
    XJ(:) = X0J(:)

    ! Distance in xOy plane
    R = NORM2(XI(1:2) - XJ(1:2))

    ! 1.a First infinite depth problem
    CALL COMPUTE_INTEGRALS_WRT_THETA(XI(:), XJ(:), wavenumber, X_AXIS, Z_AXIS, TABULATION, FS(1), VS(:, 1))

    PSR(1) = ONE/(wavenumber*SQRT(R**2+(XI(3)+XJ(3))**2))

    ! 1.b Shift and reflect XI and compute another value of the Green function
    XI(3) = -X0I(3) - 2*depth
    XJ(3) =  X0J(3)
    CALL COMPUTE_INTEGRALS_WRT_THETA(XI(:), XJ(:), wavenumber, X_AXIS, Z_AXIS, TABULATION, FS(2), VS(:, 2))
    VS(3, 2) = -VS(3, 2) ! Reflection of the output vector

    PSR(2) = ONE/(wavenumber*SQRT(R**2+(XI(3)+XJ(3))**2))

    ! 1.c Shift and reflect XJ and compute another value of the Green function
    XI(3) =  X0I(3)
    XJ(3) = -X0J(3) - 2*depth
    CALL COMPUTE_INTEGRALS_WRT_THETA(XI(:), XJ(:), wavenumber, X_AXIS, Z_AXIS, TABULATION, FS(3), VS(:, 3))

    PSR(3) = ONE/(wavenumber*SQRT(R**2+(XI(3)+XJ(3))**2))

    ! 1.d Shift and reflect both XI and XJ and compute another value of the Green function
    XI(3) = -X0I(3) - 2*depth
    XJ(3) = -X0J(3) - 2*depth
    CALL COMPUTE_INTEGRALS_WRT_THETA(XI(:), XJ(:), wavenumber, X_AXIS, Z_AXIS, TABULATION, FS(4), VS(:, 4))
    VS(3, 4) = -VS(3, 4) ! Reflection of the output vector

    PSR(4) = ONE/(wavenumber*SQRT(R**2+(XI(3)+XJ(3))**2))

    ! Add up the results of the four problems
    SP               = SUM(FS(1:4)) - SUM(PSR(1:4))
    VSP_SYM(1:3)     = VS(1:3, 1) + VS(1:3, 4)
    VSP_ANTISYM(1:3) = VS(1:3, 2) + VS(1:3, 3)

    ! Multiply by some coefficients
    AMH  = wavenumber*depth
    AKH  = AMH*TANH(AMH)
    A    = (AMH+AKH)**2/(2*depth*(AMH**2-AKH**2+AKH))

    SP          = A*SP
    VSP_ANTISYM = A*wavenumber*VSP_ANTISYM
    VSP_SYM     = A*wavenumber*VSP_SYM

    !=====================================================
    ! Part 2: Integrate (NEXP+1)×4 terms of the form 1/MM'
    !=====================================================

    DO KE = 1, NEXP
      XI(:) = X0I(:)

      ! 2.a Shift observation point and compute integral
      XI(3) =  X0I(3) + depth*AMBDA(KE) - 2*depth
      CALL COMPUTE_ASYMPTOTIC_RANKINE_SOURCE(XI(:), X0J(:), ONE, FTS(1), VTS(:, 1))

      ! 2.b Shift and reflect observation point and compute integral
      XI(3) = -X0I(3) - depth*AMBDA(KE)
      CALL COMPUTE_ASYMPTOTIC_RANKINE_SOURCE(XI(:), X0J(:), ONE, FTS(2), VTS(:, 2))
      VTS(3, 2) = -VTS(3, 2) ! Reflection of the output vector

      ! 2.c Shift and reflect observation point and compute integral
      XI(3) = -X0I(3) + depth*AMBDA(KE) - 4*depth
      CALL COMPUTE_ASYMPTOTIC_RANKINE_SOURCE(XI(:), X0J(:), ONE, FTS(3), VTS(:, 3))
      VTS(3, 3) = -VTS(3, 3) ! Reflection of the output vector

      ! 2.d Shift observation point and compute integral
      XI(3) =  X0I(3) - depth*AMBDA(KE) + 2*depth
      CALL COMPUTE_ASYMPTOTIC_RANKINE_SOURCE(XI(:), X0J(:), ONE, FTS(4), VTS(:, 4))

      AQT = AR(KE)/2

      ! Add all the contributions
      SP               = SP               + AQT*SUM(FTS(1:4))
      VSP_ANTISYM(1:3) = VSP_ANTISYM(1:3) + AQT*(VTS(1:3, 1) + VTS(1:3, 4))
      VSP_SYM(1:3)     = VSP_SYM(1:3)     + AQT*(VTS(1:3, 2) + VTS(1:3, 3))

    END DO

    RETURN
  END SUBROUTINE

END MODULE GREEN_WAVE


      SUBROUTINE PARAMCHECK()
      REAL, PARAMETER :: pi = 3.14159
      END SUBROUTINE PARAMCHECK


module settings

use mpi

    implicit none

    double precision, parameter :: pi = 4*atan(1.0)

    integer :: nx,ny
    double precision :: dx,dy,dt
    double precision :: rho,mu,nu
    integer :: nt,nit
    double precision :: omega_P, omega_U, omega_V, tol
    double precision :: Lx,Ly
    double precision :: U0
    integer:: nLog, nWrite		! nLog: write log to terminal every nLog timesteps
    							! write: results to file every nwrite timesteps
    double precision :: RADIUS	! for testing: circle radius

    contains
        subroutine setup(filename)

	        character(len=*) :: filename
	        character(len=30) :: temp

            integer :: id, Nproc, ierr

            call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)

            if (id==0) then

                open(unit=10,file=filename,status='old',action='read')

                read (10,*) temp, Lx
                read (10,*) temp, Ly
                read (10,*) temp, dx
                read (10,*) temp, dy
                read (10,*) temp, dt
                read (10,*) temp, nt
                read (10,*) temp, nit
                read (10,*) temp, rho
                read (10,*) temp, nu
                read (10,*) temp, omega_P
                read (10,*) temp, omega_U
                read (10,*) temp, omega_V
                read (10,*) temp, tol
                read (10,*) temp, U0
                read (10,*) temp, nLog
                read (10,*) temp, nWrite
                read (10,*) temp, RADIUS

			    close(10)

            end if

            ! broadcast to all
            call mpi_bcast(Lx,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(Ly,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(dx,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(dy,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(dt,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(nt,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(nit,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(rho,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(nu,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(omega_P,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(omega_U,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(omega_V,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(tol,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(U0,1,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(nLog,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)
            call mpi_bcast(nWrite,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr)

            !call mpi_barrier(MPI_COMM_WORLD,ierr)

			nx = floor(Lx/dx)
			ny = floor(Ly/dy)

            !print*, Lx, Ly, Lz

			mu = nu*rho

        end subroutine setup

        subroutine setTimestep(a)
        	double precision :: a
        	dt = a
        end subroutine

end module settings


!Fortran permite la conversión entre tipos. Cuando se operan reales con enteros o complejos, Fortran los convierte de manera automática:
!	*Los enteros son convertidos en reales o complejos
!	*Los reales son convertidos en complejos
!	*Los reales o complejos son convertidos en la clase (kind) más alto.
!	*En la asignación de valores (=), la parte derecha es evaluada en el tipo y clase que corresponde, luego es convertida al tipo y
!	 clase de la variable del lado izquierdo

program conversion_tipos
integer :: int = 6
real :: r_var = 3.5
complex :: z = (2, 5.9)

print *, "Complex + integer: ", z + int
print *, "Complex + real: ", r_var + z
print *, "Real + integer: ", r_var + int

end program conversion_tipos

Constantes, variables y tipos de datos/conversion_tipos.f90


c
c
c
c     ===============================================================
      subroutine claw1ez    ! No arguments
c     ===============================================================
c
c     An easy-to-use clawpack driver routine for simple applications
c     Documentation is available at
c                 http://www.clawpack.org
c
c     ! Modified for Boussinesq version
c

      use gauges_module, only: set_gauges
      use geoclaw_module, only: set_geo
      use grid_module, only: set_grid, xlower, xupper, mx, mbc
      use grid_module, only: monitor_total_zeta,iunit_total_zeta_mass
      use grid_module, only: monitor_runup,iunit_runup,runup_tolerance
      use grid_module, only: monitor_fgmax,iunit_fgmax
      use grid_module, only: hmax, smax, xcell
      use topo_module, only: read_topo_settings
      use bouss_module, only: set_bouss

      implicit double precision (a-h,o-z)
      external bc1,rp1,src1,b4step1

      double precision, dimension(:,:), allocatable :: q, aux
      double precision, dimension(:), allocatable :: work, tout
      integer, dimension(:), allocatable :: mthlim, iout_q, iout_aux

c
      dimension method(7),dtv(5),cflv(4),nv(2),mthbc(2)
      integer :: allocate_status, outstyle
      logical :: outaux_init_only, use_fwaves, output_t0
      logical :: outaux_always, dt_variable
      character*12 fname
c
      open(10,file='fort.info',status='unknown',form='formatted')

c
c     # Read the input in standard form from claw.data:
c     # For a description of input parameters see the documentation at
c                 http://www.amath.washington.edu/~claw

c     ## New in 4.4:   Input file name changed from claw1ez.data
c     ## Open file and skip over leading lines with # comments:
      fname = 'claw.data'
      call opendatafile(55,fname)

c
c     # Read the input in standard form from claw.data:
c

      read(55,*) ndim

      read(55,*) xlower
      read(55,*) xupper
      read(55,*) mx
      read(55,*) meqn
      read(55,*) mwaves
      read(55,*) maux
      read(55,*) t0

      read(55,*) outstyle
      if (outstyle == 1) then
         read(55,*) nout
         read(55,*) tfinal
         read(55,*) output_t0
         nstepout = 1
      else if (outstyle == 2) then
         read(55,*) nout
         allocate(tout(nout), stat=allocate_status)
         if (allocate_status .ne. 0) then
            print *, '*** Error allocating tout array; exiting claw1ez'
            go to 900
         end if
         read(55,*) (tout(i), i=1,nout)
         nstepout = 1
      else if (outstyle == 3) then
         read(55,*) nstepout
         read(55,*) nstop
         read(55,*) output_t0
         nout = nstop
      else
         print *, '*** Unrecognized output style ', outstyle
         print *, '*** Exiting claw1ez'
         go to 900
      end if

      read(55,*) output_format    ! Not used yet
      ! These iout variables are not currently used, but hang onto them
      ! anyway in case somebody wants to use them at a future date.  The
      ! same goes for outaux_init_only.
      allocate(iout_q(meqn), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating iout_q array; exiting claw1ez'
         go to 900    ! Exception handling, old school style
      end if
      read(55,*) (iout_q(i), i = 1, meqn)
      if (maux > 0) then
         allocate(iout_aux(maux), stat=allocate_status)
         if (allocate_status .ne. 0) then
            print *, '*** Error allocating iout_aux array;',
     &               ' exiting claw1ez'
            go to 900
         end if
         read(55,*) (iout_aux(i), i = 1, maux)
         read(55,*) outaux_init_only
         ! Not implementing selective output of aux fields yet
         if (any(iout_aux .ne. 0)) then
            outaux_always = .not. outaux_init_only
         else
            outaux_always = .false.
            outaux_init_only = .false.
         end if
      else
         outaux_always = .false.
         outaux_init_only = .false.    ! Just to initialize
      end if

      read(55,*) dtv(1)     ! Initial dt
      read(55,*) dtv(2)     ! Max dt
      read(55,*) cflv(1)    ! Max CFL number
      read(55,*) cflv(2)    ! Desired CFL number
      read(55,*) nv(1)      ! Maximum number of steps

      read(55,*) dt_variable    ! Variable or fixed dt
      if (dt_variable) then
         method(1) = 1
      else
         method(1) = 0
      end if
      read(55,*) method(2)    ! Order
      ! method(3) (transverse order) not used in 1D
      ! No dimensional splitting in 1D
      read(55,*) method(4)    ! Verbosity
      read(55,*) method(5)    ! Source term splitting style
      read(55,*) method(6)    ! Index into aux of capacity function
      method(7) = maux        ! Number of aux variables

      read(55,*) use_fwaves

      allocate(mthlim(mwaves), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating mthlim array; exiting claw1ez'
         go to 900
      end if
      read(55,*) (mthlim(i), i = 1, mwaves)

      read(55,*) mbc
      read(55,*) mthbc(1)
      read(55,*) mthbc(2)

      ! No restart in 1D, and there's nothing after the restart info, so
      ! just close the file now.
      close(unit=55)

      ! Check consistency for periodic BCs
      if ((mthbc(1).eq.2 .and. mthbc(2).ne.2) .or.
     &    (mthbc(2).eq.2 .and. mthbc(1).ne.2)) then
         write(6,*) '*** ERROR ***  periodic boundary conditions'
         write(6,*) ' require mthbc(1) and mthbc(2) BOTH be set to 2'
         stop
      endif

      ! Figure out size of work array needed
      mwork = (mx + 2*mbc) * (2 + 4*meqn + mwaves + meqn*mwaves)

c
c
      write(6,*) 'running...'
      write(6,*) ' '
c
c     # grid spacing
      dx = (xupper - xlower) / float(mx)
c

c     # time increments between outputing solution:
      if (outstyle .eq. 1) then
         dtout = (tfinal - t0)/float(nout)
         endif
c

c     # set gauges and geoclaw specific quantities:

      call set_gauges(.false., 2) ! no restart, nvar=2
      call set_geo()
      call set_grid(mx,dx)
      call read_topo_settings()

      ! read in Boussinesq solver parameters:
      call set_bouss(mx,mbc,mthbc,meqn)

c
c     # call user's routine setprob to set any specific parameters
c     # or other initialization required.
c
      call setprob

      ! Allocate aux
      if (maux > 0) then
         allocate(aux(maux, 1-mbc:mx+mbc), stat=allocate_status)
      else
         ! Allocate dummy array to prevent segfaults if it's
         ! dereferenced.  May be unnecessary.
         allocate(aux(1,1), stat=allocate_status)
      end if
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating aux array; exiting claw1ez'
         go to 900
      end if

c
c     # set aux array:
c
      if (maux .gt. 0)  then
         call setaux(mbc,mx,xlower,dx,maux,aux)
      endif

      ! Allocate q
      allocate(q(meqn, 1-mbc:mx+mbc), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating q array; exiting claw1ez'
         go to 900
      end if

c
c     # set initial conditions:
c
      call qinit(meqn,mbc,mx,xlower,dx,q,maux,aux)
c
      if (output_t0) then
c     # output initial data
          call out1(meqn,mbc,mx,xlower,dx,q,t0,0,aux,maux,
     &              outaux_init_only .or. outaux_always)
      endif

      ! Allocate work array
      allocate(work(mwork), stat=allocate_status)
      if (allocate_status .ne. 0) then
         print *, '*** Error allocating work array; exiting claw1ez'
         go to 900
      end if
c
c     ----------
c     Main loop:
c     ----------
c
      tend = t0
      do n=1,nout
         tstart = tend
         if (outstyle .eq. 1)  tend = tstart + dtout
         if (outstyle .eq. 2)  tend = tout(n)
         if (outstyle .eq. 3)  tend = tstart - 1.d0  !# single-step mode
c
         call claw1(meqn,mwaves,maux,mbc,mx,
     &           q,aux,xlower,dx,tstart,tend,dtv,cflv,nv,method,mthlim,
     &           mthbc,work,mwork,use_fwaves,info,bc1,rp1,src1,b4step1)
c
c        # check to see if an error occured:
         if (info .ne. 0) then
            write(6,*) '*** ERROR in claw1 ***  info =',info
            if (info.eq.1) then
               write(6,*) '***   either mx > maxmx or mbc < 2'
               endif
            if (info.eq.2) then
               write(6,*) '***   dt does not divide (tend - tstart)'
               write(6,*) '***   and dt is fixed since method(1)=0'
               endif
            if (info.eq.3) then
               write(6,*) '***   method(1)=1 and cflv(2) > cflv(1)'
               endif
            if (info.eq.4) then
               write(6,*) '***   mwork is too small'
               endif
            if (info.eq.11) then
               write(6,*) '***   Too many times steps, n > nv(1)'
               endif
            if (info.eq.12) then
               write(6,*)
     &          '***   The Courant number is greater than cflv(1)'
               write(6,*) '***   and dt is fixed since method(1)=0'
               endif

            go to 900
            endif
c
         dtv(1) = dtv(5)  !# use final dt as starting value on next call
c
c        # output solution at this time
c        ------------------------------
c
c        # if outstyle=1 or 2, then nstepout=1 and we output every time
c        # we reach this point, since claw1 was called for the entire time
c        # increment between outputs.
c
c        # if outstyle=3 then we only output if we have taken nstepout
c        # time steps since the last output.

c        # iframe is the frame number used to form file names in out1
         iframe = n/nstepout
         if (iframe*nstepout .eq. n) then
            call out1(meqn,mbc,mx,xlower,dx,q,tend,iframe,
     &                aux,maux,outaux_always)
            write(6,601) iframe,tend
            write(10,1010) tend,info,dtv(3),dtv(4),dtv(5),
     &           cflv(3),cflv(4),nv(2)
         endif
c
c        # formats for writing out information about this call to claw:
c
  601    format('CLAW1EZ: Frame ',i4,
     &           ' output files done at time t =',
     &           d12.4,/)
c
 1010    format('tend =',d15.4,/,
     &       'info =',i5,/,'smallest dt =',d15.4,/,'largest dt =',
     &       d15.4,/,'last dt =',d15.4,/,'largest cfl =',
     &         d15.4,/,'last cfl =',d15.4,/,'steps taken =',i4,/)
c
      end do
c
  900 continue

      if (monitor_fgmax) then
          write(6,*) 'Writing fgmax.txt file with mx = ',mx
          open(unit=iunit_fgmax, file='fgmax.txt', status='unknown',
     &         form='formatted')
          do i=1,mx
             etamax = hmax(i) + aux(1,i)
             write(iunit_fgmax,451) xcell(i),hmax(i),smax(i),etamax
 451         format(4f16.8)
          enddo
          close(iunit_fgmax)
      endif

      if (allocated(q))        deallocate(q)
      if (allocated(aux))      deallocate(aux)
      if (allocated(work))     deallocate(work)
      if (allocated(mthlim))   deallocate(mthlim)
      if (allocated(tout))     deallocate(tout)
      if (allocated(iout_q))   deallocate(iout_q)
      if (allocated(iout_aux)) deallocate(iout_aux)

      if (monitor_total_zeta) then
          close(iunit_total_zeta_mass)
          write(6,*) 'total_zeta_mass.txt written'
      endif

      if (monitor_runup) then
          close(iunit_runup)
          write(6,*) 'runup.txt written, used runup_tolerance = ',
     &               runup_tolerance
      endif
c
      return
      end


    MODULE biomath_constants_mod
! .. Default Accessibility ..
      PUBLIC
! ..
! .. Parameters ..
      INTEGER, PARAMETER :: dpkind = KIND(0.0D0)
      INTEGER, PARAMETER :: spkind = KIND(0.0)
      INTEGER, PARAMETER :: stdin = 5, stdout = 6
      REAL (dpkind), PARAMETER :: eight = 8.0E0_dpkind
      REAL (dpkind), PARAMETER :: five = 5.0E0_dpkind
      REAL (dpkind), PARAMETER :: four = 4.0E0_dpkind
      REAL (dpkind), PARAMETER :: hundred = 100.0E0_dpkind
      REAL (dpkind), PARAMETER :: nine = 9.0E0_dpkind
      REAL (dpkind), PARAMETER :: one = 1.0E0_dpkind
      REAL (dpkind), PARAMETER :: seven = 7.0E0_dpkind
      REAL (dpkind), PARAMETER :: six = 6.0E0_dpkind
      REAL (dpkind), PARAMETER :: sixth = one/six
      REAL (dpkind), PARAMETER :: ten = 10.0E0_dpkind
      REAL (dpkind), PARAMETER :: tenth = one/ten
      REAL (dpkind), PARAMETER :: thousand = 1000.0E0_dpkind
      REAL (dpkind), PARAMETER :: thousandth = one/thousand
      REAL (dpkind), PARAMETER :: three = 3.0E0_dpkind
      REAL (dpkind), PARAMETER :: twelve = 12.0E0_dpkind
      REAL (dpkind), PARAMETER :: two = 2.0E0_dpkind
      REAL (dpkind), PARAMETER :: zero = 0.0E0_dpkind
      REAL (dpkind), PARAMETER :: eighth = one/eight
      REAL (dpkind), PARAMETER :: fifth = one/five
      REAL (dpkind), PARAMETER :: fourth = one/four
      REAL (dpkind), PARAMETER :: half = one/two
      REAL (dpkind), PARAMETER :: hundredth = one/hundred
      REAL (dpkind), PARAMETER :: third = one/three
! ..
! .. Intrinsic Functions ..
      INTRINSIC KIND
! ..
    END MODULE biomath_constants_mod


module mod_random
! module for pseudo random numbers
 implicit none
 private
 public init_random_seed, randint, r4_uniform
contains
 subroutine init_random_seed(seed)
  implicit none
  integer, intent(out) :: seed
  integer   day,hour,i4_huge,milli,minute,month,second,year
  parameter (i4_huge=2147483647)
  double precision temp
  character*(10) time
  character*(8) date
  call date_and_time (date,time)
  read (date,'(i4,i2,i2)')year,month,day
  read (time,'(i2,i2,i2,1x,i3)')hour,minute,second,milli
  temp=0.0D+00
  temp=temp+dble(month-1)/11.0D+00
  temp=temp+dble(day-1)/30.0D+00
  temp=temp+dble(hour)/23.0D+00
  temp=temp+dble(minute)/59.0D+00
  temp=temp+dble(second)/59.0D+00
  temp=temp+dble(milli)/999.0D+00
  temp=temp/6.0D+00
  doext: do
    if(temp<=0.0D+00 )then
       temp=temp+1.0D+00
       cycle doext
    else
       exit doext
    end if
  enddo doext
  doext2: do
    if (1.0D+00<temp) then
       temp=temp-1.0D+00
       cycle doext2
    else
       exit doext2
    end if
  end do doext2
  seed=int(dble(i4_huge)*temp)
  if(seed == 0)       seed = 1
  if(seed == i4_huge) seed = seed-1
  return
 end subroutine init_random_seed
 integer function randint(i,j,seed)
  real               ::  a,b
  integer,intent(in) ::  i,j,seed
  a = real(i)
  b = real(j)
  randint=int(r4_uniform(a,b+1.0,seed))
 end function randint

 real function r4_uniform(b1,b2,seed)
  implicit none
  real b1,b2
  integer i4_huge,k,seed
  parameter (i4_huge=2147483647)
  if(seed == 0) then
   write(*,'(b1)')'R4_UNIFORM - Fatal error!'
   write(*,'(b1)')'Input value of SEED = 0.'
   stop '[ERROR] Chiquitan chiquitintatan'
  end if
  k=seed/127773
  seed=16807*(seed-k*17773)-k*2836
  if(seed<0) then
    seed=seed+i4_huge
  endif
  r4_uniform=b1+(b2-b1)*real(dble(seed)* 4.656612875D-10)
  return
 end function r4_uniform
end module

program init_renormalisation
 use iso_fortran_env
 use mod_random
 implicit none
 real :: a(8)
 integer :: i,j,k,l,n,seed
 integer :: n_T=60
 integer :: n_average=0
 real    :: x_cell(1:27),x_average,eta
 real    :: temperature=448.0     ! K
 real    :: k_B  = 8.61734E-5     ! eV/K
 real    :: beta, x, partition = 0.0
 real    :: probability_cell(1:27),free(1:27),free_min
 real    :: e_1,e_2
 call init_random_seed(seed)
 partition = 0.0
 beta = 1.0/(k_B*temperature)
 write(6,*)"Parameters:"
 read(5,*)  n_average
 x_average=(n_average/real(n_T))
 do i=1,8
  read(5,*)  a(i)
  write(6,*) a(i)
 end do
 write(6,*)"======"
 do i=1,n_T
  x=(i/real(n_T))
  write(6,*)x,Free_Energy(a,x)
 end do
 write(6,*)"======"
 x_cell(1:27) = x_average
  do l=1,27
   e_1=Free_Energy(a,x_cell(l))
  end do
 write(6,'(27(i2,1x))') (int(n_T*x_cell( l )) , l=1,27)
 write(6,*)"======"
 call update_probability(x_cell,free,partition,probability_cell)
 do k=1,1000
  i=randint(1,27,seed)
  j=randint(1,27,seed)
  do while ( i==j .or. x_cell(i) <= 0.0 .or. x_cell(j) <= 0.0 .or. x_cell(i) >= 1.0 .or. x_cell(j)>=1.0)
   i=randint(1,27,seed)
   j=randint(1,27,seed)
  end do
  e_1=Free_Energy(a,x_cell(i)) + Free_Energy(a,x_cell(j))
  n=randint(1,3,seed)
  x_cell(i)=x_cell(i)+n/60.0
  x_cell(j)=x_cell(j)-n/60.0
  e_2=Free_Energy(a,x_cell(i)) + Free_Energy(a,x_cell(j))
  if(e_1 >= e_2 ) then
   call update_probability(x_cell,free,partition,probability_cell)
   write(6,'(27(i2,1x),a1,1x,i2,1x,i2)') (int(n_T*x_cell( l )) ,l=1,27),':',int(n_t*averages()),int(sum(x_cell)*(n_T/27.0))
  else
   eta=R4_UNIFORM(0.0,1.0,SEED)
   if ( eta < exp(-( e_2 - e_1 )/(k_B*temperature)) ) then
    call update_probability(x_cell,free,partition,probability_cell)
    write(6,'(27(i2,1x),a1,1x,i2,1x,i2)') (int(n_T*x_cell( l )) ,l=1,27),':',int(n_t*averages()),int(sum(x_cell)*(n_T/27.0))
   else
   x_cell(i)=x_cell(i)-n/60.0
   x_cell(j)=x_cell(j)+n/60.0
   call update_probability(x_cell,free,partition,probability_cell)
   end if
  end if
 end do
 contains
 real function averages()
  implicit none
  integer :: i
  averages=0.0
  do i=1,27
   averages=averages+x_cell(i)*probability_cell(i)
  end do
  return
 end function averages
 subroutine update_probability(x_cell,free,partition,probability_cell)
 implicit none
  integer          :: j
  real,intent(in)  :: x_cell(1:27)
  real,intent(out) :: probability_cell(1:27)
  real,intent(out) :: partition,free(1:27)
  real :: free_min = 0.0
  partition=0.0
  do j=1,27
   free(j)=Free_Energy(a,x_cell(j) )
  end do
  free_min=minval(free)
  do j =1,27
   partition=partition + exp(-beta*(Free_Energy(a,x_cell(j) )-free_min ))
  end do
  do j=1,27
   probability_cell(j)=exp(-beta*(Free_Energy(a,x_cell(j) ) - free_min))/partition
  end do
  return
 end subroutine
 real function Free_Energy(a,x)
  implicit none
  real, intent(in) :: a(8)
  real,intent(in) :: x
  Free_Energy = a(1)*(x-a(2))**2 + a(3)*(x-a(4))**3 + &
                a(5)*(x-a(6))**4 + a(7)*(x-a(8))**5
  return
 end function Free_Energy
end program init_renormalisation


      SUBROUTINE sgbsl1 (ABD, LDA, N, ML, MU, IPVT, B, JOB)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, JOB
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD
      REAL(WP), DIMENSION(N) :: B

      CALL sgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)

      END SUBROUTINE sgbsl1

      SUBROUTINE dgbsl1 (ABD, LDA, N, ML, MU, IPVT, B, JOB)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, JOB
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(*) :: ABD
      REAL(WP), DIMENSION(N) :: B

      CALL dgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)

      END SUBROUTINE dgbsl1

#ifndef CRAY
      SUBROUTINE sgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)
      USE LIPREC, ONLY: WP => SP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, JOB
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
      REAL(WP), DIMENSION(N) :: B
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: K, KB, L, LA, LB, LM, M, NM1
      REAL(WP) :: T
C-----------------------------------------------
C   E X T E R N A L   F U N C T I O N S
C-----------------------------------------------
      REAL(WP) , EXTERNAL :: sdot
      EXTERNAL saxpy
C-----------------------------------------------
c
c     sgbsl solves the real band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by sgbco or sgbfa.
c
c     on ENTRY
c
c        abd     REAL(lda, n)
c                the output from sgbco or sgbfa.
c
c        lda     INTEGER
c                the leading DIMENSION of the array  abd .
c
c        n       INTEGER
c                the order of the original matrix.
c
c        ml      INTEGER
c                number of diagonals below the main diagonal.
c
c        mu      INTEGER
c                number of diagonals above the main diagonal.
c
c        ipvt    INTEGER(n)
c                the pivot vector from sgbco or sgbfa.
c
c        b       REAL(n)
c                the right hand side vector.
c
c        job     INTEGER
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , WHERE
c                            trans(a)  is the TRANSPOSE.
c
c     on RETURN
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if sgbco has set rcond .gt. 0.0
c        or sgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas saxpy ,sdot
c     fortran min
c
c     internal variables
c
c
      m = mu + ml + 1
      nm1 = n - 1
      IF (job .eq. 0) THEN
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         IF (ml .ne. 0) THEN
            DO k = 1, nm1
               lm = MIN(ml,n - k)
               l = ipvt(k)
               t = b(l)
               IF (l .ne. k) THEN
                  b(l) = b(k)
                  b(k) = t
               END IF
               CALL saxpy (lm, t, abd(m+1,k), 1, b(k+1), 1)
            END DO
         END IF
c
c        now solve  u*x = y
c
         DO kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = MIN(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            CALL saxpy (lm, t, abd(la,k), 1, b(lb), 1)
         END DO
      ELSE
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         DO k = 1, n
            lm = MIN(k,m) - 1
            la = m - lm
            lb = k - lm
            t = sdot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k)-t)/abd(m,k)
         END DO
c
c        now solve trans(l)*x = y
c
         IF (ml .ne. 0) THEN
            DO kb = 1, nm1
               k = n - kb
               lm = MIN(ml,n - k)
               b(k) = b(k) + sdot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               IF (l .ne. k) THEN
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
               END IF
            END DO
         END IF
      END IF

      END SUBROUTINE sgbsl

      SUBROUTINE dgbsl (ABD, LDA, N, ML, MU, IPVT, B, JOB)
      USE LIPREC, ONLY: WP => DP
      IMPLICIT NONE
C-----------------------------------------------
C   D U M M Y   A R G U M E N T S
C-----------------------------------------------
      INTEGER LDA, N, ML, MU, JOB
      INTEGER, DIMENSION(N) :: IPVT
      REAL(WP), DIMENSION(LDA,N) :: ABD
      REAL(WP), DIMENSION(N) :: B
C-----------------------------------------------
C   L O C A L   V A R I A B L E S
C-----------------------------------------------
      INTEGER :: K, KB, L, LA, LB, LM, M, NM1
      REAL(WP) :: T
C-----------------------------------------------
C   E X T E R N A L   F U N C T I O N S
C-----------------------------------------------
      REAL(WP) , EXTERNAL :: ddot
      EXTERNAL daxpy
C-----------------------------------------------
c
c     sgbsl solves the REAL band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by sgbco or sgbfa.
c
c     on ENTRY
c
c        abd     REAL(lda, n)
c                the output from sgbco or sgbfa.
c
c        lda     INTEGER
c                the leading DIMENSION of the array  abd .
c
c        n       INTEGER
c                the order of the original matrix.
c
c        ml      INTEGER
c                number of diagonals below the main diagonal.
c
c        mu      INTEGER
c                number of diagonals above the main diagonal.
c
c        ipvt    INTEGER(n)
c                the pivot vector from sgbco or sgbfa.
c
c        b       REAL(n)
c                the right hand side vector.
c
c        job     INTEGER
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , WHERE
c                            trans(a)  is the TRANSPOSE.
c
c     on RETURN
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if sgbco has set rcond .gt. 0.0
c        or sgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call sgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call sgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy ,ddot
c     fortran min
c
c     internal variables
c
c
      m = mu + ml + 1
      nm1 = n - 1
      IF (job .eq. 0) THEN
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         IF (ml .ne. 0) THEN
            DO k = 1, nm1
               lm = MIN(ml,n - k)
               l = ipvt(k)
               t = b(l)
               IF (l .ne. k) THEN
                  b(l) = b(k)
                  b(k) = t
               END IF
               CALL daxpy (lm, t, abd(m+1,k), 1, b(k+1), 1)
            END DO
         END IF
c
c        now solve  u*x = y
c
         DO kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = MIN(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            CALL daxpy (lm, t, abd(la,k), 1, b(lb), 1)
         END DO
      ELSE
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         DO k = 1, n
            lm = MIN(k,m) - 1
            la = m - lm
            lb = k - lm
            t = ddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k)-t)/abd(m,k)
         END DO
c
c        now solve trans(l)*x = y
c
         IF (ml .ne. 0) THEN
            DO kb = 1, nm1
               k = n - kb
               lm = MIN(ml,n - k)
               b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               IF (l .ne. k) THEN
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
               END IF
            END DO
         END IF
      END IF

      END SUBROUTINE dgbsl
#endif


          program demo_atan2
          implicit none
          real(4) :: x = 1.e0_4, y = 0.5e0_4
             x = atan2(y,x)
          end program demo_atan2


      SUBROUTINE constants
      USE global
      IMPLICIT NONE

!C --- Constants for Kappa function ------------------------------------

!-------- For HOT electron -----------------------------------
      PHE = -KH + 0.50      ! constant at power in Kappa
      BH = 1.0/(KH - 1.50) ! constant at dinominator in Kappa

!--------- For COLD electron ----------------------------------
      PC = -KC + 0.50      ! constant at power in Kappa
      BC = 1.0/(TU*(KC - 1.50)) ! constant at dinominator in Kappa
!-------------- For Cairns distribution ------------------------
      BTH = 4*ALPH/(3*ALPH + 1)
      BTC = 4*ALPC/(3*ALPC + 1)

      END SUBROUTINE constants


	subroutine goor_solve(sl,tl,el,su,tu,eu,p,s0,t0,p0,sigb,sns,tns)
ccc
ccc
ccc
ccc	DESCRIPTION :	Find the intersection of a potential density surface
ccc			between two bottles using a bisection method
ccc
ccc	PRECISION :	Double
ccc
ccc	INPUT :		sl, su		bottle salinities
ccc			tl, tu		bottle in situ temperatures
ccc			el, eu		bottle e values
ccc			p		bottle pressures (the same)
ccc			s0		emanating bottle salinity
ccc			t0		emanating bottle in situ temperature
ccc			p0		emanating bottle pressure
ccc
ccc	OUTPUT :	sns		salinity of the neutral surface
ccc					intersection with the bottle pair
ccc			tns		in situ temperature of the intersection
ccc
ccc
ccc	UNITS :		salinities	psu (IPSS-78)
ccc			temperatures	degrees C (IPTS-68)
ccc			pressures	db
ccc
ccc
ccc	AUTHOR :	David Jackett
ccc
ccc	CREATED :	June 1993
ccc
ccc	REVISION :	1.1		30/6/93
ccc
ccc
ccc
	implicit double precision (a-h,o-z)

	rl = 0.
	ru = 1.

	pmid = (p+p0)/2.0

	thl = theta(sl,tl,p,pmid)
	thu = theta(su,tu,p,pmid)

	iter = 0
	isuccess = 0

	do while(isuccess.eq.0)

	  iter = iter+1

	  rm = (rl+ru)/2

	  sm = sl+rm*(su-sl)
	  thm = thl+rm*(thu-thl)

	  tm = theta(sm,thm,pmid,p)

	  sd = svan(sm,thm,pmid,sigma)

	  em = sigma-sigb

	  if(el*em.lt.0.) then
	    ru = rm
	    eu = em
	  elseif(em*eu.lt.0.) then
	    rl = rm
	    el = em
	  elseif(em.eq.0.) then
	    sns = sm
	    tns = tm
	    isuccess = 1
	  end if

	  if(isuccess.eq.0) then
	    if(abs(em).le.5.e-5.and.abs(ru-rl).le.5.e-3) then
	      sns = sm
	      tns = tm
	      isuccess = 1
	    elseif(iter.le.20) then
	      isuccess = 0
	    else
	      print *, 'WARNING 1 in goor-solve.f'
	      sns = sm
	      tns = tm
	      isuccess = 1
	    end if
	  end if

	end do

	return

	end


!*****************************************************************************
!
! MODULE: Utilities_Statistics
!
!   SUBROUTINE: InitStat()
!   SUBROUTINE: AddStat()
!   SUBROUTINE: CalcStat()
!
!
! Usage)
!
!   1) InitStat() initializes private working variables in this module.
!   2) AddStat() accumulates sample data to the working variables.
!   3) CalcStat() calculates statistics using the accumulated data.
!
!
! Created by Y.Tahara in Aug,02
!
!*****************************************************************************

module Utilities_Statistics

  !--- Modules

  use type_kinds,        only : fp_kind
  use ParametersGenCoef, only : ZERO, INFINITE

  !--- implicit

  implicit none

  !--- Private & Public

  private
  public InitStat
  public AddStat
  public CalcStat
  public StatResults

  !--- structure definition of a vaiable to keep statistical results

  type StatResults
    real(fp_kind) :: max1
    real(fp_kind) :: max2
    real(fp_kind) :: min1
    real(fp_kind) :: min2
    real(fp_kind) :: mean1
    real(fp_kind) :: mean2
    real(fp_kind) :: sd1
    real(fp_kind) :: sd2
    real(fp_kind) :: corr
    real(fp_kind) :: rmse
    real(fp_kind) :: sderr
    real(fp_kind) :: meanerr
    real(fp_kind) :: covar
  end type StatResults

  !--- global variables

  integer      ,allocatable,save :: numdt(:)
  real(fp_kind),allocatable,save :: sum1(:),     sum2(:)
  real(fp_kind),allocatable,save :: sum_dbl1(:), sum_dbl2(:)
  real(fp_kind),allocatable,save :: sum_mul12(:)
  real(fp_kind),allocatable,save :: mx1(:),      mx2(:)
  real(fp_kind),allocatable,save :: mn1(:),      mn2(:)

  !--- parameters

  real(fp_kind),parameter :: RMISS_STAT = -99999._fp_kind

  contains

  !===========================================================================
  !
  ! SUBROUTINE: InitStat()
  !
  !   InitStat() initializes private working variables defined in this
  !   module. The variables are used to accumulate statistical sample
  !   data information.
  !
  !===========================================================================

  subroutine InitStat( num_idx )

    !--- interface

    integer,intent(in) :: num_idx       ! # of statistical categories

    !--- local valiables

    integer,save :: num_idx_last  = -1

    !--- allocate

    if( num_idx  /= num_idx_last )then

      if( num_idx_last > 0 )then
        deallocate( numdt              )
        deallocate( sum1,     sum2     )
        deallocate( sum_dbl1, sum_dbl2 )
        deallocate( sum_mul12          )
        deallocate( mx1,      mx2      )
        deallocate( mn1,      mn2      )
      endif

      allocate( numdt    (num_idx) )
      allocate( sum1     (num_idx) )
      allocate( sum2     (num_idx) )
      allocate( sum_dbl1 (num_idx) )
      allocate( sum_dbl2 (num_idx) )
      allocate( sum_mul12(num_idx) )
      allocate( mx1      (num_idx) )
      allocate( mx2      (num_idx) )
      allocate( mn1      (num_idx) )
      allocate( mn2      (num_idx) )

      num_idx_last  = num_idx

    endif

    !--- Initialize

    numdt    (:) = 0
    sum1     (:) = ZERO
    sum2     (:) = ZERO
    sum_dbl1 (:) = ZERO
    sum_dbl2 (:) = ZERO
    sum_mul12(:) = ZERO
    mx1      (:) = -INFINITE
    mx2      (:) = -INFINITE
    mn1      (:) =  INFINITE
    mn2      (:) =  INFINITE

  end subroutine InitStat

  !===========================================================================
  !
  ! SUBROUTINE: AddStat()
  !
  !   AddStat() accumulates a set of statistical data to working variables.
  !   Before calling it, InitStat() must have been called.
  !
  !===========================================================================

  subroutine AddStat( idx, dx1, dx2 )

    !--- interface

    integer      ,intent(in) :: idx       ! statistical categoly number
    real(fp_kind),intent(in) :: dx1, dx2  ! data 1 and 2 to be accumulated

    !--- # of samples

    numdt(idx) = numdt(idx) + 1

    !--- accumulate

    sum1     (idx) = sum1     (idx) + dx1
    sum2     (idx) = sum2     (idx) + dx2
    sum_dbl1 (idx) = sum_dbl1 (idx) + dx1*dx1
    sum_dbl2 (idx) = sum_dbl2 (idx) + dx2*dx2
    sum_mul12(idx) = sum_mul12(idx) + dx1*dx2

    !--- check max,min

    mx1(idx) = max( mx1(idx), dx1 )
    mx2(idx) = max( mx2(idx), dx2 )
    mn1(idx) = min( mn1(idx), dx1 )
    mn2(idx) = min( mn2(idx), dx2 )

  end subroutine AddStat

  !===========================================================================
  !
  ! SUBROUTINE: CalcStat()
  !
  !   CalcStat() calculates statistics. The results are stored in
  !   a structural variable, whose structure is defined in this module.
  !
  !===========================================================================

  subroutine CalcStat( idx, num, stat)

    !--- interface

    integer          ,intent(in)  :: idx        ! statistical categoly number
    integer          ,intent(out) :: num        ! number of sample data
    type(StatResults),intent(out) :: stat       ! results

    !--- local variables

    real(fp_kind) :: rnum
    real(fp_kind) :: mse

    !--- check then number of data in the index

    num = numdt(idx)

    if( num <= 0 )then
      stat%max1    = RMISS_STAT
      stat%max2    = RMISS_STAT
      stat%min1    = RMISS_STAT
      stat%min2    = RMISS_STAT
      stat%mean1   = RMISS_STAT
      stat%mean2   = RMISS_STAT
      stat%sd1     = RMISS_STAT
      stat%sd2     = RMISS_STAT
      stat%meanerr = RMISS_STAT
      stat%rmse    = RMISS_STAT
      stat%sderr   = RMISS_STAT
      stat%corr    = RMISS_STAT
      stat%covar   = RMISS_STAT
      return
    endif

    !--- # of samples in real

    rnum = real( num, fp_kind )

    !--- max and min for each

    stat%max1 = mx1(idx)
    stat%max2 = mx2(idx)
    stat%min1 = mn1(idx)
    stat%min2 = mn2(idx)

    !--- mean for each

    stat%mean1 = sum1(idx) / rnum
    stat%mean2 = sum2(idx) / rnum

    !--- mean difference

    stat%meanerr = stat%mean1 - stat%mean2

    !--- standard deviation for each

    stat%sd1 = sqrt( max( (sum_dbl1(idx)/rnum - stat%mean1**2), ZERO ) )
    stat%sd2 = sqrt( max( (sum_dbl2(idx)/rnum - stat%mean2**2), ZERO ) )

    !--- RMS and SD difference

    mse = (sum_dbl1(idx) - 2*sum_mul12(idx) + sum_dbl2(idx)) / rnum

    stat%rmse  = sqrt( max( (mse                               ), ZERO ) )
    stat%sderr = sqrt( max( (mse - (stat%mean1 - stat%mean2)**2), ZERO ) )

    !--- covariance

    stat%covar = sum_mul12(idx)/rnum - stat%mean1*stat%mean2

    !--- correlation

    if( stat%sd1 == ZERO  .or.  stat%sd2 == ZERO )then
      stat%corr = ZERO
    else
      stat%corr = stat%covar / (stat%sd1 * stat%sd2)
    endif

  end subroutine CalcStat

end module Utilities_Statistics


      subroutine fpintb(t,n,bint,nk1,x,y)
c  subroutine fpintb calculates integrals of the normalized b-splines
c  nj,k+1(x) of degree k, defined on the set of knots t(j),j=1,2,...n.
c  it makes use of the formulae of gaffney for the calculation of
c  indefinite integrals of b-splines.
c
c  calling sequence:
c     call fpintb(t,n,bint,nk1,x,y)
c
c  input parameters:
c    t    : real array,length n, containing the position of the knots.
c    n    : integer value, giving the number of knots.
c    nk1  : integer value, giving the number of b-splines of degree k,
c           defined on the set of knots ,i.e. nk1 = n-k-1.
c    x,y  : real values, containing the end points of the integration
c           interval.
c  output parameter:
c    bint : array,length nk1, containing the integrals of the b-splines.
c  ..
c  ..scalars arguments..
      integer n,nk1
      real x,y
c  ..array arguments..
      real t(n),bint(nk1)
c  ..local scalars..
      integer i,ia,ib,it,j,j1,k,k1,l,li,lj,lk,l0,min
      real a,ak,arg,b,f,one
c  ..local arrays..
      real aint(6),h(6),h1(6)
c  initialization.
      one = 0.1e+01
      k1 = n-nk1
      ak = k1
      k = k1-1
      do 10 i=1,nk1
        bint(i) = 0.
  10  continue
c  the integration limits are arranged in increasing order.
      a = x
      b = y
      min = 0
      if(a-b) 30,160,20
  20  a = y
      b = x
      min = 1
  30  if(a.lt.t(k1)) a = t(k1)
      if(b.gt.t(nk1+1)) b = t(nk1+1)
c  using the expression of gaffney for the indefinite integral of a
c  b-spline we find that
c  bint(j) = (t(j+k+1)-t(j))*(res(j,b)-res(j,a))/(k+1)
c    where for t(l) <= x < t(l+1)
c    res(j,x) = 0, j=1,2,...,l-k-1
c             = 1, j=l+1,l+2,...,nk1
c             = aint(j+k-l+1), j=l-k,l-k+1,...,l
c               = sumi((x-t(j+i))*nj+i,k+1-i(x)/(t(j+k+1)-t(j+i)))
c                 i=0,1,...,k
      l = k1
      l0 = l+1
c  set arg = a.
      arg = a
      do 90 it=1,2
c  search for the knot interval t(l) <= arg < t(l+1).
  40    if(arg.lt.t(l0) .or. l.eq.nk1) go to 50
        l = l0
        l0 = l+1
        go to 40
c  calculation of aint(j), j=1,2,...,k+1.
c  initialization.
  50    do 55 j=1,k1
          aint(j) = 0.
  55    continue
        aint(1) = (arg-t(l))/(t(l+1)-t(l))
        h1(1) = one
        do 70 j=1,k
c  evaluation of the non-zero b-splines of degree j at arg,i.e.
c    h(i+1) = nl-j+i,j(arg), i=0,1,...,j.
          h(1) = 0.
          do 60 i=1,j
            li = l+i
            lj = li-j
            f = h1(i)/(t(li)-t(lj))
            h(i) = h(i)+f*(t(li)-arg)
            h(i+1) = f*(arg-t(lj))
  60      continue
c  updating of the integrals aint.
          j1 = j+1
          do 70 i=1,j1
            li = l+i
            lj = li-j1
            aint(i) = aint(i)+h(i)*(arg-t(lj))/(t(li)-t(lj))
            h1(i) = h(i)
  70    continue
        if(it.eq.2) go to 100
c  updating of the integrals bint
        lk = l-k
        ia = lk
        do 80 i=1,k1
          bint(lk) = -aint(i)
          lk = lk+1
  80    continue
c  set arg = b.
        arg = b
  90  continue
c  updating of the integrals bint.
 100  lk = l-k
      ib = lk-1
      do 110 i=1,k1
        bint(lk) = bint(lk)+aint(i)
        lk = lk+1
 110  continue
      if(ib.lt.ia) go to 130
      do 120 i=ia,ib
        bint(i) = bint(i)+one
 120  continue
c  the scaling factors are taken into account.
 130  f = one/ak
      do 140 i=1,nk1
        j = i+k1
        bint(i) = bint(i)*(t(j)-t(i))*f
 140  continue
c  the order of the integration limits is taken into account.
      if(min.eq.0) go to 160
      do 150 i=1,nk1
        bint(i) = -bint(i)
 150  continue
 160  return
      end