c     This function calculate the reduced structure function, with energy
c     fraction given by "x", at scale "Qsquare"
      real*8 function eepdf_tilde_calc(x,Qsquare,n,partonid,beamid)
      implicit none
      real*8 x,Qsquare
      real*8 me
      data me /0.511d-3/
      real*8 PI
      real*8 alphaem
c     In Gmu scheme
      data alphaem/0.007562397d0/
      real*8 beta
      integer n,partonid,beamid
      real*8 isr_tilde
      real*8 res
      data res/0d0/

      PI=4.D0*DATAN(1.D0)
      beta = alphaem/PI * (dlog(Qsquare/me/me)-1d0)

c     electron beam
      if (beamid .eq. 11) then
c     other partons are zero
          if (partonid .ne. 11) then
             res = 0d0
          else
             if (n .eq. 1) then
                res = isr_tilde(x,beta)
             else
                res = 0d0
             endif
          endif
      else if (beamid .eq. -11) then
          if (partonid .ne. -11) then
              res = 0d0
          else
             if (n .eq. 1) then
                res = isr_tilde(x,beta)
             else
                res = 0d0
             endif
          endif
      endif
      eepdf_tilde_calc = res
      end


      SUBROUTINE GPT (DMJD,DLAT,DLON,DHGT,PRES,TEMP,UNDU)
*+
*  - - - - - - - - -
*   G P T
*  - - - - - - - - -
*
*  This routine is part of the International Earth Rotation and
*  Reference Systems Service (IERS) Conventions software collection.
*
*  This subroutine determines Global Pressure and Temperature (Boehm et al. 2007)
*  based on Spherical Harmonics up to degree and order 9.
*
*  In general, Class 1, 2, and 3 models represent physical effects that
*  act on geodetic parameters while canonical models provide lower-level
*  representations or basic computations that are used by Class 1, 2, or
*  3 models.
*
*  Status: Class 1 model
*
*     Class 1 models are those recommended to be used a priori in the
*     reduction of raw space geodetic data in order to determine
*     geodetic parameter estimates.
*     Class 2 models are those that eliminate an observational
*     singularity and are purely conventional in nature.
*     Class 3 models are those that are not required as either Class
*     1 or 2.
*     Canonical models are accepted as is and cannot be classified as a
*     Class 1, 2, or 3 model.
*
*  Given:
*     DMJD           d      Modified Julian Date
*     DLAT           d      Latitude given in radians (North Latitude)
*     DLON           d      Longitude given in radians (East Longitude)
*     DHGT           d      Ellipsoidal height in meters
*
*  Returned:
*     PRES           d      Pressure given in hPa
*     TEMP           d      Temperature in degrees Celsius
*     UNDU           d      Geoid undulation in meters (Note 1)
*
*  Notes:
*
*  1) This is from a 9x9 Earth Gravitational Model (EGM).
*
*  Test case:
*     given input: DMJD = 55055D0
*                  DLAT = 0.6708665767D0 radians (NRAO, Green Bank, WV)
*                  DLON = -1.393397187D0 radians
*                  DHGT = 812.546 meters
*     expected output: PRES = 919.1930225603726967D0 hPa
*                      TEMP = 28.94460920276309679D0 degrees Celsius
*                      UNDU = -42.78796423912972813D0 meters
*
*  References:
*
*     Boehm, J., Heinkelmann, R. and Schuh, H., 2007, "Short Note: A
*     Global model of pressure and temperature for geodetic applications",
*     Journal of Geodesy, 81(10), pp. 679-683.
*
*     Petit, G. and Luzum, B. (eds.), IERS Conventions (2010),
*     IERS Technical Note No. 36, BKG (2010)
*
*  Revisions:
*  2006 June 12 J. Boehm    Original code
*  2006 June 16 J. Boehm    Accounted for geoid undulation
*  2006 August 14 O. Montenbruck Recursions for Legendre polynomials
*  2009 February 13 B.E. Stetzler Added header and copyright
*  2009 March 30 B.E. Stetzler More modifications and defined twopi
*  2009 March 31 B.E. Stetzler Provided test case
*  2009 July  29 B.E. Stetzler Capitalized all variables for FORTRAN 77
*                              compatibility and corrected test case
*                              latitude and longitude coordinates
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION DMJD,DLAT,DLON,DHGT,PRES,TEMP,UNDU

      DOUBLE PRECISION V(10,10),W(10,10),
     . AP_MEAN(55),BP_MEAN(55),AP_AMP(55),BP_AMP(55),
     . AT_MEAN(55),BT_MEAN(55),AT_AMP(55),BT_AMP(55),
     . A_GEOID(55),B_GEOID(55)

      INTEGER*4 I,N,M,NMAX,MMAX
      DOUBLE PRECISION TWOPI,DOY,TEMP0,PRES0,
     . APM,APA,ATM,ATA,HORT,X,Y,Z

      PARAMETER (TWOPI = 6.283185307179586476925287D0)

      DATA (A_GEOID(I),I=1,55)/
     .-5.6195D-001,-6.0794D-002,-2.0125D-001,-6.4180D-002,-3.6997D-002,
     .+1.0098D+001,+1.6436D+001,+1.4065D+001,+1.9881D+000,+6.4414D-001,
     .-4.7482D+000,-3.2290D+000,+5.0652D-001,+3.8279D-001,-2.6646D-002,
     .+1.7224D+000,-2.7970D-001,+6.8177D-001,-9.6658D-002,-1.5113D-002,
     .+2.9206D-003,-3.4621D+000,-3.8198D-001,+3.2306D-002,+6.9915D-003,
     .-2.3068D-003,-1.3548D-003,+4.7324D-006,+2.3527D+000,+1.2985D+000,
     .+2.1232D-001,+2.2571D-002,-3.7855D-003,+2.9449D-005,-1.6265D-004,
     .+1.1711D-007,+1.6732D+000,+1.9858D-001,+2.3975D-002,-9.0013D-004,
     .-2.2475D-003,-3.3095D-005,-1.2040D-005,+2.2010D-006,-1.0083D-006,
     .+8.6297D-001,+5.8231D-001,+2.0545D-002,-7.8110D-003,-1.4085D-004,
     .-8.8459D-006,+5.7256D-006,-1.5068D-006,+4.0095D-007,-2.4185D-008/

      DATA (B_GEOID(I),I=1,55)/
     .+0.0000D+000,+0.0000D+000,-6.5993D-002,+0.0000D+000,+6.5364D-002,
     .-5.8320D+000,+0.0000D+000,+1.6961D+000,-1.3557D+000,+1.2694D+000,
     .+0.0000D+000,-2.9310D+000,+9.4805D-001,-7.6243D-002,+4.1076D-002,
     .+0.0000D+000,-5.1808D-001,-3.4583D-001,-4.3632D-002,+2.2101D-003,
     .-1.0663D-002,+0.0000D+000,+1.0927D-001,-2.9463D-001,+1.4371D-003,
     .-1.1452D-002,-2.8156D-003,-3.5330D-004,+0.0000D+000,+4.4049D-001,
     .+5.5653D-002,-2.0396D-002,-1.7312D-003,+3.5805D-005,+7.2682D-005,
     .+2.2535D-006,+0.0000D+000,+1.9502D-002,+2.7919D-002,-8.1812D-003,
     .+4.4540D-004,+8.8663D-005,+5.5596D-005,+2.4826D-006,+1.0279D-006,
     .+0.0000D+000,+6.0529D-002,-3.5824D-002,-5.1367D-003,+3.0119D-005,
     .-2.9911D-005,+1.9844D-005,-1.2349D-006,-7.6756D-009,+5.0100D-008/

      DATA (AP_MEAN(I),I=1,55)/
     .+1.0108D+003,+8.4886D+000,+1.4799D+000,-1.3897D+001,+3.7516D-003,
     .-1.4936D-001,+1.2232D+001,-7.6615D-001,-6.7699D-002,+8.1002D-003,
     .-1.5874D+001,+3.6614D-001,-6.7807D-002,-3.6309D-003,+5.9966D-004,
     .+4.8163D+000,-3.7363D-001,-7.2071D-002,+1.9998D-003,-6.2385D-004,
     .-3.7916D-004,+4.7609D+000,-3.9534D-001,+8.6667D-003,+1.1569D-002,
     .+1.1441D-003,-1.4193D-004,-8.5723D-005,+6.5008D-001,-5.0889D-001,
     .-1.5754D-002,-2.8305D-003,+5.7458D-004,+3.2577D-005,-9.6052D-006,
     .-2.7974D-006,+1.3530D+000,-2.7271D-001,-3.0276D-004,+3.6286D-003,
     .-2.0398D-004,+1.5846D-005,-7.7787D-006,+1.1210D-006,+9.9020D-008,
     .+5.5046D-001,-2.7312D-001,+3.2532D-003,-2.4277D-003,+1.1596D-004,
     .+2.6421D-007,-1.3263D-006,+2.7322D-007,+1.4058D-007,+4.9414D-009/

      DATA (BP_MEAN(I),I=1,55)/
     .+0.0000D+000,+0.0000D+000,-1.2878D+000,+0.0000D+000,+7.0444D-001,
     .+3.3222D-001,+0.0000D+000,-2.9636D-001,+7.2248D-003,+7.9655D-003,
     .+0.0000D+000,+1.0854D+000,+1.1145D-002,-3.6513D-002,+3.1527D-003,
     .+0.0000D+000,-4.8434D-001,+5.2023D-002,-1.3091D-002,+1.8515D-003,
     .+1.5422D-004,+0.0000D+000,+6.8298D-001,+2.5261D-003,-9.9703D-004,
     .-1.0829D-003,+1.7688D-004,-3.1418D-005,+0.0000D+000,-3.7018D-001,
     .+4.3234D-002,+7.2559D-003,+3.1516D-004,+2.0024D-005,-8.0581D-006,
     .-2.3653D-006,+0.0000D+000,+1.0298D-001,-1.5086D-002,+5.6186D-003,
     .+3.2613D-005,+4.0567D-005,-1.3925D-006,-3.6219D-007,-2.0176D-008,
     .+0.0000D+000,-1.8364D-001,+1.8508D-002,+7.5016D-004,-9.6139D-005,
     .-3.1995D-006,+1.3868D-007,-1.9486D-007,+3.0165D-010,-6.4376D-010/

      DATA (AP_AMP(I),I=1,55)/
     .-1.0444D-001,+1.6618D-001,-6.3974D-002,+1.0922D+000,+5.7472D-001,
     .-3.0277D-001,-3.5087D+000,+7.1264D-003,-1.4030D-001,+3.7050D-002,
     .+4.0208D-001,-3.0431D-001,-1.3292D-001,+4.6746D-003,-1.5902D-004,
     .+2.8624D+000,-3.9315D-001,-6.4371D-002,+1.6444D-002,-2.3403D-003,
     .+4.2127D-005,+1.9945D+000,-6.0907D-001,-3.5386D-002,-1.0910D-003,
     .-1.2799D-004,+4.0970D-005,+2.2131D-005,-5.3292D-001,-2.9765D-001,
     .-3.2877D-002,+1.7691D-003,+5.9692D-005,+3.1725D-005,+2.0741D-005,
     .-3.7622D-007,+2.6372D+000,-3.1165D-001,+1.6439D-002,+2.1633D-004,
     .+1.7485D-004,+2.1587D-005,+6.1064D-006,-1.3755D-008,-7.8748D-008,
     .-5.9152D-001,-1.7676D-001,+8.1807D-003,+1.0445D-003,+2.3432D-004,
     .+9.3421D-006,+2.8104D-006,-1.5788D-007,-3.0648D-008,+2.6421D-010/

      DATA (BP_AMP(I),I=1,55)/
     .+0.0000D+000,+0.0000D+000,+9.3340D-001,+0.0000D+000,+8.2346D-001,
     .+2.2082D-001,+0.0000D+000,+9.6177D-001,-1.5650D-002,+1.2708D-003,
     .+0.0000D+000,-3.9913D-001,+2.8020D-002,+2.8334D-002,+8.5980D-004,
     .+0.0000D+000,+3.0545D-001,-2.1691D-002,+6.4067D-004,-3.6528D-005,
     .-1.1166D-004,+0.0000D+000,-7.6974D-002,-1.8986D-002,+5.6896D-003,
     .-2.4159D-004,-2.3033D-004,-9.6783D-006,+0.0000D+000,-1.0218D-001,
     .-1.3916D-002,-4.1025D-003,-5.1340D-005,-7.0114D-005,-3.3152D-007,
     .+1.6901D-006,+0.0000D+000,-1.2422D-002,+2.5072D-003,+1.1205D-003,
     .-1.3034D-004,-2.3971D-005,-2.6622D-006,+5.7852D-007,+4.5847D-008,
     .+0.0000D+000,+4.4777D-002,-3.0421D-003,+2.6062D-005,-7.2421D-005,
     .+1.9119D-006,+3.9236D-007,+2.2390D-007,+2.9765D-009,-4.6452D-009/

      DATA (AT_MEAN(I),I=1,55)/
     .+1.6257D+001,+2.1224D+000,+9.2569D-001,-2.5974D+001,+1.4510D+000,
     .+9.2468D-002,-5.3192D-001,+2.1094D-001,-6.9210D-002,-3.4060D-002,
     .-4.6569D+000,+2.6385D-001,-3.6093D-002,+1.0198D-002,-1.8783D-003,
     .+7.4983D-001,+1.1741D-001,+3.9940D-002,+5.1348D-003,+5.9111D-003,
     .+8.6133D-006,+6.3057D-001,+1.5203D-001,+3.9702D-002,+4.6334D-003,
     .+2.4406D-004,+1.5189D-004,+1.9581D-007,+5.4414D-001,+3.5722D-001,
     .+5.2763D-002,+4.1147D-003,-2.7239D-004,-5.9957D-005,+1.6394D-006,
     .-7.3045D-007,-2.9394D+000,+5.5579D-002,+1.8852D-002,+3.4272D-003,
     .-2.3193D-005,-2.9349D-005,+3.6397D-007,+2.0490D-006,-6.4719D-008,
     .-5.2225D-001,+2.0799D-001,+1.3477D-003,+3.1613D-004,-2.2285D-004,
     .-1.8137D-005,-1.5177D-007,+6.1343D-007,+7.8566D-008,+1.0749D-009/

      DATA (BT_MEAN(I),I=1,55)/
     .+0.0000D+000,+0.0000D+000,+1.0210D+000,+0.0000D+000,+6.0194D-001,
     .+1.2292D-001,+0.0000D+000,-4.2184D-001,+1.8230D-001,+4.2329D-002,
     .+0.0000D+000,+9.3312D-002,+9.5346D-002,-1.9724D-003,+5.8776D-003,
     .+0.0000D+000,-2.0940D-001,+3.4199D-002,-5.7672D-003,-2.1590D-003,
     .+5.6815D-004,+0.0000D+000,+2.2858D-001,+1.2283D-002,-9.3679D-003,
     .-1.4233D-003,-1.5962D-004,+4.0160D-005,+0.0000D+000,+3.6353D-002,
     .-9.4263D-004,-3.6762D-003,+5.8608D-005,-2.6391D-005,+3.2095D-006,
     .-1.1605D-006,+0.0000D+000,+1.6306D-001,+1.3293D-002,-1.1395D-003,
     .+5.1097D-005,+3.3977D-005,+7.6449D-006,-1.7602D-007,-7.6558D-008,
     .+0.0000D+000,-4.5415D-002,-1.8027D-002,+3.6561D-004,-1.1274D-004,
     .+1.3047D-005,+2.0001D-006,-1.5152D-007,-2.7807D-008,+7.7491D-009/

      DATA (AT_AMP(I),I=1,55)/
     .-1.8654D+000,-9.0041D+000,-1.2974D-001,-3.6053D+000,+2.0284D-002,
     .+2.1872D-001,-1.3015D+000,+4.0355D-001,+2.2216D-001,-4.0605D-003,
     .+1.9623D+000,+4.2887D-001,+2.1437D-001,-1.0061D-002,-1.1368D-003,
     .-6.9235D-002,+5.6758D-001,+1.1917D-001,-7.0765D-003,+3.0017D-004,
     .+3.0601D-004,+1.6559D+000,+2.0722D-001,+6.0013D-002,+1.7023D-004,
     .-9.2424D-004,+1.1269D-005,-6.9911D-006,-2.0886D+000,-6.7879D-002,
     .-8.5922D-004,-1.6087D-003,-4.5549D-005,+3.3178D-005,-6.1715D-006,
     .-1.4446D-006,-3.7210D-001,+1.5775D-001,-1.7827D-003,-4.4396D-004,
     .+2.2844D-004,-1.1215D-005,-2.1120D-006,-9.6421D-007,-1.4170D-008,
     .+7.8720D-001,-4.4238D-002,-1.5120D-003,-9.4119D-004,+4.0645D-006,
     .-4.9253D-006,-1.8656D-006,-4.0736D-007,-4.9594D-008,+1.6134D-009/

      DATA (BT_AMP(I),I=1,55)/
     .+0.0000D+000,+0.0000D+000,-8.9895D-001,+0.0000D+000,-1.0790D+000,
     .-1.2699D-001,+0.0000D+000,-5.9033D-001,+3.4865D-002,-3.2614D-002,
     .+0.0000D+000,-2.4310D-002,+1.5607D-002,-2.9833D-002,-5.9048D-003,
     .+0.0000D+000,+2.8383D-001,+4.0509D-002,-1.8834D-002,-1.2654D-003,
     .-1.3794D-004,+0.0000D+000,+1.3306D-001,+3.4960D-002,-3.6799D-003,
     .-3.5626D-004,+1.4814D-004,+3.7932D-006,+0.0000D+000,+2.0801D-001,
     .+6.5640D-003,-3.4893D-003,-2.7395D-004,+7.4296D-005,-7.9927D-006,
     .-1.0277D-006,+0.0000D+000,+3.6515D-002,-7.4319D-003,-6.2873D-004,
     .-8.2461D-005,+3.1095D-005,-5.3860D-007,-1.2055D-007,-1.1517D-007,
     .+0.0000D+000,+3.1404D-002,+1.5580D-002,-1.1428D-003,+3.3529D-005,
     .+1.0387D-005,-1.9378D-006,-2.7327D-007,+7.5833D-009,-9.2323D-009/

*     Reference day is 28 January 1980
*     This is taken from Niell (1996) to be consistent (See References)
*     For constant values use: doy = 91.3125
      DOY = DMJD  - 44239D0 + 1 - 28

*     Define degree n and order m EGM
      NMAX = 9
      MMAX = 9

*     Define unit vector
      X = DCOS(DLAT)*DCOS(DLON)
      Y = DCOS(DLAT)*DSIN(DLON)
      Z = DSIN(DLAT)

*     Legendre polynomials
      V(1,1) = 1.0D0
      W(1,1) = 0.0D0
      V(2,1) = Z * V(1,1)
      W(2,1) = 0.0

      DO N=2,NMAX
        V(N+1,1) = ((2*N-1) * Z * V(N,1) - (N-1) * V(N-1,1)) / N
        W(N+1,1) = 0.0D0
      ENDDO

      DO M=1,NMAX
        V(M+1,M+1) = (2*M-1) * (X*V(M,M) - Y*W(M,M))
        W(M+1,M+1) = (2*M-1) * (X*W(M,M) + Y*V(M,M))
        IF (M < NMAX) THEN
          V(M+2,M+1) = (2*M+1) * Z * V(M+1,M+1)
          W(M+2,M+1) = (2*M+1) * Z * W(M+1,M+1)
        ENDIF
        DO N=M+2,NMAX
          V(N+1,M+1) = ((2*N-1)*Z*V(N,M+1) - (N+M-1)*V(N-1,M+1)) / (N-M)
          W(N+1,M+1) = ((2*N-1)*Z*W(N,M+1) - (N+M-1)*W(N-1,M+1)) / (N-M)
        ENDDO
      ENDDO

*     Geoidal height
      UNDU = 0.D0
      I = 0
      DO N=0,NMAX
        DO M=0,N
          I = I+1
          UNDU = UNDU + (A_GEOID(I)*V(N+1,M+1) + B_GEOID(I)*W(N+1,M+1))
        ENDDO
      ENDDO

*     orthometric height
      HORT = DHGT - UNDU

*     Surface pressure on the geoid
      APM = 0.D0
      APA = 0.D0
      I = 0
      DO N=0,NMAX
        DO M=0,N
          I = I+1
          APM = APM + (AP_MEAN(I)*V(N+1,M+1) + BP_MEAN(I)*W(N+1,M+1))
          APA = APA + (AP_AMP(I) *V(N+1,M+1) + BP_AMP(I) *W(N+1,M+1))
        ENDDO
      ENDDO
      PRES0  = APM + APA*DCOS(DOY/365.25D0*TWOPI)

*     height correction for pressure
      PRES = PRES0*(1D0-0.0000226D0*HORT)**5.225D0

*     Surface temperature on the geoid
      ATM = 0D0
      ATA = 0D0
      I = 0
      DO N=0,NMAX
        DO M=0,N
          I = I+1
          ATM = ATM + (AT_MEAN(I)*V(N+1,M+1) + BT_MEAN(I)*W(N+1,M+1))
          ATA = ATA + (AT_AMP(I) *V(N+1,M+1) + BT_AMP(I) *W(N+1,M+1))
        ENDDO
      ENDDO
      TEMP0 =  ATM + ATA*DCOS(DOY/365.25D0*TWOPI)

*     height correction for temperature
      TEMP = TEMP0 - 0.0065D0*HORT

* Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2008
*  IERS Conventions Center
*
*  ==================================
*  IERS Conventions Software License
*  ==================================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING TERMS AND CONDITIONS
*  WHICH APPLY TO ITS USE.
*
*  1. The Software is provided by the IERS Conventions Center ("the
*     Center").
*
*  2. Permission is granted to anyone to use the Software for any
*     purpose, including commercial applications, free of charge,
*     subject to the conditions and restrictions listed below.
*
*  3. You (the user) may adapt the Software and its algorithms for your
*     own purposes and you may distribute the resulting "derived work"
*     to others, provided that the derived work complies with the
*     following requirements:
*
*     a) Your work shall be clearly identified so that it cannot be
*        mistaken for IERS Conventions software and that it has been
*        neither distributed by nor endorsed by the Center.
*
*     b) Your work (including source code) must contain descriptions of
*        how the derived work is based upon and/or differs from the
*        original Software.
*
*     c) The name(s) of all modified routine(s) that you distribute
*        shall be changed.
*
*     d) The origin of the IERS Conventions components of your derived
*        work must not be misrepresented; you must not claim that you
*        wrote the original Software.
*
*     e) The source code must be included for all routine(s) that you
*        distribute.  This notice must be reproduced intact in any
*        source distribution.
*
*  4. In any published work produced by the user and which includes
*     results achieved by using the Software, you shall acknowledge
*     that the Software was used in obtaining those results.
*
*  5. The Software is provided to the user "as is" and the Center makes
*     no warranty as to its use or performance.   The Center does not
*     and cannot warrant the performance or results which the user may
*     obtain by using the Software.  The Center makes no warranties,
*     express or implied, as to non-infringement of third party rights,
*     merchantability, or fitness for any particular purpose.  In no
*     event will the Center be liable to the user for any consequential,
*     incidental, or special damages, including any lost profits or lost
*     savings, even if a Center representative has been advised of such
*     damages, or for any claim by any third party.
*
*  Correspondence concerning IERS Conventions software should be
*  addressed as follows:
*
*                     Gerard Petit
*     Internet email: gpetit[at]bipm.org
*     Postal address: IERS Conventions Center
*                     Time, frequency and gravimetry section, BIPM
*                     Pavillon de Breteuil
*                     92312 Sevres  FRANCE
*
*     or
*
*                     Brian Luzum
*     Internet email: brian.luzum[at]usno.navy.mil
*     Postal address: IERS Conventions Center
*                     Earth Orientation Department
*                     3450 Massachusetts Ave, NW
*                     Washington, DC 20392
*
*
*-----------------------------------------------------------------------
      END


!/ ------------------------------------------------------------------- /
      MODULE W3SBT1MD
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    For updates see W3SBT1 documentation.
!/
!  1. Purpose :
!
!     JONSWAP bottom friction routine.
!
!  2. Variables and types :
!
!  3. Subroutines and functions :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      W3SBT1    Subr. Public   JONSWAP source term.
!     ----------------------------------------------------------------
!
!  4. Subroutines and functions used :
!
!     See subroutine documentation.
!
!  5. Remarks :
!
!  6. Switches :
!
!     See subroutine documentaiton.
!
!  7. Source code :
!/
!/ ------------------------------------------------------------------- /
!/
      PUBLIC
!/
      CONTAINS
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3SBT1 (A, CG, WN, DEPTH, S, D)
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    05-Dec-1996 : Final FORTRAN 77.                   ( version 1.18 )
!/    08-Dec-1999 : Upgrade to FORTRAN 90.              ( version 2.00 )
!/    20-Dec-2004 : Multiple model version.             ( version 3.06 )
!/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
!/
!/    Copyright 2009 National Weather Service (NWS),
!/       National Oceanic and Atmospheric Administration.  All rights
!/       reserved.  WAVEWATCH III is a trademark of the NWS.
!/       No unauthorized use without permission.
!/
!  1. Purpose :
!
!     Bottom friction source term according to the empirical JONSWAP
!     formulation.
!
!  2. Method :
!
!              2 GAMMA   /    CG         \      SBTC1 /     \       .
!       Sbt = ---------- | ------- - 0.5 | E  = ----- | ... | E    (1)
!             GRAV DEPTH \  SI/WN        /      DEPTH \     /
!
!     Where GAMMA = -0.038 m2/s3 (JONSWAP)
!                 = -0.067 m2/s3 (Bouws and Komen 1983)
!
!     In the routine, the constant 2 GAMMA / GRAV = SBTC1.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       A       R.A.  I   Action density spectrum (1-D)
!       CG      R.A.  I   Group velocities.
!       WN      R.A.  I   Wavenumbers.
!       DEPTH   Real  I   Mean water depth.
!       S       R.A.  O   Source term (1-D version).
!       D       R.A.  O   Diagonal term of derivative (1-D version).
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      STRACE    Subr. W3SERVMD Subroutine tracing (!/S switch).
!      PRT2DS    Subr. W3ARRYMD Print plot output (!/T1 switch).
!      OUTMAT    Subr. W3ARRYMD Matrix output (!/T2 switch).
!     ----------------------------------------------------------------
!
!  5. Called by :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3SRCE    Subr. W3SRCEMD Source term integration.
!      W3EXPO    Subr.   N/A    Point output post-processor.
!      GXEXPO    Subr.   N/A    GrADS point output post-processor.
!     ----------------------------------------------------------------
!
!  6. Error messages :
!
!     None.
!
!  7. Remarks :
!
!  8. Structure :
!
!     See source code.
!
!  9. Switches :
!
!     !/S  Enable subroutine tracing.
!     !/T   Enable general test output.
!     !/T0  2-D print plot of source term.
!     !/T1  Print arrays.
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: NK, NTH, NSPEC, SIG, MAPWN, SBTC1
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      REAL, INTENT(IN)        :: CG(NK), WN(NK), DEPTH, A(NSPEC)
      REAL, INTENT(OUT)       :: S(NSPEC), D(NSPEC)
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER                 :: IS, IK, NSCUT
      REAL                    :: FACTOR, CBETA(NK)
!/
!/ ------------------------------------------------------------------- /
!/
!
! 1.  Deep water ===================================================== *
!
      IF ( DEPTH*WN(1) .GT. 6 ) THEN
!
          D = 0.
          S = 0.
!
! 2.  Shallow water ================================================== *
!
        ELSE
!
! 2.a Set constant
!
          FACTOR = SBTC1 / DEPTH
!
! 2.b Wavenumber dependent part.
!
          DO IK=1, NK
            IF ( WN(IK)*DEPTH .GT. 6. ) EXIT
            CBETA(IK) = FACTOR *                                      &
               MAX(0., (CG(IK)*WN(IK)/SIG(IK)-0.5) )
            END DO
!
! 2.c Fill diagional matrix
!
          NSCUT  = (IK-1)*NTH
!
          DO IS=1, NSCUT
            D(IS) = CBETA(MAPWN(IS))
            END DO
!
          DO IS=NSCUT+1, NSPEC
            D(IS) = 0.
            END DO
!
          S = D * A
!
        END IF
!
! ... Test output of arrays
!
      RETURN
!
! Formats
!
!/
!/ End of W3SBT1 ----------------------------------------------------- /
!/
      END SUBROUTINE W3SBT1
!/
!/ End of module W3SBT1MD -------------------------------------------- /
!/
      END MODULE W3SBT1MD


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    use toolbox

    implicit none

    ! number of transition periods
    integer, parameter :: TT = 40

    ! number of years the household lives
    integer, parameter :: JJ = 12

    ! number of years the household retires
    integer, parameter :: JR = 10

    ! number of persistent shock process values
    integer, parameter :: NP = 2

    ! number of transitory shock process values
    integer, parameter :: NS = 5

    ! number of points on the asset grid
    integer, parameter :: NA = 100

    ! household preference parameters
    real*8, parameter :: gamma = 0.50d0
    real*8, parameter :: egam = 1d0 - 1d0/gamma
    real*8, parameter :: nu    = 0.335d0
    real*8, parameter :: beta  = 0.998**5

    ! household risk process
    real*8, parameter :: sigma_theta = 0.23d0
    real*8, parameter :: sigma_eps   = 0.05d0
    real*8, parameter :: rho         = 0.98d0

    ! production parameters
    real*8, parameter :: alpha = 0.36d0
    real*8, parameter :: delta = 1d0-(1d0-0.0823d0)**5
    real*8, parameter :: Omega = 1.60d0

    ! size of the asset grid
    real*8, parameter :: a_l    = 0.0d0
    real*8, parameter :: a_u    = 35d0
    real*8, parameter :: a_grow = 0.05d0

    ! demographic parameters
    real*8, parameter :: n_p   = (1d0+0.01d0)**5-1d0

    ! simulation parameters
    real*8, parameter :: damp    = 0.30d0
    real*8, parameter :: sig     = 1d-4
    integer, parameter :: itermax = 50

    ! counter variables
    integer :: iter

    ! macroeconomic variables
    real*8 :: r(0:TT), rn(0:TT), w(0:TT), wn(0:TT), p(0:TT)
    real*8 :: KK(0:TT), AA(0:TT), BB(0:TT), LL(0:TT), HH(0:TT)
    real*8 :: YY(0:TT), CC(0:TT), II(0:TT), GG(0:TT), INC(0:TT)

    ! government variables
    real*8 :: tauc(0:TT), tauw(0:TT), taur(0:TT), taup(0:TT), kappa(0:TT)
    real*8 :: gy, by, pen(JJ,0:TT), PP(0:TT), taxrev(4,0:TT)
    integer :: tax(0:TT)

    ! LSRA variables
    real*8 :: BA(0:TT) = 0d0, SV(0:TT) = 0d0, lsra_comp, lsra_all, Lstar
    logical :: lsra_on

    ! cohort aggregate variables
    real*8 :: c_coh(JJ, 0:TT), l_coh(JJ, 0:TT), y_coh(JJ, 0:TT), a_coh(JJ, 0:TT)
    real*8 :: v_coh(JJ, 0:TT) = 0d0, VV_coh(JJ, 0:TT) = 0d0

    ! the shock process
    real*8 :: dist_theta(NP), theta(NP)
    real*8 :: pi(NS, NS), eta(NS)
    integer :: is_initial = 3

    ! demographic and other model parameters
    real*8 :: m(JJ, 0:TT), pop(JJ, 0:TT), eff(JJ)

    ! individual variables
    real*8 :: a(0:NA), aplus(JJ, 0:NA, NP, NS, 0:TT)
    real*8 :: c(JJ, 0:NA, NP, NS, 0:TT), l(JJ, 0:NA, NP, NS, 0:TT)
    real*8 :: phi(JJ, 0:NA, NP, NS, 0:TT), VV(JJ, 0:NA, NP, NS, 0:TT) = 0d0
    real*8 :: v(JJ, 0:NA, NP, NS, 0:TT) = 0d0, FLC(JJ,0:TT)

    ! numerical variables
    real*8 :: RHS(JJ, 0:NA, NP, NS, 0:TT), EV(JJ, 0:NA, NP, NS, 0:TT)
    integer :: ij_com, ia_com, ip_com, is_com, it_com
    real*8 :: cons_com, lab_com, DIFF(0:TT)

contains

    ! the first order condition
    function foc(x_in)

        implicit none
        real*8, intent(in) :: x_in
        real*8 :: foc, a_plus, varphi, tomorrow, wage, v_ind, available
        integer :: ial, iar, itp

        ! calculate tomorrows assets
        a_plus  = x_in

        ! get tomorrows year
        itp = year(it_com, ij_com, ij_com+1)

        ! get lsra transfer payment
        v_ind = v(ij_com, ia_com, ip_com, is_com, it_com)

        ! calculate the wage rate
        wage = wn(it_com)*eff(ij_com)*theta(ip_com)*eta(is_com)

        ! calculate available resources
        available = (1d0+rn(it_com))*a(ia_com) + pen(ij_com, it_com) + v_ind

        ! determine labor
        if(ij_com < JR)then
            lab_com = min( max( nu + (1d0-nu)*(a_plus-available)/wage, 0d0) , 1d0-1d-10)
        else
            lab_com = 0d0
        endif

        ! calculate consumption
        cons_com = max( (available + wage*lab_com - a_plus)/p(it_com) , 1d-10)

        ! calculate linear interpolation for future part of first order condition
        call linint_Grow(a_plus, a_l, a_u, a_grow, NA, ial, iar, varphi)

        tomorrow = max(varphi*RHS(ij_com+1, ial, ip_com, is_com, itp) + &
                            (1d0-varphi)*RHS(ij_com+1, iar, ip_com, is_com, itp), 0d0)

        ! calculate first order condition for consumption
        foc = margu(cons_com, lab_com, it_com)**(-gamma) - tomorrow

    end function

    ! calculates marginal utility of consumption
    function margu(cons, lab, it)

        implicit none
        real*8, intent(in) :: cons, lab
        integer, intent(in) :: it
        real*8 :: margu

        margu = nu*(cons**nu*(1d0-lab)**(1d0-nu))**(1d0-1d0/gamma)/(p(it)*cons)

    end function

    ! calculates the value function
    function valuefunc(a_plus, cons, lab, ij, ip, is, it)

        implicit none
        integer, intent(in) :: ij, ip, is, it
        real*8, intent(in) :: a_plus, cons, lab
        real*8 :: valuefunc, varphi, c_help, l_help
        integer :: ial, iar, itp

        ! check whether consumption or leisure are too small
        c_help = max(cons, 1d-10)
        l_help = min(max(lab, 0d0),1d0-1d-10)

        ! get tomorrows year
        itp = year(it, ij, ij+1)

        ! get tomorrows utility
        call linint_Grow(a_plus, a_l, a_u, a_grow, NA, ial, iar, varphi)

        ! calculate tomorrow's part of the value function
        valuefunc = 0d0
        if(ij < JJ)then
            valuefunc = max(varphi*EV(ij+1, ial, ip, is, itp) + &
                (1d0-varphi)*EV(ij+1, iar, ip, is, itp), 1d-10)**(1d0-1d0/gamma)/(1d0-1d0/gamma)
        endif

        ! add todays part and discount
        valuefunc = (c_help**nu*(1d0-l_help)**(1d0-nu))**(1d0-1d0/gamma)/(1d0-1d0/gamma) + beta*valuefunc

    end function

    ! calculates year at which age ij agent is ijp
    function year(it, ij, ijp)

        implicit none
        integer, intent(in) :: it, ij, ijp
        integer :: year

        year = it + ijp - ij

        if(it == 0 .or. year <= 0)year = 0
        if(it == TT .or. year >= TT)year = TT

    end function

end module


      SUBROUTINE RWQSTL(IWQTSTL)
C
C CHANGE RECORD
C READ IN SPATIALLY AND/OR TEMPORALLY VARYING PARAMETERS FOR SETTLING
C VELOCITIES OF ALGAE, RPOM, LPOM & PARTICULATE METAL (UNIT INWQSTL).
C ALSO SPATIALLY/TEMPORALLY VARYING REAERATION ADJUSTMENT FACTOR.
C
C
C ***    WQWSC = Settling velocity for cyanobacteria (m/day)
C ***    WQWSD = Settling velocity for algae diatoms (m/day)
C ***    WQWSG = Settling velocity for algae greens  (m/day)
C ***   WQWSRP = Settling velocity for refractory POM (m/day)
C ***   WQWSLP = Settling velocity for labile POM (m/day)
C ***    WQWSS = Settling velocity for particles sorbed to TAM (m/day)
C ***    WQWSM = Settling velocity for macroalgae (m/day = 0.0)
C ***    WQWSM = Reaeration adjustment factor (NOT SAVED)
C
      USE GLOBAL
C
      CHARACTER TITLE(3)*79, STLCONT*3
C
      OPEN(1,FILE=STLFN,STATUS='UNKNOWN')
      OPEN(2,FILE='WQ3D'//ans(partid2)//'.OUT',STATUS='UNKNOWN',POSITION='APPEND')
      IF(IWQTSTL.EQ.0)THEN
        READ(1,50) (TITLE(M),M=1,3)
        WRITE(2,999)
        WRITE(2,50) (TITLE(M),M=1,3)
      ENDIF
      WRITE(2,60)'* SETTLING VELOCITY AT  ', IWQTSTL,
     &    ' TH DAY FROM MODEL START'
      READ(1,999)
      READ(1,50) TITLE(1)
      WRITE(2,50) TITLE(1)
      DO I=1,IWQZ
        READ(1,*) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I),
     &      WQWSLP(I),WQWSS(I), WQWSM
        WRITE(2,51) MM,WQWSC(I),WQWSD(I),WQWSG(I),WQWSRP(I),WQWSLP(I),
     &      WQWSS(I), WQWSM
      ENDDO
      READ(1,52) IWQTSTL, STLCONT
      WRITE(2,52) IWQTSTL, STLCONT
      IF(STLCONT.EQ.'END')THEN
        CLOSE(1)
        IWQSTL = 0
      ENDIF
      CLOSE(2)
  999 FORMAT(1X)
   50 FORMAT(A79)
   51 FORMAT(I3, 10F8.3)
   52 FORMAT(I7, 1X, A3)
   60 FORMAT(/, A24, I5, A24)
      RETURN
      END


*     AB05MD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          N1MAX, N2MAX, NMAX, M1MAX, P1MAX, P2MAX
      PARAMETER        ( N1MAX = 20, N2MAX = 20, NMAX = N1MAX+N2MAX,
     $                   M1MAX = 20, P1MAX = 20, P2MAX = 20 )
      INTEGER          LDA, LDA1, LDA2, LDB, LDB1, LDB2, LDC, LDC1,
     $                 LDC2, LDD, LDD1, LDD2, LDWORK
      PARAMETER        ( LDA = NMAX, LDA1 = N1MAX, LDA2 = N2MAX,
     $                   LDB = NMAX,LDB1 = N1MAX, LDB2 = N2MAX,
     $                   LDC = P2MAX, LDC1 = P1MAX, LDC2 = P2MAX,
     $                   LDD = P2MAX, LDD1 = P1MAX, LDD2 = P2MAX,
     $                   LDWORK = P1MAX*N1MAX )
*     .. Local Scalars ..
      CHARACTER*1      OVER, UPLO
      INTEGER          I, INFO, J, M1, N, N1, N2, P1, P2
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), A1(LDA1,N1MAX), A2(LDA2,N2MAX),
     $                 B(LDB,M1MAX), B1(LDB1,M1MAX), B2(LDB2,P1MAX),
     $                 C(LDC,NMAX), C1(LDC1,N1MAX), C2(LDC2,N2MAX),
     $                 D(LDD,M1MAX), D1(LDD1,M1MAX), D2(LDD2,P1MAX),
     $                 DWORK(LDWORK)
*     .. External Subroutines ..
      EXTERNAL         AB05MD
*     .. Executable Statements ..
*
      UPLO = 'Lower'
      OVER = 'N'
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N1, M1, P1, N2, P2
      IF ( N1.LE.0 .OR. N1.GT.N1MAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) N1
      ELSE
         READ ( NIN, FMT = * ) ( ( A1(I,J), J = 1,N1 ), I = 1,N1 )
         IF ( M1.LE.0 .OR. M1.GT.M1MAX ) THEN
            WRITE ( NOUT, FMT = 99991 ) M1
         ELSE
            READ ( NIN, FMT = * ) ( ( B1(I,J), I = 1,N1 ), J = 1,M1 )
            IF ( P1.LE.0 .OR. P1.GT.P1MAX ) THEN
               WRITE ( NOUT, FMT = 99990 ) P1
            ELSE
               READ ( NIN, FMT = * ) ( ( C1(I,J), J = 1,N1 ), I = 1,P1 )
               READ ( NIN, FMT = * ) ( ( D1(I,J), J = 1,M1 ), I = 1,P1 )
               IF ( N2.LE.0 .OR. N2.GT.N2MAX ) THEN
                  WRITE ( NOUT, FMT = 99989 ) N2
               ELSE
                  READ ( NIN, FMT = * )
     $                 ( ( A2(I,J), J = 1,N2 ), I = 1,N2 )
                  READ ( NIN, FMT = * )
     $                 ( ( B2(I,J), I = 1,N2 ), J = 1,P1 )
                  IF ( P2.LE.0 .OR. P2.GT.P2MAX ) THEN
                     WRITE ( NOUT, FMT = 99988 ) P2
                  ELSE
                     READ ( NIN, FMT = * )
     $                    ( ( C2(I,J), J = 1,N2 ), I = 1,P2 )
                     READ ( NIN, FMT = * )
     $                    ( ( D2(I,J), J = 1,P1 ), I = 1,P2 )
*                    Find the state-space model (A,B,C,D).
                     CALL AB05MD( UPLO, OVER, N1, M1, P1, N2, P2, A1,
     $                            LDA1, B1, LDB1, C1, LDC1, D1, LDD1,
     $                            A2, LDA2, B2, LDB2, C2, LDC2, D2,
     $                            LDD2, N, A, LDA, B, LDB, C, LDC, D,
     $                            LDD, DWORK, LDWORK, INFO )
*
                     IF ( INFO.NE.0 ) THEN
                        WRITE ( NOUT, FMT = 99998 ) INFO
                     ELSE
                        WRITE ( NOUT, FMT = 99997 )
                        DO 20 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( A(I,J), J = 1,N )
   20                   CONTINUE
                        WRITE ( NOUT, FMT = 99995 )
                        DO 40 I = 1, N
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( B(I,J), J = 1,M1 )
   40                   CONTINUE
                        WRITE ( NOUT, FMT = 99994 )
                        DO 60 I = 1, P2
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( C(I,J), J = 1,N )
   60                   CONTINUE
                        WRITE ( NOUT, FMT = 99993 )
                        DO 80 I = 1, P2
                           WRITE ( NOUT, FMT = 99996 )
     $                           ( D(I,J), J = 1,M1 )
   80                   CONTINUE
                     END IF
                  END IF
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' AB05MD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from AB05MD = ',I2)
99997 FORMAT (' The state transition matrix of the cascaded system is ')
99996 FORMAT (20(1X,F8.4))
99995 FORMAT (/' The input/state matrix of the cascaded system is ')
99994 FORMAT (/' The state/output matrix of the cascaded system is ')
99993 FORMAT (/' The input/output matrix of the cascaded system is ')
99992 FORMAT (/' N1 is out of range.',/' N1 = ',I5)
99991 FORMAT (/' M1 is out of range.',/' M1 = ',I5)
99990 FORMAT (/' P1 is out of range.',/' P1 = ',I5)
99989 FORMAT (/' N2 is out of range.',/' N2 = ',I5)
99988 FORMAT (/' P2 is out of range.',/' P2 = ',I5)
      END


C***********************************************************************
C
C
                        SUBROUTINE ellan
C
C
C***********************************************************************
C
C
C     Subroutine to analyze the ellipticity of the system
C
C
C=======================================================================

        INCLUDE 'common6.h'
C   Declaration of local variables.
C   -------------------------------
        DOUBLE PRECISION etoti(1:nmax),mtot,poscm(3),
     &     ti(3,3),tiwork(3,3),dwork(3),ework(3),lam(3)
        INTEGER i,j,k,ief,nbound,nstart,nnext,np,indexev(3)
        INTEGER index(1:nmax)

        INTEGER nef,nef1
        PARAMETER(nef=9,nef1=nef+1)
        DOUBLE PRECISION xf(nef1),ba(nef1),ca(nef1),taue(nef1),
     &            evec(3,3,nef1)

        PARAMETER (tiny2=1.D-30)
        DATA (xf(i),i=1,nef1) /0.01D0,0.05D0,0.1D0,0.2D0,0.5D0,
     &                        0.8D0,0.9D0,0.95D0,1.0D0,99.D0/

C=======================================================================

C       calculate specific energy of particles
C       --------------------------------------

        DO 100 i=ifirst,ntot
        etoti(i-ifirst+1) = 0.5D0 * (xdot(1,i)**2 + xdot(2,i)**2 +
     &                         xdot(3,i)**2) + phidbl(i)
100     CONTINUE

C      calculate number of bound particles
C      -----------------------------------

        nbound = 0
        DO 150 i=1,ntot-ifirst+1
           IF(etoti(i).LT.0.D0) nbound = nbound + 1
150     CONTINUE

C       sort for particle energy
C       ------------------------

        CALL indexx(ntot-ifirst+1,etoti,index)

C       initialize tensor of inertia
C       ----------------------------

        DO 210 i=1,3
           DO 200 k=1,3
              ti(i,k) = 0.D0
200        CONTINUE
210     CONTINUE

C       LOOP over fraction of most bound particles and all particles
C       ------------------------------------------------------------

        nstart   = 1
        mtot     = 0.D0
        poscm(1) = 0.D0
        poscm(2) = 0.D0
        poscm(3) = 0.D0
        DO 500 ief=1,nef1

           IF(ief.LE.nef) THEN
C                                  only fraction of bound particles
C                                  --------------------------------
              nnext = NINT(xf(ief) * nbound)
           ELSE
C                                   all particles
C                                   -------------
              nnext = ntot
           ENDIF

C-----------------------------------------------------------------
C--      at least two particles are required for ellipticity...
C-----------------------------------------------------------------
           IF(nnext.LT.2) THEN
              ba(ief)  = 999.
              ca(ief)  = 999.
              taue(ief) = 999.
              DO 320 k=1,3
                 DO 310 j=1,3
                    evec(k,j,ief) = 0.
310              CONTINUE
320           CONTINUE

           ELSE

C       calculate tensor of inertia
C       ---------------------------
*             print*,' nstart,nnext=',nstart,nnext
              DO 400 i=nstart,nnext
                 ipo = index(i) + ifirst - 1
                 ti(1,1) = ti(1,1) + body(ipo) *
     &                  (x(2,ipo)*x(2,ipo) + x(3,ipo)*x(3,ipo))
                 ti(2,2) = ti(2,2) + body(ipo) *
     &                  (x(1,ipo)*x(1,ipo) + x(3,ipo)*x(3,ipo))
                 ti(3,3) = ti(3,3) + body(ipo) *
     &                  (x(1,ipo)*x(1,ipo) + x(2,ipo)*x(2,ipo))
                 ti(1,2) = ti(1,2) - body(ipo) * x(1,ipo)*x(2,ipo)
                 ti(1,3) = ti(1,3) - body(ipo) * x(1,ipo)*x(3,ipo)
                 ti(2,3) = ti(2,3) - body(ipo) * x(2,ipo)*x(3,ipo)
400           CONTINUE

C       correct for center of mass
C       --------------------------

C   A) calculate center of mass data
C   --------------------------------

C--       remove previous correction for center of mass
              ti(1,1) = ti(1,1) + mtot * (poscm(2)**2+poscm(3)**2)
              ti(2,2) = ti(2,2) + mtot * (poscm(1)**2+poscm(3)**2)
              ti(3,3) = ti(3,3) + mtot * (poscm(1)**2+poscm(2)**2)
              ti(1,2) = ti(1,2) - mtot * poscm(1) * poscm(2)
              ti(1,3) = ti(1,3) - mtot * poscm(1) * poscm(3)
              ti(2,3) = ti(2,3) - mtot * poscm(2) * poscm(3)
              poscm(1) = poscm(1) * mtot
              poscm(2) = poscm(2) * mtot
              poscm(3) = poscm(3) * mtot
*             xav = 0.d0
*             yav = 0.d0
*             zav = 0.d0

              DO 405 i=nstart,nnext
                 ipo = index(i) + ifirst - 1
                 poscm(1) = poscm(1) + body(ipo) * x(1,ipo)
                 poscm(2) = poscm(2) + body(ipo) * x(2,ipo)
                 poscm(3) = poscm(3) + body(ipo) * x(3,ipo)
                 mtot     = mtot + body(ipo)
*                xav = xav + abs(x(1,ipo))
*                yav = yav + abs(x(2,ipo))
*                zav = zav + abs(x(3,ipo))

 405           CONTINUE
              poscm(1) = poscm(1) / mtot
              poscm(2) = poscm(2) / mtot
              poscm(3) = poscm(3) / mtot
*             print*,' av=',xav,yav,zav

C   B) apply correction
C   -------------------
              ti(1,1) = ti(1,1) - mtot * (poscm(2)**2+poscm(3)**2)
              ti(2,2) = ti(2,2) - mtot * (poscm(1)**2+poscm(3)**2)
              ti(3,3) = ti(3,3) - mtot * (poscm(1)**2+poscm(2)**2)
              ti(1,2) = ti(1,2) + mtot * poscm(1) * poscm(2)
              ti(1,3) = ti(1,3) + mtot * poscm(1) * poscm(3)
              ti(2,3) = ti(2,3) + mtot * poscm(2) * poscm(3)

C       set off-axis values by symmetry
C       -------------------------------

              ti(2,1) = ti(1,2)
              ti(3,1) = ti(1,3)
              ti(3,2) = ti(2,3)
*
*             print*,' mtot,poscm=',mtot,(poscm(k),k=1,3)
C=======================================================
C       determine eigenvalues and axis of inertia
C=======================================================

C------------------------------------------------------
C--          copy tensor of inertia
C------------------------------------------------------
              DO 420 i=1,3
                 DO 410 k=1,3
                    tiwork(i,k) = ti(i,k)
410              CONTINUE
420           CONTINUE
              np = 3

C------------------------------------------------------
C--          calculate eigenvalues and eigenvectors
C------------------------------------------------------
              CALL tred2(tiwork,np,np,dwork,ework)
              CALL tqli(dwork,ework,np,np,tiwork)

C--               sort for increasing eigenvalues
              CALL indexx(np,dwork,indexev)
C--               find eigenvectors
              DO 450 i=1,np
                 lam(i) = dwork(indexev(i))
                 DO 440 k=1,np
                    evec(k,i,ief) = tiwork(k,indexev(i))
440              CONTINUE
450           CONTINUE

              xhelp    = lam(3) + lam(2) - lam(1)
              xhelp1   = lam(2) - lam(3) + lam(1)
c              IF(xhelp1.LT.0.D0) THEN
c                 PRINT*,' ellan: xhelp1 < 0',xhelp1,tnow
c                 xhelp1 = 0.D0
c             ENDIF
              ba(ief)  = SQRT(MAX(tiny2,lam(3)-lam(2)+lam(1)) / xhelp)
              ca(ief)  = SQRT(MAX(tiny2,xhelp1) / xhelp)
              taue(ief) = (ba(ief)-ca(ief)) /MAX(tiny2,(1.D0 - ca(ief)))

              nstart = nnext + 1

           ENDIF

500     CONTINUE

C==================================================================
C==         OUTPUT of data
C===================================================================

      	DO 600 ief=1,nef1
          if(rank.eq.0)
     *     WRITE(60+ief,910) time,ba(ief),ca(ief),taue(ief),
     *     mtot,(poscm(k),k=1,3)
600     CONTINUE

*     900     FORMAT(1x,1p,e12.5,1x,0p,i9,1x,i9,1x,i2)
910     FORMAT(1x,13(f9.5,1x))

        R E T U R N
        END


module residuals
    ! contains functions for the computation of the residual vector
    ! which is needed for the newton iteration in the stress update algorithm
    ! (return mapping method) and additionally can be used for the numerical computation
    ! of the jacobian matrix needed in the newton iteration

    ! load additional modules
    use constants
	use material_info
	use aux_routines, only: unpack_x_vector
    use model_comp_act, only: Dg_actDsigma, &
    									hf_act, &
    									yf_act

    implicit none

contains

	function comp_R(x, sigma_trial, alpha_old, &
							C_el, &
							n_act_yf, yield_flags, act_yf_ind)
		! assembles the residual vector R
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(:), intent(in) :: 	x				! x vector, containing stress vector, alpha vector and active delta_lambda vector
		real(kind=dbl), dimension(:), intent(in) ::		sigma_trial		! trial stress vector
		real(kind=dbl), dimension(:), intent(in) ::		alpha_old		! internal variables vector at the end of the prior load increment
		real(kind=dbl), dimension(:,:), intent(in) ::	C_el			! elasticity matrix
		integer, intent(in) :: 							n_act_yf		! number of active yield functions
		logical, dimension(:), intent(in) :: 			yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(x)) ::			comp_R		! residual vector R

		! internal variables
		real(kind=dbl), dimension(6) :: 				sigma				! stress vector
		real(kind=dbl), dimension(n_int_vars) :: 		alpha				! internal variables vector
		real(kind=dbl), dimension(n_act_yf) :: 			delta_lambda_act	! active delta_lambdas vector
		integer :: i_start
		integer :: i_end
		! --------------------------------------------------------------------------

		! unpack x vector
		call unpack_x_vector(x, sigma, alpha, delta_lambda_act)

		! assemble residual vector
		i_start = 1
		i_end = 6
		comp_R(i_start:i_end) = R_sigma(sigma, alpha, delta_lambda_act, &
												sigma_trial, &
												C_el, &
												n_act_yf, yield_flags, act_yf_ind)

		i_start = i_end+1
		i_end = i_start+n_int_vars-1
		if (hardening_present) then
			comp_R(i_start:i_end) = R_alpha(sigma, alpha, delta_lambda_act, &
											alpha_old, &
											n_act_yf, yield_flags, act_yf_ind)
		end if

		i_start = i_end+1
		i_end = i_start+n_act_yf-1
		comp_R(i_start:i_end) = R_f(sigma, alpha, &
									n_act_yf, yield_flags, act_yf_ind)

	end function comp_R

	function R_sigma(sigma, alpha, delta_lambda_act, &
									sigma_trial, &
									C_el, &
									n_act_yf, yield_flags, act_yf_ind)
		! computes R_sigma part of the residual vector
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(:), intent(in) :: 	sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha			! internal variables vector
		real(kind=dbl), dimension(:), intent(in) ::		delta_lambda_act	! active delta lambda vector
		real(kind=dbl), dimension(:), intent(in) ::		sigma_trial		! trial stress vector
		real(kind=dbl), dimension(:,:), intent(in) :: 	C_el			! elasticity matrix
		integer, intent(in) :: 							n_act_yf		! number of active yield functions
		logical, dimension(:), intent(in) :: 			yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(6) :: 	R_sigma

		! internal variables
		real(kind=dbl), dimension(6,n_act_yf) :: dg_act		! matrix with dg_act/dsigma vectors
		real(kind=dbl), dimension(6) ::		A				! auxiliary variable (vector) for sum( delta_lambda_act*dg_act/dsigma)
		integer :: i													! index variable
		! --------------------------------------------------------------------------

		! compute dg_act/dsigma matrix
		dg_act = Dg_actDsigma(sigma, alpha, yield_flags, act_yf_ind)

		! initialize A vector with zeros
		A = 0._dbl

		! loop over all active delta lambdas
		do i=1,n_act_yf

			! compute sum( delta_lambda_act*dg_act/dsigma)
			A = A + delta_lambda_act(i) * dg_act(:,i)

		end do

		! compute R_sigma
		R_sigma = -1._dbl*sigma + sigma_trial - matmul(C_el,A)

	end function R_sigma

	function R_alpha(sigma, alpha, delta_lambda_act, &
									alpha_old, &
									n_act_yf, yield_flags, act_yf_ind)
		! compute R_alpha part of the residual vector
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(:), intent(in) :: 	sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha			! internal variables vector
		real(kind=dbl), dimension(:), intent(in) ::		delta_lambda_act	! active delta lambda vector
		real(kind=dbl), dimension(:), intent(in) ::		alpha_old		! internal variables vector at the end of the prior load increment
		integer, intent(in) :: 							n_act_yf		! number of active yield functions
		logical, dimension(:), intent(in) :: 			yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(size(alpha)) ::		R_alpha

		! internal variables
		real(kind=dbl), dimension(size(alpha),n_act_yf) :: h_act		! matrix with active hardening function vectors
		real(kind=dbl), dimension(size(alpha)) ::		A				! auxiliary variable (vector) for sum( delta_lambda_act*h_act)
		integer :: i													! index variable
		! --------------------------------------------------------------------------

		! compute active hardening functions matrix
		h_act = hf_act(sigma, alpha, yield_flags, act_yf_ind)

		! initialize A vector with zeros
		A = 0._dbl

		! loop over all active delta lambdas
		do i=1,n_act_yf

			! compute sum( delta_lambda_act*h_act)
			A = A + delta_lambda_act(i)*h_act(:,i)

		end do

		! compute R_alpha
		R_alpha = -1._dbl*alpha + alpha_old + A

	end function R_alpha

	function R_f(sigma, alpha, &
					n_act_yf, yield_flags, act_yf_ind)
		! computes R_f part of the residual vector
		implicit none

		! --------------------------------------------------------------------------
		! passed variables
		real(kind=dbl), dimension(:), intent(in) :: 	sigma			! stress vector
		real(kind=dbl), dimension(:), intent(in) :: 	alpha			! internal variables vector
		integer, intent(in) :: 							n_act_yf		! number of active yield functions
		logical, dimension(:), intent(in) :: 			yield_flags		! active yield functions vector
		integer, dimension(:), intent(in) ::			act_yf_ind		! vector with indices of active yield functions

		! return variable
		real(kind=dbl), dimension(n_act_yf) ::			R_f

		! internal variables
		! --------------------------------------------------------------------------

		! compute R_f
		R_f = yf_act(sigma, alpha, yield_flags, act_yf_ind)

	end function R_f

end module residuals


      function bt12_td_rv_for_pga_or_pgv_f(m, r, ynull,
     :  nm4bt12, nr4bt12,
     :  m4bt12, logr4bt12,
     :  bt12_td_rv )

! Find td/rv for specified M and R by interpolating td/rv evaluated for
! tabulated values of M and R surrounding the desired M and R

! The input arrays are read in subroutine get_params, contained in rv_td_subs, and
! are passed through common blocks in bt12osc.fi.

! Dates: 09/20/11 - Written by D. Boore, based on drms_dex_f.for
!        07/23/14 - Temp change for the new BT14 factors
!        07/28/14 - Set to ynull if bt12_td_rv = 0
!        11/17/14 - Changed above statement to "Set to ynull if m, r is out of range".

      real m, r, logr, ynull

      real y_interp, u, t, y1,y2,y3,y4

      integer, parameter :: nmparam=13, nrparam=15  ! Added 07/23/14
      integer nm4bt12, nr4bt12
      real m4bt12(nmparam), logr4bt12(nrparam)
      real bt12_td_rv(nmparam,nrparam)

! Find j:

      call locate(m4bt12,nm4bt12,m,j)

      if (j == 0 .or. j == nm4bt12) then ! out of range
        bt12_td_rv_for_pga_or_pgv_f = ynull
        return
      end if

! Find k:

      logr = alog10(r)

      call locate(logr4bt12,nr4bt12,logr,k)

      if (k == 0 .or. k == nr4bt12) then ! out of range
        bt12_td_rv_for_pga_or_pgv_f = ynull
        return
      end if

      if (bt12_td_rv(j,k) == 0.0) then
        bt12_td_rv_for_pga_or_pgv_f = ynull
!DEBUG
      print *,' For M, R, j, k, bt12_td_rv(j,k), '//
     :         'bt12_td_rv_for_pga_or_pgv_f = '
      print *,  M, R, j, k, bt12_td_rv(j,k),
     :         bt12_td_rv_for_pga_or_pgv_f
!DEBUG
        return
      end if

! Evaluate TD/RV at the four corners (I made plots of TD/RV and log TD/RV as a function
! of log R for the M's; I see no reason to interpolate log TD/RV rather than TD/RV):

      y1 = bt12_td_rv(j,k)

      y2 = bt12_td_rv(j+1,k)

      y3 = bt12_td_rv(j+1,k+1)

      y4 = bt12_td_rv(j,k+1)

      t = (m -m4bt12(j))/(m4bt12(j+1) - m4bt12(j))
      u = (logr -logr4bt12(k))/(logr4bt12(k+1) - logr4bt12(k))

      y_interp = (1.0-t)*(1.0-u)*y1 + t*(1.0-u)*y2 +
     :           t*u*y3 + (1.0-t)*u*y4

      bt12_td_rv_for_pga_or_pgv_f = y_interp

      return

      end


      SUBROUTINE CYLPATCH (rdata)
C
C* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C	VICAR SUBROUTINE                                          CYLPATCH
C       ----------------                                          --------
C	General routine for computing ZC, the line intersecting the
C       equator, CPSI, the longitude at sample 1, and CSAM00,
C       the sample at longitude zero.
C
C	Fortran format of call:
C
C	CALL CYLPATCH (RDATA)
C
C	"C" format of call:
C
C	cylpatch (rdata);
C
C	Parameters:-
C
C	RDATA   (input/output)  REAL Input Matrix.
C
C   REVISION HISTORY
C
C      20-05-94   CRI  MSTP S/W Conversion (VICAR Porting)
C      11-05-98   RRP  Updated tcylpatch to compile under
C                 vms system by merging the divided string
C                 parameter to xvmessage to max possible
C                 string.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

C     this code was lifted from MAP2 cylcen subroutine
      implicit none
      real*4 rdata(40),PIFAC
      real*4 cphi,cpsi,xc,zc,f,req,rpole,fl
      real*4 phi,sinphi,rfl,radius,CSAM00

      integer*4 l

      data PIFAC/.017453293/

      call  ifmessage ('CYLPATCH version 11-May-98')

      call mve(4,1,rdata(39),l,1,1)  ! Check Type of Data
      if(l.ne.9)return

      cphi=rdata(3)
      cpsi=rdata(6)
      xc=rdata(1)
      zc=rdata(2)
      f=rdata(7)
      req=rdata(26)
      rpole=rdata(25)
      fl=rpole

C     THIS ROUTINE COMPUTES ZC, THE LINE INTERCEPTING THE EQUATOR,
C     CPSI = THE LONGITUDE AT SAMPLE 1, AND CSAM00 = THE SAMPLE OF LONG ZERO.

      IF(xc.EQ.1..AND.cphi.EQ.0.)GO TO 50
C        GET W. LONG AT SAMPLE 1
2        cpsi=f*(xc-1.)/req/PIFAC+cpsi
         xc=1.
         cpsi=AMOD(720.+cpsi,360.)
C        FIND LINE OF EQUATOR
         phi=cphi*PIFAC
         sinphi=SIN(phi)
         rfl=(req/fl)**2                               !new
         radius=req/(f*sqrt(rfl+(1.-rfl)*cos(phi)**2)) !new
         zc=zc+sinphi*radius                           !new

C        ROUND
         zc=FLOAT(INT(zc+0.5))
         cphi=0.
         rdata(2)=zc
         rdata(3)=cphi

C        CALCULATE SAMP OF LONG ZERO AND ROUND
50    CSAM00=req*cpsi*PIFAC/f+1.
      CSAM00=FLOAT(INT(CSAM00+0.5))

C     ADJUST LONGITUDE OF SAMPLE 1.
      cpsi=f*(CSAM00-1.)/req/PIFAC
      rdata(1)=CSAM00
      rdata(6)=cpsi
      RETURN
      END


      subroutine cli_wndgen(iwgn)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine generates wind speed

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    idg(:)      |none          |array location of random number seed used
!!                               |for a given process
!!    j           |none          |HRU number
!!    rndseed(:,:)|none          |random number seeds
!!    wndav(:,:)  |m/s           |average wind speed for the month in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Log
!!    SWAT: Aunif
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use hydrograph_module
      use climate_module
      use time_module

      implicit none

      real :: v6                  !none          |random number between 0.0 and 1.0
      real :: v7                  !              |
      real :: rdir2               !              |
      real :: pi2                 !              |
      integer :: idir             !none          |counter
      integer :: idir1            !              |
      integer :: idir2            !              |
      integer :: mo               !              |
      integer :: iwgn             !              |
      integer :: iwndir           !              |
      real :: aunif               !              |
      real :: g                   !              |

      pi2 = 6.283185
      mo = time%mo

      !! Generate wind speed !!
      v6 = Aunif(rndseed(idg(5),iwgn))
      wst(iwst)%weat%windsp = wgn(iwgn)%windav(time%mo) * (-Log(v6)) ** 0.3

      !! Generate wind direction !!
      iwndir = wst(iwst)%wco%wndir
      if (iwndir > 0) then
      idir1 = 16
      idir2 = 15
      v7 = Aunif(rndseed(idg(5),iwgn))
      do idir = 1, 16
        if (wnd_dir(iwndir)%dir(mo,idir) > v7) then
          idir1 = idir
          idir2 = idir - 1
          exit
        end if
      end do
      if (idir1 == 1) then
        g = v7 / wnd_dir(iwndir)%dir(mo,idir1)
      else
        g = (v7 - wnd_dir(iwndir)%dir(mo,idir2)) /                        &
           (wnd_dir(iwndir)%dir(mo,idir1) - wnd_dir(iwndir)%dir(mo,idir2))
      end if

      rdir2 = float (idir2)
      wst(iwst)%weat%wndir = pi2 * (g + rdir2 - .5) / 16.
      wst(iwst)%weat%wndir = pi2 + wst(iwst)%weat%wndir
      end if

      return
      end subroutine cli_wndgen


#include "../defines.inc"
!-----------------------------------------------------------!
!
!     Calculate volume of each Bin within the confinement
!
!            Started by Quinn 3/17/15
!
!
!
! confineType  |  Discription
! _____________|_________________________________
!    0         |  No confinement
!    1         |  Betwene two plates in Z direction at 0 and LBox
!    2         |  Cube of size LBox**3,  range: 0-LBox
!    3         |  Circle of radius LBox/2 inside box of size LBox

subroutine mc_calc_volume(dbin, LBox, Vol, rand_stat)

!use mt19937, only : grnd, init_genrand, rnorm, mt, mti
   use mersenne_twister
   use params, only: dp
   implicit none

   real(dp) LBox ! Side length of box
   integer I      ! for loops
   integer ix, iy, iz      ! location of conder
   real(dp) x, y, z
   integer :: STATUS = 0
   real(dp) Rsqrd
   real(dp) Vol(WLC_P__NBIN_X*WLC_P__NBIN_Y*WLC_P__NBIN_Z)  ! output: volume of bins
   real(dp) V
   real(dp) corner(8, 3)
   integer nc
   integer, PARAMETER:: npts = 10000
   real(dp) dbin           ! side length of bins
   real(dp) rsq, minr
   type(random_stat) rand_stat !for random numer generator
   real(dp) urand(3)

   if (abs(dbin*WLC_P__NBIN_X - LBOX) .gt. 0.000001_dp) then
      print *, "dbin = ", dbin
      print *, "WLC_P__NBin_X = ", WLC_P__NBIN_X
      print *, "LBOX = ", LBOX
      print *, "Error in MC_calcvolume, make box integer lenth*dbin"
      STOP 1
   endif

   if (WLC_P__CONFINETYPE == 'none') then
      print *, "Don't call mc_calc_volume with this type of boundary"
      STATUS = 1
      STOP 1
   elseif (WLC_P__CONFINETYPE == 'platesInZperiodicXY') then
      print *, "Don't call mc_calc_volume with this type of boundary"
      STATUS = 1
      STOP 1
   elseif (WLC_P__CONFINETYPE == 'cube') then
      print *, "Don't call mc_calc_volume with this type of boundary"
      STATUS = 1
      STOP 1
   elseif (WLC_P__CONFINETYPE == 'sphere') then
      Rsqrd = (LBox/2.0_dp)**2
      Do ix = 1, WLC_P__NBIN_X
         Do iy = 1, WLC_P__NBIN_Y
            do iz = 1, WLC_P__NBIN_Z
               x = dbin*ix
               y = dbin*iy
               z = dbin*iz
               corner(1, 1) = x; corner(1, 2) = y; corner(1, 3) = z
               corner(2, 1) = x; corner(3, 2) = y - dbin; corner(3, 3) = z - dbin
               corner(3, 1) = x; corner(2, 2) = y; corner(2, 3) = z - dbin
               corner(4, 1) = x - dbin; corner(4, 2) = y - dbin; corner(4, 3) = z - dbin
               corner(5, 1) = x - dbin; corner(5, 2) = y; corner(5, 3) = z - dbin
               corner(6, 1) = x; corner(6, 2) = y - dbin; corner(6, 3) = z
               corner(7, 1) = x - dbin; corner(7, 2) = y; corner(7, 3) = z
               corner(8, 1) = x - dbin; corner(8, 2) = y - dbin; corner(8, 3) = z

               nc = 0
               minr = Rsqrd + 2*dbin ! just big
               do I = 1, 8
                  rsq = ((corner(I, 1) - LBox/2.0_dp)**2 + &
                         (corner(I, 2) - LBox/2.0_dp)**2 + &
                         (corner(I, 3) - LBox/2.0_dp)**2)
                  minr = min(minr, rsq)
                  if (rsq .gt. Rsqrd) then
                     nc = nc + 1
                  endif
               enddo
               if (nc .eq. 0) then
                  ! inside
                  V = dbin**3
               elseif ((nc .eq. 8) .and. (minr .gt. Rsqrd + dbin*0.5_dp)) then
                  V = 0.0_dp
               else
                  V = 0.0_dp
                  do I = 1, npts
                     call random_number(urand, rand_stat)
                     rsq = ((corner(1, 1) - urand(1)*dbin - LBox/2.0_dp)**2 + &
                            (corner(1, 2) - urand(2)*dbin - LBox/2.0_dp)**2 + &
                            (corner(1, 3) - urand(3)*dbin - LBox/2.0_dp)**2)
                     if (rsq .lt. Rsqrd) then
                        V = V + 1.0_dp
                     endif
                  enddo
                  V = (dbin**3)*V/dble(npts)
               endif
               Vol(ix + (iy - 1)*WLC_P__NBIN_X + (iz - 1)*WLC_P__NBIN_X*WLC_P__NBIN_Y) = V
            enddo
         enddo
      enddo
   else
      print *, "Undefined confine Type"
      stop 1
   endif

END


      function diskdenspsi(r,z,psi)

      include 'commonblocks'

      real psi

c the truncation factor is derived assuming that the azimuthal velocity dist
c is gaussian with dispersion sigma_R * 2 omega/kappa, as per epicycle theory.
      if( abs(z/zdisk) .gt. 10.) goto 99
      erfarg=(r-outdisk)/1.4142136/drtrunc
      if (erfarg.gt.4.) goto 99
      if (erfarg.lt.-4) then
         trunfac=1
      else
         trunfac=0.5*erfc(erfarg)
      endif
      if (z.eq.0.) then
         con=1
      else
        psizh= pot(r,zdisk)
        psi00 = pot(r,0.)
        con = 0.419974**((psi-psi00)/(psizh-psi00))
      endif
      diskdenspsi = diskconst*exp(-r/rdisk)*con*trunfac
      return
 99   diskdenspsi = 0.0
      return
      end


c
c	This program exercises this subroutine in 2D

c
	real*4 outn(4),den(201,201),pp_profile
	real*4 r,al,alatr,amlt,akp,ne_inner_ps
	integer*4 itime(2)

      itime(1)=2002185
      ihr=12
      imin=0
      isec=0
      itime(2)=(ihr*3600 + imin*60 + isec) * 1000
	akp=0.7
c	open(unit=4,file='test_ne.txt',type='replace')

      alatr=0.0
	do i=0,200
	  x=float(i-100)/10.0
c        i=16
c        x=1.4
	print*,'%being worked: ',float(i)/2.0
	do j=0,200
	  y=float(j-100)/10.0
c        j=6
c        y=0.6
	  r=sqrt(x*x+y*y)
          along=atan2(y,x)
          amlt=along/3.1415927*12.0 + 12.0
          if (amlt.gt.24.0) amlt=amlt-24.0
          call gcpm_v24(itime,r,amlt,alatr,akp,outn)
c      	  print*,'out:',outn(1),x,y,r,amlt,alatr
c          write(4,*) x,y,outn(1)
          if ((outn(1).lt.0.0) .or. (outn(1).gt.1.0e7)) then
      	  print*,'we be stopped'
      	  print*,'outn:',outn(1),x,y,r,amlt,alatr
            stop
          endif
          den(i+1,j+1)=outn(1)
	enddo
      enddo

	open(unit=3,file='test_equatorial.bin',form='UNFORMATTED')
      write(3) den
      close(unit=3)
c      close(unit=4)

	stop
	end


C
C $Id: ilsint.f,v 1.4 2008-07-27 00:17:31 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      FUNCTION ILSINT (XCPA,YCPA,XCPB,YCPB,XCPC,YCPC,XCPD,YCPD)
C
C This function has a non-zero value if and only if the 2D line
C segments AB and CD overlap.
C
C Initialize the value of the function to say that the line
C segments don't intersect.
C
        ILSINT=0
C
C Compute a denominator needed below.  (Its value is zero if and
C only if the line segments are parallel.)
C
        DNOM=(XCPB-XCPA)*(YCPD-YCPC)-(XCPD-XCPC)*(YCPB-YCPA)
C
C If the line segments are parallel, they don't intersect.
C
        IF (DNOM.EQ.0.) RETURN
C
C Otherwise, find the values of S and T, in the parametric equations
C for line segments AB and CD, for which intersection occurs.
C
        S=((XCPC-XCPA)*(YCPD-YCPC)-(XCPD-XCPC)*(YCPC-YCPA))/DNOM
        T=((XCPC-XCPA)*(YCPB-YCPA)-(XCPB-XCPA)*(YCPC-YCPA))/DNOM
C
C If both S and T are strictly between 0 and 1, the line segments
C intersect; otherwise, they don't.
C
        IF (S.GT.0..AND.S.LT.1..AND.T.GT.0..AND.T.LT.1.) ILSINT=1
C
C Done.
C
        RETURN
C
      END


! Copyright (c) 2011-2013 Bartosz Szczesny
! LICENSE: The MIT License (MIT)

program task_2
    integer :: RY = 2005, CY, NY
    real( kind = 8 ) :: RT = 15.0, CT, RCT
    real( kind = 8 ) :: CCO2, CRTCO2 = 1.5
    real( kind = 8 ) :: CSUL, CRTSUL = 3.0

    open( 22, file = "un.txt" )
    read( 22, * ) CY, CT, CCO2, CSUL
    close( 22 )

    NY = CY - RY
    RCT = ( CT - RT ) / NY

    if ( RCT > +0.1 ) then
        print *, "global warming"
    endif
    if ( RCT < -0.1 ) then
        print *, "global cooling"
    endif

    if ( RCT == 0.0 ) then
        print *, "no climate change"
    else
        if ( ( RCT >= -0.1 ) .and. ( RCT <= +0.1 ) ) then
            if ( ( CCO2 < CRTCO2 ) .and. ( CSUL < CRTSUL ) ) then
                print *, "climate change not iminent"
            else
                if ( ( CCO2 > CRTCO2 ) .and. ( CSUL > CRTSUL ) ) then
                    print *, "cannot predict"
                else
                    if ( CCO2 > CRTCO2 ) then
                        print *, "global warming likely"
                    endif
                    if ( CSUL > CRTSUL ) then
                        print *, "global cooling likely"
                    endif
                endif
            endif
        endif
    endif

    stop
end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C   Copyright (C) 1995-2004, Scientific Computing Division,
C   University Corporation for Atmospheric Research
C   Licensed under the GNU General Public License (GPL)
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id: cosqb1.f,v 1.2 2006-11-21 01:10:16 haley Exp $
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE DCOSQB1(N,INC,X,WSAVE,WORK,IER)
      DOUBLE PRECISION X
      DOUBLE PRECISION WSAVE
      DOUBLE PRECISION WORK
      DOUBLE PRECISION XIM1
      DIMENSION X(INC,*),WSAVE(*),WORK(*)

      IER = 0
      NS2 = (N+1)/2
      NP2 = N + 2
      DO 101 I = 3,N,2
          XIM1 = X(1,I-1) + X(1,I)
          X(1,I) = .5D0* (X(1,I-1)-X(1,I))
          X(1,I-1) = .5D0*XIM1
  101 CONTINUE
      X(1,1) = .5D0*X(1,1)
      MODN = MOD(N,2)
      IF (MODN.NE.0) GO TO 302
      X(1,N) = .5D0*X(1,N)
  302 LENX = INC* (N-1) + 1
      LNSV = N + INT(LOG(DBLE(N))) + 4
      LNWK = N
C
      CALL DRFFT1B(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1)
      IF (IER1.NE.0) THEN
          IER = 20
          CALL DXERFFT('COSQB1',-5)
          GO TO 400
      END IF
C
      DO 102 K = 2,NS2
          KC = NP2 - K
          WORK(K) = WSAVE(K-1)*X(1,KC) + WSAVE(KC-1)*X(1,K)
          WORK(KC) = WSAVE(K-1)*X(1,K) - WSAVE(KC-1)*X(1,KC)
  102 CONTINUE
      IF (MODN.NE.0) GO TO 305
      X(1,NS2+1) = WSAVE(NS2)* (X(1,NS2+1)+X(1,NS2+1))
  305 DO 103 K = 2,NS2
          KC = NP2 - K
          X(1,K) = WORK(K) + WORK(KC)
          X(1,KC) = WORK(K) - WORK(KC)
  103 CONTINUE
      X(1,1) = X(1,1) + X(1,1)
  400 RETURN
      END


      SUBROUTINE MB04NY( M, N, V, INCV, TAU, A, LDA, B, LDB, DWORK )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To apply a real elementary reflector H to a real m-by-(n+1)
C     matrix C = [ A  B ], from the right, where A has one column. H is
C     represented in the form
C                                        ( 1 )
C           H = I - tau * u *u',    u  = (   ),
C                                        ( v )
C     where tau is a real scalar and v is a real n-vector.
C
C     If tau = 0, then H is taken to be the unit matrix.
C
C     In-line code is used if H has order < 11.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices A and B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix B.  N >= 0.
C
C     V       (input) DOUBLE PRECISION array, dimension
C             (1+(N-1)*ABS( INCV ))
C             The vector v in the representation of H.
C
C     INCV    (input) INTEGER
C             The increment between the elements of v.  INCV <> 0.
C
C     TAU     (input) DOUBLE PRECISION
C             The scalar factor of the elementary reflector H.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,1)
C             On entry, the leading M-by-1 part of this array must
C             contain the matrix A.
C             On exit, the leading M-by-1 part of this array contains
C             the updated matrix A (the first column of C * H).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,M).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading M-by-N part of this array must
C             contain the matrix B.
C             On exit, the leading M-by-N part of this array contains
C             the updated matrix B (the last n columns of C * H).
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,M).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (M)
C             DWORK is not referenced if H has order less than 11.
C
C     METHOD
C
C     The routine applies the elementary reflector H, taking the special
C     structure of C into account.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTORS
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1998.
C     Based on LAPACK routines DLARFX and DLATZM.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, elementary reflector, orthogonal
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INCV, LDA, LDB, M, N
      DOUBLE PRECISION  TAU
C     .. Array Arguments ..
      DOUBLE PRECISION  A( LDA, * ), B( LDB, * ), DWORK( * ), V( * )
C     .. Local Scalars ..
      INTEGER           IV, J
      DOUBLE PRECISION  SUM, T1, T2, T3, T4, T5, T6, T7, T8, T9, V1, V2,
     $                  V3, V4, V5, V6, V7, V8, V9
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DCOPY, DGEMV, DGER
C
C     .. Executable Statements ..
C
      IF( TAU.EQ.ZERO )
     $   RETURN
C
C     Form  C * H, where H has order n+1.
C
      GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
     $        170, 190 ) N+1
C
C     Code for general N. Compute
C
C     w := C*u,  C := C - tau * w * u'.
C
      CALL DCOPY( M, A, 1, DWORK, 1 )
      CALL DGEMV( 'No transpose', M, N, ONE, B, LDB, V, INCV, ONE,
     $            DWORK, 1 )
      CALL DAXPY( M, -TAU, DWORK, 1, A, 1 )
      CALL DGER( M, N, -TAU, DWORK, 1, V, INCV, B, LDB )
      GO TO 210
   10 CONTINUE
C
C     Special code for 1 x 1 Householder
C
      T1 = ONE - TAU
      DO 20 J = 1, M
         A( J, 1 ) = T1*A( J, 1 )
   20 CONTINUE
      GO TO 210
   30 CONTINUE
C
C     Special code for 2 x 2 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      DO 40 J = 1, M
         SUM = A( J, 1 ) + V1*B( J, 1 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
   40 CONTINUE
      GO TO 210
   50 CONTINUE
C
C     Special code for 3 x 3 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      DO 60 J = 1, M
         SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
   60 CONTINUE
      GO TO 210
   70 CONTINUE
C
C     Special code for 4 x 4 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      DO 80 J = 1, M
         SUM = A( J, 1 ) + V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
   80 CONTINUE
      GO TO 210
   90 CONTINUE
C
C     Special code for 5 x 5 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      DO 100 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
  100 CONTINUE
      GO TO 210
  110 CONTINUE
C
C     Special code for 6 x 6 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      IV = IV + INCV
      V5 = V( IV )
      T5 = TAU*V5
      DO 120 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 ) + V5*B( J, 5 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
         B( J, 5 ) = B( J, 5 ) - SUM*T5
  120 CONTINUE
      GO TO 210
  130 CONTINUE
C
C     Special code for 7 x 7 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      IV = IV + INCV
      V5 = V( IV )
      T5 = TAU*V5
      IV = IV + INCV
      V6 = V( IV )
      T6 = TAU*V6
      DO 140 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
         B( J, 5 ) = B( J, 5 ) - SUM*T5
         B( J, 6 ) = B( J, 6 ) - SUM*T6
  140 CONTINUE
      GO TO 210
  150 CONTINUE
C
C     Special code for 8 x 8 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      IV = IV + INCV
      V5 = V( IV )
      T5 = TAU*V5
      IV = IV + INCV
      V6 = V( IV )
      T6 = TAU*V6
      IV = IV + INCV
      V7 = V( IV )
      T7 = TAU*V7
      DO 160 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
     $                      V7*B( J, 7 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
         B( J, 5 ) = B( J, 5 ) - SUM*T5
         B( J, 6 ) = B( J, 6 ) - SUM*T6
         B( J, 7 ) = B( J, 7 ) - SUM*T7
  160 CONTINUE
      GO TO 210
  170 CONTINUE
C
C     Special code for 9 x 9 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      IV = IV + INCV
      V5 = V( IV )
      T5 = TAU*V5
      IV = IV + INCV
      V6 = V( IV )
      T6 = TAU*V6
      IV = IV + INCV
      V7 = V( IV )
      T7 = TAU*V7
      IV = IV + INCV
      V8 = V( IV )
      T8 = TAU*V8
      DO 180 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
     $                      V7*B( J, 7 ) + V8*B( J, 8 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
         B( J, 5 ) = B( J, 5 ) - SUM*T5
         B( J, 6 ) = B( J, 6 ) - SUM*T6
         B( J, 7 ) = B( J, 7 ) - SUM*T7
         B( J, 8 ) = B( J, 8 ) - SUM*T8
  180 CONTINUE
      GO TO 210
  190 CONTINUE
C
C     Special code for 10 x 10 Householder
C
      IV = 1
      IF( INCV.LT.0 )
     $   IV = (-N+1)*INCV + 1
      V1 = V( IV )
      T1 = TAU*V1
      IV = IV + INCV
      V2 = V( IV )
      T2 = TAU*V2
      IV = IV + INCV
      V3 = V( IV )
      T3 = TAU*V3
      IV = IV + INCV
      V4 = V( IV )
      T4 = TAU*V4
      IV = IV + INCV
      V5 = V( IV )
      T5 = TAU*V5
      IV = IV + INCV
      V6 = V( IV )
      T6 = TAU*V6
      IV = IV + INCV
      V7 = V( IV )
      T7 = TAU*V7
      IV = IV + INCV
      V8 = V( IV )
      T8 = TAU*V8
      IV = IV + INCV
      V9 = V( IV )
      T9 = TAU*V9
      DO 200 J = 1, M
         SUM = A( J, 1 ) +  V1*B( J, 1 ) + V2*B( J, 2 ) + V3*B( J, 3 ) +
     $                      V4*B( J, 4 ) + V5*B( J, 5 ) + V6*B( J, 6 ) +
     $                      V7*B( J, 7 ) + V8*B( J, 8 ) + V9*B( J, 9 )
         A( J, 1 ) = A( J, 1 ) - SUM*TAU
         B( J, 1 ) = B( J, 1 ) - SUM*T1
         B( J, 2 ) = B( J, 2 ) - SUM*T2
         B( J, 3 ) = B( J, 3 ) - SUM*T3
         B( J, 4 ) = B( J, 4 ) - SUM*T4
         B( J, 5 ) = B( J, 5 ) - SUM*T5
         B( J, 6 ) = B( J, 6 ) - SUM*T6
         B( J, 7 ) = B( J, 7 ) - SUM*T7
         B( J, 8 ) = B( J, 8 ) - SUM*T8
         B( J, 9 ) = B( J, 9 ) - SUM*T9
  200 CONTINUE
  210 CONTINUE
      RETURN
C *** Last line of MB04NY ***
      END


!> @file
!!   Routines to calculate the Faddeeva-function
!! @author
!!      ALGORITHM 680, COLLECTED ALGORITHMS FROM ACM.
!!      THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
!!      VOL. 16, NO. 1, PP. 47.

!>  @brief GIVEN A COMPLEX NUMBER Z = (XI,YI), THIS SUBROUTINE COMPUTES
!!  THE VALUE OF THE FADDEEVA-FUNCTION W(Z) = EXP(-Z**2)*ERFC(-I*Z),
!!  WHERE ERFC IS THE COMPLEX COMPLEMENTARY ERROR-FUNCTION AND I
!!  MEANS SQRT(-1).
!!
!!  THE ACCURACY OF THE ALGORITHM FOR Z IN THE 1ST AND 2ND QUADRANT
!!  IS 14 SIGNIFICANT DIGITS; IN THE 3RD AND 4TH IT IS 13 SIGNIFICANT
!!  DIGITS OUTSIDE A CIRCULAR REGION WITH RADIUS 0.126 AROUND A ZERO
!!  OF THE FUNCTION.
!!  ALL REAL VARIABLES IN THE PROGRAM ARE DOUBLE PRECISION.
!!
!!
!!  THE CODE CONTAINS A FEW COMPILER-DEPENDENT PARAMETERS :
!!     RMAXREAL = THE MAXIMUM VALUE OF RMAXREAL EQUALS THE ROOT OF
!!                RMAX = THE LARGEST NUMBER WHICH CAN STILL BE
!!                IMPLEMENTED ON THE COMPUTER IN DOUBLE PRECISION
!!                FLOATING-POINT ARITHMETIC
!!     RMAXEXP  = LN(RMAX) - LN(2)
!!     RMAXGONI = THE LARGEST POSSIBLE ARGUMENT OF A DOUBLE PRECISION
!!                GONIOMETRIC FUNCTION (DCOS, DSIN, ...)
!!  THE REASON WHY THESE PARAMETERS ARE NEEDED AS THEY ARE DEFINED WILL
!!  BE EXPLAINED IN THE CODE BY MEANS OF COMMENTS
!!
!!
!!  PARAMETER LIST
!!     XI     = REAL      PART OF Z
!!     YI     = IMAGINARY PART OF Z
!!     U      = REAL      PART OF W(Z)
!!     V      = IMAGINARY PART OF W(Z)
!!     FLAG   = AN ERROR FLAG INDICATING WHETHER OVERFLOW WILL
!!              OCCUR OR NOT; TYPE LOGICAL;
!!              THE VALUES OF THIS VARIABLE HAVE THE FOLLOWING
!!              MEANING :
!!              FLAG=.FALSE. : NO ERROR CONDITION
!!              FLAG=.TRUE.  : OVERFLOW WILL OCCUR, THE ROUTINE
!!                             BECOMES INACTIVE
!!  XI, YI      ARE THE INPUT-PARAMETERS
!!  U, V, FLAG  ARE THE OUTPUT-PARAMETERS
!!
!!  FURTHERMORE THE PARAMETER FACTOR EQUALS 2/SQRT(PI)
!!
!!  THE ROUTINE IS NOT UNDERFLOW-PROTECTED BUT ANY VARIABLE CAN BE
!!  PUT TO 0 UPON UNDERFLOW;
!!
!!  REFERENCE - GPM POPPE, CMJ WIJERS; MORE EFFICIENT COMPUTATION OF
!!  THE COMPLEX ERROR-FUNCTION, ACM TRANS. MATH. SOFTWARE.
SUBROUTINE WOFZ (XI, YI, U, V, FLAG)

  implicit none
  !IMPLICIT DOUBLE PRECISION (A-H, O-Z)

  real(kind=8), intent(in)      :: xi
  real(kind=8), intent(in)      :: yi
  real(kind=8), intent(out)     :: u
  real(kind=8), intent(out)     :: v
  logical, intent(out)          :: flag
  LOGICAL A, B
  real(kind=8) :: factor, rmaxreal, rmaxexp, rmaxgoni, xabs, yabs, x, y, qrho, xabsq
  real(kind=8) :: xquad, yquad, h, h2, kapn, j, xsum, ysum, xaux, u1, qlambda, rx, v1
  real(kind=8) :: daux, ry, u2, sx, v2, sy, tx, ty, c, w1
  integer :: i, n, nu, np1
  PARAMETER (FACTOR   = 1.12837916709551257388D0,&
       RMAXREAL = 0.5D+154,RMAXEXP  = 708.503061461606D0,&
       RMAXGONI = 3.53711887601422D+15)

  FLAG = .FALSE.

  XABS = DABS(XI)
  YABS = DABS(YI)
  X    = XABS/6.3
  Y    = YABS/4.4

!     THE FOLLOWING IF-STATEMENT PROTECTS
!     QRHO = (X**2 + Y**2) AGAINST OVERFLOW

  IF ((XABS.GT.RMAXREAL).OR.(YABS.GT.RMAXREAL)) then
     FLAG = .TRUE.
     RETURN
  end IF

  QRHO = X**2 + Y**2

  XABSQ = XABS**2
  XQUAD = XABSQ - YABS**2
  YQUAD = 2*XABS*YABS

  A     = QRHO.LT.0.085264D0

  IF (A) THEN
     !IF (QRHO.LT.0.085264D0) THEN THE FADDEEVA-FUNCTION IS EVALUATED
     !USING A POWER-SERIES (ABRAMOWITZ/STEGUN, EQUATION (7.1.5), P.297)
     !N IS THE MINIMUM NUMBER OF TERMS NEEDED TO OBTAIN THE REQUIRED
     !ACCURACY

     QRHO  = (1-0.85*Y)*DSQRT(QRHO)
     N     = IDNINT(6 + 72*QRHO)
     J     = 2*N+1
     XSUM  = 1.0/J
     YSUM  = 0.0D0
     DO I=N, 1, -1
        J    = J - 2
        XAUX = (XSUM*XQUAD - YSUM*YQUAD)/I
        YSUM = (XSUM*YQUAD + YSUM*XQUAD)/I
        XSUM = XAUX + 1.0/J
     end DO
     U1   = -FACTOR*(XSUM*YABS + YSUM*XABS) + 1.0
     V1   =  FACTOR*(XSUM*XABS - YSUM*YABS)
     DAUX =  DEXP(-XQUAD)
     U2   =  DAUX*DCOS(YQUAD)
     V2   = -DAUX*DSIN(YQUAD)

     U    = U1*U2 - V1*V2
     V    = U1*V2 + V1*U2

  ELSE

     !IF (QRHO.GT.1.O) THEN W(Z) IS EVALUATED USING THE LAPLACE
     !CONTINUED FRACTION
     !NU IS THE MINIMUM NUMBER OF TERMS NEEDED TO OBTAIN THE REQUIRED
     !ACCURACY
     !
     !IF ((QRHO.GT.0.085264D0).AND.(QRHO.LT.1.0)) THEN W(Z) IS EVALUATED
     !BY A TRUNCATED TAYLOR EXPANSION, WHERE THE LAPLACE CONTINUED FRACTION
     !IS USED TO CALCULATE THE DERIVATIVES OF W(Z)
     !KAPN IS THE MINIMUM NUMBER OF TERMS IN THE TAYLOR EXPANSION NEEDED
     !TO OBTAIN THE REQUIRED ACCURACY
     !NU IS THE MINIMUM NUMBER OF TERMS OF THE CONTINUED FRACTION NEEDED
     !TO CALCULATE THE DERIVATIVES WITH THE REQUIRED ACCURACY

     IF (QRHO.GT.1.0) THEN
        H    = 0.0D0
        KAPN = 0
        QRHO = DSQRT(QRHO)
        NU   = IDINT(3 + (1442/(26*QRHO+77)))
     ELSE
        QRHO = (1-Y)*DSQRT(1-QRHO)
        H    = 1.88*QRHO
        H2   = 2*H
        KAPN = IDNINT(7  + 34*QRHO)
        NU   = IDNINT(16 + 26*QRHO)
     ENDIF

     B = (H.GT.0.0)

     IF (B) QLAMBDA = H2**KAPN

     RX = 0.0
     RY = 0.0
     SX = 0.0
     SY = 0.0

     DO N=NU, 0, -1
        NP1 = N + 1
        TX  = YABS + H + NP1*RX
        TY  = XABS - NP1*RY
        C   = 0.5/(TX**2 + TY**2)
        RX  = C*TX
        RY  = C*TY
        IF ((B).AND.(N.LE.KAPN)) THEN
           TX = QLAMBDA + SX
           SX = RX*TX - RY*SY
           SY = RY*TX + RX*SY
           QLAMBDA = QLAMBDA/H2
        ENDIF
     end DO

     IF (H.EQ.0.0) THEN
        U = FACTOR*RX
        V = FACTOR*RY
     ELSE
        U = FACTOR*SX
        V = FACTOR*SY
     END IF

     IF (YABS.EQ.0.0) U = DEXP(-XABS**2)

  END IF

  !
  !  EVALUATION OF W(Z) IN THE OTHER QUADRANTS
  !

  IF (YI.LT.0.0) THEN

     IF (A) THEN
        U2    = 2*U2
        V2    = 2*V2
     ELSE
        XQUAD =  -XQUAD

        !         THE FOLLOWING IF-STATEMENT PROTECTS 2*EXP(-Z**2)
        !         AGAINST OVERFLOW

        IF ((YQUAD.GT.RMAXGONI).OR. &
             (XQUAD.GT.RMAXEXP)) then
           FLAG = .TRUE.
           !print *,'BBB',xi,yi,YQUAD,XQUAD,RMAXGONI,RMAXEXP
           RETURN
        end IF

        W1 =  2*DEXP(XQUAD)
        U2  =  W1*DCOS(YQUAD)
        V2  = -W1*DSIN(YQUAD)
     END IF

     U = U2 - U
     V = V2 - V
     IF (XI.GT.0.0) V = -V
  ELSE
     IF (XI.LT.0.0) V = -V
  END IF

END SUBROUTINE WOFZ

!> The same function as above multiplied by exp(-yi**2), to protect against overflows
subroutine wofz_mod(alpha,m,q,jm,u,v,flag)
   use Poisson_Solver, only: dp
   implicit none
   real(dp), intent(in) :: alpha
   integer, intent(in) :: q,m,jm
   logical, intent(out) :: flag
   real(dp), intent(out) :: u,v
   !local variables
   real(dp), parameter :: factor=1.12837916709551257388_dp,rmaxreal=0.5e+154_dp
   real(dp), parameter :: rmaxexp=708.503061461606_dp !n(c) ,rmaxgoni=3.53711887601422e+15_dp
   real(dp), parameter :: pi=3.1415926535897932384_dp
   logical :: a,b
   integer :: j,n,i,kapn,nu,np1
   real(dp) :: xabs,yabs,x,y,qrho,xquad,yquad,xsum,ysum,xaux,u1,v1,u2,v2,daux,h,qlambda,h2
   real(dp) :: rx,ry,sx,sy,tx,ty,c,w1,xabsq,xi,yi,fac,yquadmod

   flag = .false.

   fac=pi/real(2*m,dp)/alpha

   xi=fac*real(q,dp)
   yi=alpha*real(jm,dp)
   xabs = dabs(xi)
   yabs = dabs(yi)
   x    = xabs/6.3_dp
   y    = yabs/4.4_dp

    ! the following if-statement protects
    ! qrho = (x**2 + y**2) against overflow
   if ((xabs > rmaxreal).or.(yabs > rmaxreal)) then
      flag = .true.
      return
   end if

   qrho = x**2 + y**2

   xabsq = xabs**2
   xquad = xabsq - yabs**2
   yquad = 2*xabs*yabs
   !yquad to be passed to trigonometric functions
   yquadmod = real(modulo(abs(q*jm),2*m),dp)/real(m,dp)*pi

   a = qrho < 0.085264_dp

   if (a) then
      !if (qrho < 0.085264d0) then the faddeeva-function is evaluated
      !using a power-series (abramowitz/stegun, equation (7.1.5), p.297)
      !n is the minimum number of terms needed to obtain the required
      !accuracy

      qrho  = (1._dp-0.85_dp*y)*sqrt(qrho)
      n     = nint(6._dp + 72._dp*qrho)
      j     = 2*n+1
      xsum  = 1.0_dp/real(j,dp)
      ysum  = 0.0_dp
      do i=n, 1, -1
         j    = j - 2
         xaux = (xsum*xquad - ysum*yquad)/real(i,dp)
         ysum = (xsum*yquad + ysum*xquad)/real(i,dp)
         xsum = xaux + 1.0_dp/real(j,dp)
      end do
      u1   = -factor*(xsum*yabs + ysum*xabs) + 1.0_dp
      v1   =  factor*(xsum*xabs - ysum*yabs)
      !MODIFICATION: the exponent is corrected, yabs disappears

      daux = fac**2
      daux = exp(-daux)
      daux = daux**(q**2)

      !daux =  exp(-xquad-yabs**2)
      u2   =  daux*dcos(yquadmod)
      v2   = -daux*dsin(yquadmod)

      u    = u1*u2 - v1*v2
      v    = u1*v2 + v1*u2

   else

      !if (qrho.gt.1.0) then w(z) is evaluated using the laplace
      !continued fraction
      !nu is the minimum number of terms needed to obtain the required
      !accuracy
      !
      !if ((qrho.gt.0.085264).and.(qrho.lt.1.0)) then w(z) is evaluated
      !by a truncated taylor expansion, where the laplace continued fraction
      !is used to calculate the derivatives of w(z)
      !kapn is the minimum number of terms in the taylor expansion needed
      !to obtain the required accuracy
      !nu is the minimum number of terms of the continued fraction needed
      !to calculate the derivatives with the required accuracy

      if (qrho > 1.0) then
         h    = 0.0_dp
         kapn = 0
         qrho = sqrt(qrho)
         nu   = int(3._dp + (1442._dp/(26._dp*qrho+77._dp)))
      else
         qrho = (1-y)*sqrt(1-qrho)
         h    = 1.88*qrho
         h2   = 2._dp*h
         kapn = nint(7._dp  + 34._dp*qrho)
         nu   = nint(16._dp + 26._dp*qrho)
      endif

      b = (h > 0.0_dp)

      if (b) qlambda = h2**kapn

      rx = 0.0_dp
      ry = 0.0_dp
      sx = 0.0_dp
      sy = 0.0_dp

      do n=nu, 0, -1
         np1 = n + 1
         tx  = yabs + h + real(np1,dp)*rx
         ty  = xabs - real(np1,dp)*ry
         c   = 0.5_dp/(tx**2 + ty**2)
         rx  = c*tx
         ry  = c*ty
         if ((b).and.(n <= kapn)) then
            tx = qlambda + sx
            sx = rx*tx - ry*sy
            sy = ry*tx + rx*sy
            qlambda = qlambda/h2
         endif
         !print *,'nu,yabs,xabs,tx,ty,rx,ry',n,nu,yabs,xabs,tx,ty,rx,ry
      end do

      if (h == 0.0_dp) then
         u = factor*rx
         v = factor*ry
      else
         u = factor*sx
         v = factor*sy
      end if

      !MODIFICATION: here the exponent is added
      daux=exp(-yabs**2)
      u=daux*u
      v=daux*v

      !still do not now what happens to v in that case
      if (yabs == 0.0_dp) u = dexp(-xabs**2)

   end if

   !  evaluation of w(z) in the other quadrants
   if (jm < 0) then

      if (a) then
         !no modification is needed
         u2    = 2._dp*u2
         v2    = 2._dp*v2
      else
         xquad =  -xquad

         !the following if-statement protects 2*exp(-z**2)
         !against overflow, taking into account the modification
         if (xquad-yabs**2 > rmaxexp) then
            flag = .true.
            return
         end if
         !daux = fac**2
         !daux = exp(-daux)
         !w1 = 2.0_dp*daux**(q**2)
         !avoid floating point exceptions
         daux = real(q,kind=8)*fac
         daux = daux*daux
         daux = dexp(-daux)
         w1 = 2.0_dp*daux
         !w1 =  2*dexp(xquad-yabs**2)
         u2  =  w1*dcos(yquadmod)
         v2  = -w1*dsin(yquadmod)
         !print *,'w1,u2,v2',yquad,yquadmod,xquad,yabs**2,xquad-yabs**2,w1,u2,v2
      end if

      u = u2 - u
      v = v2 - v
      !print *,u,v
      if (q > 0) v = -v
   else
      if (q < 0) v = -v
   end if
END SUBROUTINE wofz_mod