      subroutine SEVUN(A, LDA, N, EVALR, EVALI, IFLAG)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SEVUN  Krogh  MIN0 => MIN
c>> 1994-10-20 SEVUN  Krogh  Changes to use M77CON
c>> 1992-04-24 SEVUN  CLL   Minor edits.
c>> 1992-04-23 SEVUN  Krogh Made DP version compatible with SP version.
c>> 1991-10-25 SEVUN  Krogh Initial version, converted from EISPACK.
c
c     This subroutine uses slight modifcations of EISPACK routines
c     BALANC, ELMHES, and HQR to get the eigenvalues of a general real
c     matrix by the QR method.  The first two are are encapsulated in
c     SEVBH.  HQR, which is inline here, is a translation of the ALGOL
c     procedure HQR, Num. Math. 14, 219-231(1970) by Martin, Peters, and
c     Wilkinson.
c     Handbook for Auto. Comp., Vol.ii-Linear Algebra, 359-371(1971).
c
c     On input
c     A      contains the input matrix whose eigenvalues are desired.
c     LDA    must be set to the row dimension of two-dimensional array
c            parameters as declared in the calling program dimension
c            statement.
c     N      is the order of the matrix.
c
c     On output
c     A      has been destroyed.
c     EVALR and EVALI contain real and imaginary parts, respectively, of
c          the eigenvalues.  The eigenvalues are given in order of
c          increasing real parts.  When real parts are equal they are
c          given in order of increasing absolute complex part.  Complex
c          conjugate pairs of values appear consecutively with
c          the eigenvalue having the positive imaginary part first.  If
c          an error exit is made, the eigenvalues should be correct
c          (but unordered) for indices IFLAG(1)+1,...,N.
c     IFLAG(1) is set to
c          1   If all eigenvalues are real.
c          2   If some eigenvalues are complex.
c          3   If N < 1 on the initial entry.
c          4   If the limit of 30*N iterations is exhausted.
c     ------------------------------------------------------------------
c--S replaces "?": ?EVUN, ?EVBH
c     ------------------------------------------------------------------
      integer I,J,K,L,M,N,EN,NA,LDA,IGH,ITN,ITS,LOW,MP2,ENM2,IFLAG(N)
      integer LTYPE
      real             A(LDA,N),EVALR(N),EVALI(N)
      real             P,Q,R,S,T,W,X,Y,ZZ,NORM,TST1,TST2
      logical NOTLAS
c
c     ------------------------------------------------------------------
c
      call SEVBH(A, LDA, N, LOW, IGH, IFLAG, EVALR)
      LTYPE = 1
      NORM = 0.0E0
      K = 1
c     .......... store roots isolated by SEVBH
c                and compute matrix norm ..........
      do 50 I = 1, N
         do 40 J = K, N
            NORM = NORM + abs(A(I,J))
   40    continue
         K = I
         if ((I .lt. LOW) .or. (I .gt. IGH)) then
            EVALR(I) = A(I,I)
            EVALI(I) = 0.0E0
         end if
   50 continue
      EN = IGH
      T = 0.0E0
      ITN = 30*N
c     .......... search for next eigenvalues ..........
   60 if (EN .lt. LOW) go to 300
      ITS = 0
      NA = EN - 1
      ENM2 = NA - 1
c     .......... look for single small sub-diagonal element
   70 do 80 L = EN, LOW+1, -1
         S = abs(A(L-1,L-1)) + abs(A(L,L))
         if (S .eq. 0.0E0) S = NORM
         TST1 = S
         TST2 = TST1 + abs(A(L,L-1))
         if (TST2 .eq. TST1) go to 100
   80 continue
c     .......... form shift ..........
  100 X = A(EN,EN)
      if (L .eq. EN) go to 270
      Y = A(NA,NA)
      W = A(EN,NA) * A(NA,EN)
      if (L .eq. NA) go to 280
      if (ITN .le. 0) then
c     .......... set error -- all eigenvalues have not
c                converged after 30*N iterations ..........
         call ERMSG('SEVUN', EN, 0,
     1'ERROR NO. is index of eigenvalue causing convergence failure.',
     2            '.')
         IFLAG(1) = 4
         if (EN .le. 0) IFLAG(1) = 3
         return
      end if
      if (ITS .ne. 10 .and. ITS .ne. 20) go to 130
c     .......... form exceptional shift ..........
      T = T + X
      do 120 I = LOW, EN
         A(I,I) = A(I,I) - X
  120 continue
      S = abs(A(EN,NA)) + abs(A(NA,ENM2))
      X = 0.75E0 * S
      Y = X
      W = -0.4375E0 * S * S
  130 ITS = ITS + 1
      ITN = ITN - 1
c     .......... look for two consecutive small sub-diagonal elements.
      do 140 M = ENM2, L, -1
         ZZ = A(M,M)
         R = X - ZZ
         S = Y - ZZ
         P = (R * S - W) / A(M+1,M) + A(M,M+1)
         Q = A(M+1,M+1) - ZZ - R - S
         R = A(M+2,M+1)
         S = abs(P) + abs(Q) + abs(R)
         P = P / S
         Q = Q / S
         R = R / S
         if (M .eq. L) go to 150
         TST1 = abs(P)*(abs(A(M-1,M-1)) + abs(ZZ) + abs(A(M+1,M+1)))
         TST2 = TST1 + abs(A(M,M-1))*(abs(Q) + abs(R))
         if (TST2 .eq. TST1) go to 150
  140 continue
  150 MP2 = M + 2
      do 160 I = MP2, EN
         A(I,I-2) = 0.0E0
         if (I .ne. MP2) A(I,I-3) = 0.0E0
  160 continue
c     .......... double QR step involving rows L to EN and
c                columns M to EN ..........
      do 260 K = M, NA
         NOTLAS = K .ne. NA
         if (K .ne. M) then
            P = A(K,K-1)
            Q = A(K+1,K-1)
            R = 0.0E0
            if (NOTLAS) R = A(K+2,K-1)
            X = abs(P) + abs(Q) + abs(R)
            if (X .eq. 0.0E0) go to 260
            P = P / X
            Q = Q / X
            R = R / X
         end if
         S = sign(sqrt(P*P+Q*Q+R*R),P)
         if (K .ne. M) then
            A(K,K-1) = -S * X
         else
            if (L .ne. M) A(K,K-1) = -A(K,K-1)
         end if
         P = P + S
         X = P / S
         Y = Q / S
         ZZ = R / S
         Q = Q / P
         R = R / P
         if (NOTLAS) then
c        .......... row modification ..........
            do 200 J = K, N
               P = A(K,J) + Q * A(K+1,J) + R * A(K+2,J)
               A(K,J) = A(K,J) - P * X
               A(K+1,J) = A(K+1,J) - P * Y
               A(K+2,J) = A(K+2,J) - P * ZZ
  200       continue
            J = min(EN,K+3)
c        .......... column modification ..........
            do 210 I = 1, J
               P = X * A(I,K) + Y * A(I,K+1) + ZZ * A(I,K+2)
               A(I,K) = A(I,K) - P
               A(I,K+1) = A(I,K+1) - P * Q
               A(I,K+2) = A(I,K+2) - P * R
  210       continue
         else
c     .......... row modification ..........
            do 230 J = K, N
               P = A(K,J) + Q * A(K+1,J)
               A(K,J) = A(K,J) - P * X
               A(K+1,J) = A(K+1,J) - P * Y
  230       continue
            J = min(EN,K+3)
c        .......... column modification ..........
            do 240 I = 1, J
               P = X * A(I,K) + Y * A(I,K+1)
               A(I,K) = A(I,K) - P
               A(I,K+1) = A(I,K+1) - P * Q
  240       continue
         end if
  260 continue
      go to 70
c     .......... one root found ..........
  270 EVALR(EN) = X + T
      EVALI(EN) = 0.0E0
      EN = NA
      go to 60
c     .......... two roots found ..........
  280 P = (Y - X) / 2.0E0
      Q = P * P + W
      ZZ = sqrt(abs(Q))
      X = X + T
      if (Q .ge. 0.0E0) then
c        .......... real pair ..........
         ZZ = P + sign(ZZ,P)
         EVALR(NA) = X + ZZ
         EVALR(EN) = EVALR(NA)
         if (ZZ .ne. 0.0E0) EVALR(EN) = X - W / ZZ
         EVALI(NA) = 0.0E0
         EVALI(EN) = 0.0E0
      else
c        .......... complex pair ..........
         LTYPE = 2
         EVALR(NA) = X + P
         EVALR(EN) = X + P
         EVALI(NA) = ZZ
         EVALI(EN) = -ZZ
      end if
      EN = ENM2
      go to 60
c
  300 continue
c-- Begin mask code changes
c                        Set up for Shell sort
c             Sort so real parts are algebraically increasing
c             For = real parts, so abs(imag. parts) are increasing
c             For both =, sort on index -- preserves complex pair order
c-- End mask code changes
      do 2000 I = 1, N
         IFLAG(I) = I
 2000 continue
      L = 1
      do 2010 K = 1, N
         L = 3*L + 1
         if (L .ge. N) go to 2020
 2010 continue
 2020 L = max(1, (L-4) / 9)
 2030 do 2100 J = L+1, N
         K = IFLAG(J)
         P = EVALR(K)
         I = J - L
 2040    if (P - EVALR(IFLAG(I))) 2070, 2050, 2080
 2050    if (abs(EVALI(K)) - abs(EVALI(IFLAG(I)))) 2070, 2060, 2080
 2060    if (K .gt. IFLAG(I)) go to 2080
 2070    IFLAG(I+L) = IFLAG(I)
         I = I - L
         if (I .gt. 0) go to 2040
 2080    IFLAG(I+L) = K
 2100 continue
      L = (L-1) / 3
      if (L .ne. 0) go to 2030
c              Indices in IFLAG now give the desired order --
c              Move entries to get this order.
 2110 do 2150 I = L+1, N
         if (IFLAG(I) .ne. I) then
            L = I
            M = I
            P = EVALR(I)
            Q = EVALI(I)
 2120       K = IFLAG(M)
            IFLAG(M) = M
            if (K .ne. L) then
               EVALR(M) = EVALR(K)
               EVALI(M) = EVALI(K)
               M = K
               go to 2120
            else
               EVALR(M) = P
               EVALI(M) = Q
               go to 2110
            end if
         end if
 2150 continue
      IFLAG(1) = LTYPE
      return
      end


program test
logical :: flag1, flag2, flag3, flag4, flag5, flag6
integer :: a = 5
integer :: b = 5
flag1 = a == b
flag2 = a /= b
flag3 = a < b
flag4 = a <= b
flag5 = a > b
flag6 = a >= b
print *,(a + b)
end program test


module mod_public_private

   implicit none

   public

   real, parameter :: pi = 3.141592653, &
                      c = 299792458, &
                      e = 2.7182818285

   real, private :: rad_2_deg = 180.0/pi
   real, private :: deg_2_rad = pi/180.0

   private :: sin_deg, cos_deg

   public :: tan_deg

contains

   function sin_deg(x) result(y)
      real, intent(in) :: x ! input
      real             :: y ! output
      y = sin(x*deg_2_rad)
   end function

   function cos_deg(x) result(y)
      real, intent(in) :: x ! input
      real             :: y ! output
      y = cos(x*deg_2_rad)
   end function

   function tan_deg(x) result(y)
      real, intent(in) :: x ! input
      real             :: y ! output
      y = sin_deg(x)/cos_deg(x)
   end function

end module mod_public_private

program priv_pub_module

   use mod_public_private

   implicit none

   real :: r = 2.0

   print *, 'Area = ', pi*r**2

   ! This print will not work
   ! The variables rad_2_deg and deg_2_rad are private
   !print *, rad_2_deg, deg_2_rad

   print *, 'Tan(45) ', tan_deg(45.0)

   ! These lines will not work as functions are private
   !print *, 'Sin(45) ', sin_rad(45.0)
   !print *, 'Cos(45) ', cos_rad(45.0)

end program


module high_scores
  implicit none
contains

function scores(score_list)
  integer, dimension(:) :: score_list
  integer, dimension(:) :: scores(size(score_list))
  scores(:) = score_list(:)
end function

integer function latest(score_list)
  integer, dimension(:) :: score_list
  integer :: slen
  slen = size(score_list)
  latest = score_list(slen)
end function

integer function personalBest(score_list)
  integer, dimension(:) :: score_list
  personalBest = maxval(score_list)
end function

 function personalTopThree(score_list)
  integer, dimension(:) :: score_list
  logical, dimension(:) :: score_list_mask(size(score_list))
  integer, dimension(3) :: personalTopThree
  integer :: i
  integer :: j
  personalTopThree=[0,0,0]
  score_list_mask(:) = .true.
  do i=1,min(3, size(score_list))
    personalTopThree(i) = maxval(score_list, mask=score_list_mask)
    j = maxloc(score_list, dim=1, mask=score_list_mask)
    score_list_mask(j) = .false.
  end do
end function

end module


SUBROUTINE maxnorm(n,u1,u2,out)
USE Precision
USE Constants
IMPLICIT NONE
INTEGER :: n, i
REAL(KIND=long) :: u1(n), u2(n), out
out = zero
DO i = 1, n
   out = MAX(ABS(u1(i)-u2(i)),out)
END DO
END SUBROUTINE maxnorm


C Given latitude and longitude of a point on an oblate spheroid,
C returns the line and sample values of that point for a geometrically
C corrected perspective projection.
C
C        PARAMETERS -
C
C          IND = RETURN INDICATOR
C              0 = NORMAL RETURN
C              99 = POINT BEHIND PLANET
C              -1 ON ENTRY SUPPRESSES BACK-OF-PLANET TEST
C          XL = RETURNED LINE VALUE (REAL
C          YS = RETURNED SAMPLE VALUE (REAL)
C          RLAT = INPUT LATITUDE (DEGREES)
C          RLON = INPUT LONGITUDE (DEGREES)
C            RS = INPUT VECTOR TO SPACECRAFT IN PLANET COORDINATE SYSTEM
C            FLAT = INPUT POLAR FLATTENING (EQ. RAD - POL. RAD.)
C            FOCL = INPUT CAMERA FOCAL LENGTH
C            REQ = INPUT PLANET EQUATORIAL RADIUS
C
C
      SUBROUTINE CORCAV(IND,RLAT,RLON,OM,RS,FOCL,REQ,FLAT,XL,YS,
     &CL,CS,FLAG)
      DOUBLE PRECISION OM(3,3),RS(3)
      DIMENSION SP(3),CFP(3)
      REAL PIFAC/57.29577951/
      RAD(PHI,REQ,FLAT)=REQ/SQRT(  REQ*REQ/((REQ-FLAT)**2)+(1.-REQ*REQ/
     &((REQ-FLAT)**2))*(COS(PHI*3.14159265/180.))**2 )

C        SOLVE FOR CAMERA FOCAL PLANE (CFP) COORDINATES

      CPJ = COS(RLAT/PIFAC)
      SPJ = SIN(RLAT/PIFAC)
      CLJ = COS(RLON/PIFAC)
      SLJ = SIN(RLON/PIFAC)

C     ....Compute geocentric radius
      IF (RLAT.EQ.0. .OR. ABS(RLAT).EQ.180.) THEN
         RJ = REQ
      ELSE
         RJ=RAD(RLAT,REQ,FLAT)
      ENDIF

      SP(1)=RJ*CPJ*CLJ-RS(1)
      SP(2)=RJ*CPJ*SLJ-RS(2)
      SP(3)=RJ*SPJ-RS(3)

      DO 120 I = 1,3
  120 CFP(I) = OM(I,1)*SP(1) + OM(I,2)*SP(2) + OM(I,3)*SP(3)

C  SKIP BACK-OF-PLANET TEST IF IND=-1

      IF(IND.EQ.-1)GO TO 130

C        TEST FOR BACK OF PLANET

      ZETA=0.
      TST=0.
      DO 125 I=1,3
      ZETA=ZETA+SP(I)**2
125   TST=TST+RS(I)**2
      TST=TST-RJ**2
      IF(ZETA.LE.TST) GO TO 130
      XS=FLAG
      ZL=FLAG
      IND = 99
      RETURN

C        SOLVE FOR PIXEL COORDINATES

130   U=FOCL*CFP(1)/CFP(3)
      V=FOCL*CFP(2)/CFP(3)
      XL=CL+V
      YS=CS+U
      IND = 0
      RETURN
      END


      DOUBLE PRECISION FUNCTION AB13BD( DICO, JOBN, N, M, P, A, LDA,
     $                                  B, LDB, C, LDC, D, LDD, NQ, TOL,
     $                                  DWORK, LDWORK, IWARN, INFO)
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the H2 or L2 norm of the transfer-function matrix G
C     of the system (A,B,C,D). G must not have poles on the imaginary
C     axis, for a continuous-time system, or on the unit circle, for
C     a discrete-time system. If the H2-norm is computed, the system
C     must be stable.
C
C     FUNCTION VALUE
C
C     AB13BD   DOUBLE PRECISION
C              The H2-norm of G, if JOBN = 'H', or the L2-norm of G,
C              if JOBN = 'L' (if INFO = 0).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     JOBN    CHARACTER*1
C             Specifies the norm to be computed as follows:
C             = 'H':  the H2-norm;
C             = 'L':  the L2-norm.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A, the number of rows of the
C             matrix B, and the number of columns of the matrix C.
C             N represents the dimension of the state vector.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of the matrices B and D.
C             M represents the dimension of input vector.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of the matrices C and D.
C             P represents the dimension of output vector.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix of the system.
C             On exit, the leading NQ-by-NQ part of this array contains
C             the state dynamics matrix (in a real Schur form) of the
C             numerator factor Q of the right coprime factorization with
C             inner denominator of G (see METHOD).
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input/state matrix of the system.
C             On exit, the leading NQ-by-M part of this array contains
C             the input/state matrix of the numerator factor Q of the
C             right coprime factorization with inner denominator of G
C             (see METHOD).
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the state/output matrix of the system.
C             On exit, the leading P-by-NQ part of this array contains
C             the state/output matrix of the numerator factor Q of the
C             right coprime factorization with inner denominator of G
C             (see METHOD).
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     D       (input/output) DOUBLE PRECISION array, dimension (LDD,M)
C             On entry, the leading P-by-M part of this array must
C             contain the input/output matrix of the system.
C             If DICO = 'C', D must be a null matrix.
C             On exit, the leading P-by-M part of this array contains
C             the input/output matrix of the numerator factor Q of
C             the right coprime factorization with inner denominator
C             of G (see METHOD).
C
C     LDD     INTEGER
C             The leading dimension of array D.  LDD >= MAX(1,P).
C
C     NQ      (output) INTEGER
C             The order of the resulting numerator Q of the right
C             coprime factorization with inner denominator of G (see
C             METHOD).
C             Generally, NQ = N - NS, where NS is the number of
C             uncontrollable unstable eigenvalues.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The absolute tolerance level below which the elements of
C             B are considered zero (used for controllability tests).
C             If the user sets TOL <= 0, then an implicitly computed,
C             default tolerance, defined by  TOLDEF = N*EPS*NORM(B),
C             is used instead, where EPS is the machine precision
C             (see LAPACK Library routine DLAMCH) and NORM(B) denotes
C             the 1-norm of B.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.
C             LDWORK >= MAX( 1, M*(N+M) + MAX( N*(N+5), M*(M+2), 4*P ),
C                               N*( MAX( N, P ) + 4 ) + MIN( N, P ) ).
C             For optimum performance LDWORK should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = K:  K violations of the numerical stability condition
C                   occured during the assignment of eigenvalues in
C                   computing the right coprime factorization with inner
C                   denominator of G (see the SLICOT subroutine SB08DD).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the reduction of A to a real Schur form failed;
C             = 2:  a failure was detected during the reordering of the
C                   real Schur form of A, or in the iterative process
C                   for reordering the eigenvalues of Z'*(A + B*F)*Z
C                   along the diagonal (see SLICOT routine SB08DD);
C             = 3:  if DICO = 'C' and the matrix A has a controllable
C                   eigenvalue on the imaginary axis, or DICO = 'D'
C                   and A has a controllable eigenvalue on the unit
C                   circle;
C             = 4:  the solution of Lyapunov equation failed because
C                   the equation is singular;
C             = 5:  if DICO = 'C' and D is a nonzero matrix;
C             = 6:  if JOBN = 'H' and the system is unstable.
C
C     METHOD
C
C     The subroutine is based on the algorithms proposed in [1] and [2].
C
C     If the given transfer-function matrix G is unstable, then a right
C     coprime factorization with inner denominator of G is first
C     computed
C               -1
C        G = Q*R  ,
C
C     where Q and R are stable transfer-function matrices and R is
C     inner. If G is stable, then Q = G and R = I.
C     Let (AQ,BQ,CQ,DQ) be the state-space representation of Q.
C
C     If DICO = 'C', then the L2-norm of G is computed as
C
C        NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ)),
C
C     where X satisfies the continuous-time Lyapunov equation
C
C        AQ'*X + X*AQ + CQ'*CQ = 0.
C
C     If DICO = 'D', then the l2-norm of G is computed as
C
C        NORM2(G) = NORM2(Q) = SQRT(TRACE(BQ'*X*BQ+DQ'*DQ)),
C
C     where X satisfies the discrete-time Lyapunov equation
C
C        AQ'*X*AQ - X + CQ'*CQ = 0.
C
C     REFERENCES
C
C     [1] Varga A.
C         On computing 2-norms of transfer-function matrices.
C         Proc. 1992 ACC, Chicago, June 1992.
C
C     [2] Varga A.
C         A Schur method for computing coprime factorizations with
C         inner denominators and applications in model reduction.
C         Proc. ACC'93, San Francisco, CA, pp. 2130-2131, 1993.
C
C     NUMERICAL ASPECTS
C                                            3
C     The algorithm requires no more than 14N  floating point
C     operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     July 1998.
C     Based on the RASP routine SL2NRM.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C     Jan. 2003, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Coprime factorization, Lyapunov equation, multivariable system,
C     state-space model, system norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE, ZERO
      PARAMETER         ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, JOBN
      INTEGER           INFO, IWARN, LDA, LDB, LDC, LDD, LDWORK, M,
     $                  N, NQ, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           KCR, KDR, KRW, KTAU, KU, MXNP, NR
      DOUBLE PRECISION  S2NORM, SCALE, WRKOPT
C     .. External functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLANGE, DLAPY2
      EXTERNAL          DLANGE, DLAPY2, LSAME
C     .. External subroutines ..
      EXTERNAL          DLACPY, DTRMM, SB03OU, SB08DD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN
C     .. Executable Statements ..
C
      DISCR = LSAME( DICO, 'D' )
      INFO  = 0
      IWARN = 0
C
C     Check the scalar input parameters.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( JOBN, 'H' ) .OR. LSAME( JOBN, 'L' ) ) )
     $      THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDD.LT.MAX( 1, P ) ) THEN
         INFO = -13
      ELSE IF( LDWORK.LT.MAX( 1, M*( N + M ) +
     $                             MAX( N*( N + 5 ), M*( M + 2 ), 4*P ),
     $                           N*( MAX( N, P ) + 4 ) + MIN( N, P ) ) )
     $      THEN
         INFO = -17
      END IF
      IF( INFO.NE.0 )THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13BD', -INFO )
         RETURN
      END IF
C
C     Compute the Frobenius norm of D.
C
      S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK )
      IF( .NOT.DISCR .AND. S2NORM.NE.ZERO ) THEN
         INFO = 5
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         NQ = 0
         AB13BD   = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
      KCR = 1
      KDR = KCR + M*N
      KRW = KDR + M*M
C
C     Compute the right coprime factorization with inner denominator
C     of G.
C
C     Workspace needed:      M*(N+M);
C     Additional workspace:  need MAX( N*(N+5), M*(M+2), 4*M, 4*P );
C                            prefer larger.
C
      CALL SB08DD( DICO, N, M, P, A, LDA, B, LDB, C, LDC, D, LDD, NQ,
     $             NR, DWORK(KCR), M, DWORK(KDR), M, TOL, DWORK(KRW),
     $             LDWORK-KRW+1, IWARN, INFO )
      IF( INFO.NE.0 )
     $   RETURN
C
      WRKOPT = DWORK(KRW) + DBLE( KRW-1 )
C
C     Check stability.
C
      IF( LSAME( JOBN, 'H' ) .AND. NR.GT.0 ) THEN
         INFO = 6
         RETURN
      END IF
C
      IF( NQ.GT.0 ) THEN
         KU   = 1
         MXNP = MAX( NQ, P )
         KTAU = NQ*MXNP + 1
         KRW  = KTAU + MIN( NQ, P )
C
C        Find X, the solution of Lyapunov equation.
C
C        Workspace needed:      N*MAX(N,P) + MIN(N,P);
C        Additional workspace:  4*N;
C                               prefer larger.
C
         CALL DLACPY( 'Full', P, NQ, C, LDC, DWORK(KU), MXNP )
         CALL SB03OU( DISCR, .FALSE., NQ, P, A, LDA, DWORK(KU), MXNP,
     $                DWORK(KTAU), DWORK(KU), NQ, SCALE, DWORK(KRW),
     $                LDWORK-KRW+1, INFO )
         IF( INFO.NE.0 ) THEN
            IF( INFO.EQ.1 ) THEN
               INFO = 4
            ELSE IF( INFO.EQ.2 ) THEN
               INFO = 3
            END IF
            RETURN
         END IF
C
         WRKOPT = MAX( WRKOPT, DWORK(KRW) + DBLE( KRW-1 ) )
C
C        Add the contribution of BQ'*X*BQ.
C
C        Workspace needed:      N*(N+M).
C
         KTAU = NQ*NQ + 1
         CALL DLACPY( 'Full', NQ, M, B, LDB, DWORK(KTAU), NQ )
         CALL DTRMM( 'Left', 'Upper', 'NoTranspose', 'NonUnit', NQ, M,
     $               ONE, DWORK(KU), NQ, DWORK(KTAU), NQ )
         IF( NR.GT.0 )
     $      S2NORM = DLANGE( 'Frobenius', P, M, D, LDD, DWORK )
         S2NORM = DLAPY2( S2NORM, DLANGE( 'Frobenius', NQ, M,
     $                                    DWORK(KTAU), NQ, DWORK )
     $                               / SCALE )
      END IF
C
      AB13BD = S2NORM
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of AB13BD ***
      END


C     LAST UPDATE 17/01/97
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE REDSEC(BUF,CX,CY,X1,Y1,X2,Y2)
      IMPLICIT NONE
C
C Purpose: Converts sector coordinates from xfix
C          into centre-of-gravity filespace coordinates.
C
C Calls   0:
C Called by: GUIFIX
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C FIX include file:
C
      INCLUDE 'FIXPAR.COM'
C
C Arguments:
C
      REAL BUF(NPIX*NRAST)
      REAL CX,CY,X1,Y1,X2,Y2
C
C Local variables:
C
      INTEGER NP,I,J,NR,NPHI,M,IX,IY,NVAL,NBAK
      REAL XS(2),YS(2),DELX(2),DELY(2)
      REAL DX1,DY1,DX2,DY2,PHI1,PHI2,DPHI,PHI,R,TEMP,DX,DY,R1,R2
      REAL X,Y,TWOPI
      REAL AVV,BAK,XCG,YCG
C
C Data:
C
      DATA TWOPI /6.2831853/
C
C-----------------------------------------------------------------------
      NP = NPTS
C
C========Process sectors
C
      NP = NP + 1
C
C========Find centre of gravity, average value and number of interior
C========pixels for sectors
C
      DX1 = X1 - CX
      DY1 = CY - Y1
      DX2 = X2 - CX
      DY2 = CY - Y2
      R1 = SQRT(DX1*DX1+DY1*DY1)
      R2 = SQRT(DX2*DX2+DY2*DY2)
      PHI1 = ATAN2(DY1,DX1)
      PHI2 = ATAN2(DY2,DX2)
      IF(PHI2.LT.PHI1)PHI2 = PHI2 + TWOPI
C
C========Calculate background along perimeter of sector
C
      NBAK = 0
      BAK = 0.0
C
C========Sum the radial background contribution
C
      IF(R2.GT.R1)THEN
         DELX(1) = COS(PHI1)
         DELY(1) = -SIN(PHI1)
         DELX(2) = COS(PHI2)
         DELY(2) = -SIN(PHI2)
      ELSE
         DELX(1) = -COS(PHI1)
         DELY(1) = SIN(PHI1)
         DELX(2) = -COS(PHI2)
         DELY(2) = SIN(PHI2)
      ENDIF
      XS(1) = X1
      XS(2) = X2
      YS(1) = Y1
      YS(2) = Y2
      NR = NINT(ABS(R2-R1))
      DO 20 I=0,NR
         DO 10 J=1,2
         X = XS(J) + FLOAT(I)*DELX(J) + 0.5
         Y = YS(J) + FLOAT(I)*DELY(J) + 0.5
         IX = INT(X)
         IY = INT(Y)
         IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &      IY.GE.1.AND.IY.LT.NRAST)THEN
            NBAK = NBAK + 1
            M = (IY-1)*NPIX + IX
            DX = X - FLOAT(IX)
            DY = Y - FLOAT(IY)
            BAK = BAK
     &           + (1.0-DX)*(1.0-DY)*BUF(M)
     &           +       DX*(1.0-DY)*BUF(M+1)
     &           +       (1.0-DX)*DY*BUF(M+NPIX)
     &           +             DX*DY*BUF(M+NPIX+1)
         ENDIF
 10      CONTINUE
 20   CONTINUE
C
C========Sum azimuthal background contribution
C
      DPHI = 1/R1
      NPHI = NINT(R1*(PHI2-PHI1))
      DO 40 I=0,NPHI
         PHI = FLOAT(I)*DPHI
         X = CX + R1*COS(PHI) + 0.5
         Y = CY - R1*SIN(PHI) + 0.5
         IX = INT(X)
         IY = INT(Y)
         IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &      IY.GE.1.AND.IY.LT.NRAST)THEN
            NBAK = NBAK + 1
            M = (IY-1)*NPIX + IX
            DX = X - FLOAT(IX)
            DY = Y - FLOAT(IY)
            BAK = BAK
     &           + (1.0-DX)*(1.0-DY)*BUF(M)
     &           +       DX*(1.0-DY)*BUF(M+1)
     &           +       (1.0-DX)*DY*BUF(M+NPIX)
     &           +             DX*DY*BUF(M+NPIX+1)
         ENDIF
 40   CONTINUE
      DPHI = 1/R2
      NPHI = NINT(R2*(PHI2-PHI1))
      DO 50 I=0,NPHI
         PHI = FLOAT(I)*DPHI
         X = CX + R2*COS(PHI) + 0.5
         Y = CY - R2*SIN(PHI) + 0.5
         IX = INT(X)
         IY = INT(Y)
         IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &      IY.GE.1.AND.IY.LT.NRAST)THEN
            NBAK = NBAK + 1
            M = (IY-1)*NPIX + IX
            DX = X - FLOAT(IX)
            DY = Y - FLOAT(IY)
            BAK = BAK
     &           + (1.0-DX)*(1.0-DY)*BUF(M)
     &           +       DX*(1.0-DY)*BUF(M+1)
     &           +       (1.0-DX)*DY*BUF(M+NPIX)
     &           +             DX*DY*BUF(M+NPIX+1)
         ENDIF
 50   CONTINUE
      IF(BAK.GT.0.0)BAK = BAK/FLOAT(NBAK)
C
C========Loop over interior points of sector
C
      NVAL = 0
      XCG = 0.0
      YCG = 0.0
      AVV = 0.0
      DO 70 I=1,NR-1
         R = R1 + SIGN(FLOAT(I),R2-R1)
         DPHI = 1/R
         NPHI = NINT(R*(PHI2-PHI1))
         DO 60 J=1,NPHI-1
            PHI = PHI1 + FLOAT(J)*DPHI
            X = CX + R*COS(PHI) + 0.5
            Y = CY - R*SIN(PHI) + 0.5
            IX = INT(X)
            IY = INT(Y)
            IF(IX.GE.1.AND.IX.LT.NPIX.AND.
     &         IY.GE.1.AND.IY.LT.NRAST)THEN
               NVAL = NVAL + 1
               M = (IY-1)*NPIX + IX
               DX = X - FLOAT(IX)
               DY = Y - FLOAT(IY)
               TEMP = (1.0-DX)*(1.0-DY)*BUF(M)
     &              +       DX*(1.0-DY)*BUF(M+1)
     &              +       (1.0-DX)*DY*BUF(M+NPIX)
     &              +             DX*DY*BUF(M+NPIX+1)
               TEMP = TEMP - BAK
               XCG = XCG + (X-0.5)*TEMP
               YCG = YCG + (Y-0.5)*TEMP
               AVV = AVV + TEMP
            ENDIF
 60      CONTINUE
 70   CONTINUE
      IF(ABS(AVV).GT.0.0)THEN
         XCG = XCG/AVV
         YCG = YCG/AVV
         AVV = AVV/FLOAT(NVAL) + BAK
      ELSE
         PHI = (PHI2+PHI1)/2.0
         DPHI = (PHI2-PHI1)/2.0
         R = ABS(2.0*SIN(DPHI)*(R2**3-R1**3)/(3.0*DPHI*(R2**2-R1**2)))
         XCG = CX + R*COS(PHI)
         YCG = CY - R*SIN(PHI)
      ENDIF
C
C========Write information to common block arrays
C
      FXY(1,NP) = XCG
      FXY(2,NP) = YCG
      AVPIX(NP) = AVV
      BCK(NP) = BAK
      NVALS(NP) = -NVAL
      NPTS = NP
C
C========Convert to standard coordinates if possible
C
      IF(GOTCEN.AND.GOTROT)THEN
         CALL FTOSTD
         IF(GOTWAV.AND.GOTSDD.AND.GOTTIL)CALL STOREC
      ENDIF
      RETURN
C
      END


!	This is a module file to help to compute
!	It include 3 subroutines to make the program function well

       module sub
       contains
!

!	This subroutine is used to calculate p and grad_p which use the data of
!	latitude and longtitude from user
       subroutine point(N0,x,y,p,grad_p)
       real*8 x
       real*8 y
       real*8 p(N0*(N0+3)/2+1) !to get p,we need p(0),so total number+1
       real*8 sy,cy
       real*8 grad_p(N0*(N0+3)/2+1)!to fit with p,total number also plus one
       integer N0,n,m,i !we use n,m,i in loop

	sy=sin(y)
	cy=cos(y)
       p(1)=1
       p(2)=cy
       p(3)=sy
       grad_p(1)=0!we don't use it,give it whatever you want
       grad_p(2)=(cos(y)*p(2)-p(1))/sin(y)
       grad_p(3)=cos(y)*p(3)/sin(y)
       i=4
       do n=2,N0
       	do m=0,n
       		if(m==n	)then
       			p(i)=p(i-n-1)*sy*((2.0d0*m-1)/(2.0d0*m))**0.5
       			grad_p(i)=n*cy*p(i-n-1)*((2.0d0*m-1)/(2.0d0*m))**0.5
       		else
       			p(i)=((2.0d0*n-1)*cy*p(i-n)-((n-1)**2-m**2)** &
       		&	0.5*p(i-n-n+1))/(n**2-m**2)**0.5
       			grad_p(i)=(n*cy*p(i)-(n**2-m**2)**&
       		&	0.5*p(i-n))/sy
       		end if
       		i=i+1
       	end do
       end do
       end subroutine point

!	得到观测方程的系数矩阵NA，j表示计算NA第几行，即第j个观测点的系数行。
!	subroutine getNAofx(lat,lon,r,Nmax,NA,j)
!	real*8 lat,lon,r,NA(Nmax*(Nmax+3),Nmax*(Nmax+3))
!	integer Nmax,j,i
!	real*8 p(Nmax*(Nmax+3)/2+1),grad_p(Nmax*(Nmax+3)/2+1)
!	call subroutine point(Nmax,lon,lat,p,grad_p)
!		!ux=ux+(g(i)*cos(m*x)+h(i)*sin(m*x))*grad_p(i+1)
!	i=1
!	do n=1,N0
!		do m=0,n
!		NA(j,i)=cos(m*x)*grad_p(i+1)
!		NA(j,i+Nmax*(Nmax+3)/2)=sin(m*x)*grad_p(i+1)
!		i=i+1
!		end do
!	end do
!	end subroutine

	subroutine getgh(N0,g,h)!to calculate g,h
	integer N0
	real*8 g(N0*(N0+3)/2)
	real*8 h(N0*(N0+3)/2)
11	format(f12.2,f12.2)
	open(10,file='new.cof')
	do i=1,65
		read(10,11)g(i),h(i)

	end do
	close(10)
	end subroutine getgh

	subroutine Utotal(N0,r,x,y,g,h,p,grad_p,u,ux,uy,uz)!to calculate u

	real*8 g(N0*(N0+3)/2)
	real*8 h(N0*(N0+3)/2)
	real*8 u,r,uz,ux,uy
	real*8 x
	real*8 y
	real*8 p(N0*(N0+3)/2+1) !to get p,we need p(0,0),so total number+1
	real*8 grad_p(N0*(N0+3)/2+1)!to fit with p,total number also plus one
	integer N0,n,m,i !we use n,m,i in loop
	real*8 date,alt,colat,elong,f
	isv=0;date=1900.0;itype=2;alt=6371.2;colat=60;elong=30
	u=0d0
	uy=0d0
	ux=0d0
	uz=0d0
	i=1
	do n=1,N0
		do m=0,n
		u=u+(g(i)*cos(m*x)+h(i)*sin(m*x))*p(i+1)
		uy=uy+(g(i)*sin(m*x)-h(i)*cos(m*x))*m*p(i+1)
		uz=uz-(n+1)*(g(i)*cos(m*x)+h(i)*sin(m*x))*p(i+1)
		ux=ux+(g(i)*cos(m*x)+h(i)*sin(m*x))*grad_p(i+1)
		i=i+1

		end do
	end do
	u=u*r
	uy=uy/sin(y)
	end subroutine utotal
end


module solvers
use types, only: dp
use lapack, only: dlamch, dsygvx, dggev, dsysv, dsygvd
use utils, only: stop_error
use sorting, only: sortpairs
implicit none
private
public solve_eig_range, spurious, filter_spurious_states, count_nodes, &
    solve_eig_range2, solve_sym, solve_eig_range3

CONTAINS

subroutine solve_eig_range(Am, Bm, Emin, Emax, lam, c)
! solves system equations
! simple dense solver for now, sparse solver better suited for low-order FE/SE ...
real(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Emin, Emax
real(dp), allocatable, intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
real(dp), allocatable, intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
integer i, n
! lapack variables
integer lwork, info, m
integer, allocatable:: iwork(:), ifail(:)
real(dp) abstol
real(dp), allocatable:: Amt(:,:), Bmt(:,:), lamt(:), work(:)
real(dp), allocatable:: z(:,:)

! solve
n=size(Am,1)
lwork=8*n
allocate(Amt(n,n),Bmt(n,n),lamt(n),work(lwork),iwork(5*n),ifail(n),z(n,n))
Amt=Am; Bmt=Bm  ! Amt,Bmt temporaries overwritten by dsygvx
abstol=2*dlamch('S')
call dsygvx(1,'V','V','L',n,Amt,n,Bmt,n,Emin,Emax,0,0,abstol,m, &
    lamt,z,n,work,lwork,iwork,ifail,info)
if (info/=0) then
    print *, "dsygvx returned info =", info
    if (info <= n) then
        print *, info, "eigenvectors failed to converge. Their indices are:"
        print *, ifail
    else
        print *, "The leading minor of order ", info-n, &
            "of B is not positive definite. The factorization of B could ", &
            "not be completed and no eigenvalues or eigenvectors were computed."
    end if
    call stop_error('DSYGVX ERROR')
end if
! Copy the found eigenvalues/vectors into lam/c
allocate(lam(m), c(n, m))
lam(:) = lamt(:m)
c(:, :) = z(:, :m)
do i = 1, m ! normalize such that initial values positive
   if (c(2,i)<0) c(:,i)=-c(:,i)
end do
!write(*,*) "Eigenvector residuals ||Am c - lam Bm c||: "
!allocate(r(n))
!do i = 1, m
!   r=matmul(Am-lam(i)*Bm,c(:,i))
!   write(*,'(1x,i5,a,es18.11)') i, ": ", sqrt(dot_product(r,r))
!   print *, dot_product(c(:, i), matmul(Bm, c(:, i)))
!end do
end subroutine

subroutine solve_eig_range2(Am, Bm, Emin, Emax, lam, c)
! solves generalized nonsymmetric eigenvalue problem
real(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Emin, Emax
real(dp), allocatable, intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
real(dp), allocatable, intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
integer i, j, n
! lapack variables
integer lwork, info
real(dp), allocatable:: Amt(:,:), Bmt(:,:), work(:)
real(dp), allocatable:: r(:)
real(dp), allocatable :: vl(:, :)
real(dp), allocatable :: vr(:, :), alphar(:), alphai(:), beta(:)
real(dp), allocatable :: lambda(:)
integer, allocatable :: sel(:)
!complex(dp), parameter :: J = (0, 1)

! solve
n=size(Am,1)
lwork=8*n
allocate(Amt(n,n), Bmt(n,n), work(lwork), vr(n, n), alphar(n), alphai(n), &
    beta(n), vl(n, n))
Amt=Am; Bmt=Bm  ! Amt,Bmt temporaries overwritten by dsygvx
call dggev('N', 'V', n, Amt, n, Bmt, n, alphar, alphai, beta, vl, n, &
    vr, n, work, lwork, info)
if (info/=0) then
    print *, "dsygvx returned info =", info
    if (info <= n) then
        print *, "The", info, " iteration failed."
    else
        print *, "Other error"
    end if
    call stop_error('DGGEV ERROR')
end if
allocate(lambda(n), sel(n))
where (abs(beta) > 1e-16_dp) lambda = alphar / beta
j = 0
do i = 1, n
    sel(i) = 0
    if (abs(alphai(i)) < tiny(1._dp)) then
        if (abs(beta(i)) < tiny(1._dp)) then
            ! Maybe we can just ignore the beta==0 cases
            call stop_error("Got beta==0")
        end if
        if (lambda(i) > Emin .and. lambda(i) < Emax) then
            j = j + 1
            sel(i) = j
        end if
    end if
end do
allocate(lam(maxval(sel)), c(n, maxval(sel)))
do i = 1, size(lambda)
    if (sel(i) /= 0) then
        lam(sel(i)) = lambda(i)
        c(:, sel(i)) = vr(:, i)
    end if
end do
call sortpairs(lam, c)
do i = 1, size(lam) ! normalize such that initial values positive
   if (c(2,i)<0) c(:,i)=-c(:,i)
end do
! Normalize the eigenvectors:
do i = 1, size(lam)
   c(:, i) = c(:, i) / sqrt(dot_product(c(:, i), matmul(Bm, c(:, i))))
end do
write(*,*) "Eigenvector residuals ||Am c - lam Bm c||: "
allocate(r(n))
do i = 1, size(lam)
   r=matmul(Am-lam(i)*Bm,c(:,i))
   write(*,'(1x,i5,a,es18.11)') i, ": ", sqrt(dot_product(r,r))
   !print *, dot_product(c(:, i), matmul(Bm, c(:, i)))
end do
end subroutine

subroutine solve_eig_range3(Am, Bm, Emin, Emax, lam, c)
! solves system equations
! simple dense solver for now, sparse solver better suited for low-order FE/SE ...
real(dp), intent(in) :: Am(:,:)   ! LHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Bm(:,:)   ! RHS matrix: Am c = lam Bm c
real(dp), intent(in) :: Emin, Emax
real(dp), allocatable, intent(out) :: lam(:)   ! eigenvalues: Am c = lam Bm c
real(dp), allocatable, intent(out) :: c(:,:)   ! eigenvectors: Am c = lam Bm c; c(i,j) = ith component of jth vec.
integer i, n
! lapack variables
integer lwork, liwork, info, m, m1, m2
integer, allocatable:: iwork(:)
real(dp), allocatable:: Amt(:,:), Bmt(:,:), lamt(:), work(:)
real(dp), allocatable:: r(:)

! solve
n=size(Am,1)
lwork=1+6*n+2*n**2
liwork=3+5*n
allocate(Amt(n,n),Bmt(n,n),lamt(n),work(lwork),iwork(liwork))
Amt=Am; Bmt=Bm  ! Amt,Bmt temporaries overwritten by dsygvx
call dsygvd(1,'V','L',n,Amt,n,Bmt,n,lamt,work,lwork,iwork,liwork,info)
if (info/=0) then
    print *, "dsygvd returned INFO =", info
    if (info < 0) then
        print *, "the", -info, "-th argument had an illegal value"
    else if (info <= n) then
        print *, "the algorithm failed to compute an eigenvalue while working"
        print *, "on the submatrix lying in rows and columns", 1.0_dp*info/(n+1)
        print *, "through", mod(info, n+1)
    else
        print *, "The leading minor of order ", info-n, &
            "of B is not positive definite. The factorization of B could ", &
            "not be completed and no eigenvalues or eigenvectors were computed."
    end if
    call stop_error('DSYGVD ERROR')
end if
! TODO: make sure things work with regards m1==n and m2==n:
m1 = 1
do while (lamt(m1) < Emin .and. m1 < n)
    m1 = m1 + 1
end do
! m1 is the first eigenvalue in the range
m2 = m1
do while (lamt(m2) <= Emax .and. m2 < n)
    m2 = m2 + 1
end do
m2 = m2 - 1
! m2 is the last eigenvalue in the range
m = m2-m1+1 ! number of eigenvalues in the range
! Copy the found eigenvalues/vectors into lam/c
allocate(lam(m), c(n, m))
lam(:) = lamt(m1:m2)
c(:, :) = Amt(:, m1:m2)
do i = 1, m ! normalize such that initial values positive
   if (c(2,i)<0) c(:,i)=-c(:,i)
end do
write(*,*) "Eigenvector residuals ||Am c - lam Bm c||: "
allocate(r(n))
do i = 1, m
   r=matmul(Am-lam(i)*Bm,c(:,i))
   write(*,'(1x,i5,a,es18.11)') i, ": ", sqrt(dot_product(r,r))
   print *, dot_product(c(:, i), matmul(Bm, c(:, i)))
end do
end subroutine

integer function count_nodes(u) result(nn)
! Returns the number of nodes of the function
real(dp), intent(in) :: u(:) ! State "u"

integer :: i
logical :: s, last_s, ok
real(dp) :: thres
thres = maxval(abs(u)) * 1e-5_dp
nn = 0
ok = .false.
last_s = .false. ! To fix compiler uninitialized variable warning
do i = 1, size(u)
    ! skip small "tails" of the wavefunction whose oscillations we don't want to
    ! count
    if (abs(u(i)) < thres) cycle
    s = u(i) > 0
    if (ok) then
        if (s .neqv. last_s) nn = nn + 1
    end if
    last_s = s
    ok = .true.
end do
end function

logical function spurious_old2(u)
! Returns .true. if the state "u" is spurious, otherwise .false.
! The state is declared spurious if it has (on average) less nodes per
! oscillation than allowed (see the nn_per_oscillation below), determined by
! counting the number of oscillations and comparing to the length of the vector.
real(dp), intent(in) :: u(:) ! State "u"
! The minimum allowed nodes per oscillation
integer, parameter :: nn_per_oscillation = 4

real(dp) :: osc(size(u)-1)
integer :: i, nn
logical :: s, last_s
real(dp) :: thres
integer :: last_oscillation
osc(:) = u(2:) - u(:size(u)-1) ! Calculate differences
thres = (maxval(u) - minval(u)) * 1e-5_dp ! Determine treshold
!print *, "threshold:", thres
nn = 0
last_s = osc(1) > 0
!print *, "u:"
!print *, u
!print *, "osc:"
!print *, osc
last_oscillation = 1
do i = 1, size(osc)
    ! skip small "tails" of the wavefunction whose oscillations we don't want to
    ! count
    if (abs(osc(i)) < thres) cycle
    s = osc(i) > 0
    if (s .neqv. last_s) then
        nn = nn + 1
        !if (i==99) then
        !    print *, u(i-3:)
        !end if
!        print *, "found oscillation at:", i, size(u), &
!            abs(u(i) - u(last_oscillation))
        if (i - last_oscillation < nn_per_oscillation) then
            spurious_old2 = .true.
            return
        end if
        last_oscillation = i
    end if
    last_s = s
end do
if (nn > size(u) / nn_per_oscillation) then
    spurious_old2 = .true.
else
    spurious_old2 = .false.
end if
!print *, "oscillations:", nn, size(u) / nn_per_oscillation
!print *, maxval(abs(u)), u(:10)
!print *, thres, osc(:10)
!spurious = .false.
end function

logical function spurious(u, ib)
! Returns .true. if the state "u" is spurious, otherwise .false.
! The state is declared spurious if it has (on average) less nodes per
! oscillation than allowed (see the nn_per_oscillation below), determined by
! counting the number of oscillations and comparing to the length of the vector.
real(dp), intent(in) :: u(:) ! State "u"
integer, intent(in) :: ib(:, :)   ! basis connectivity: ib(i,j) = index of basis
   ! function associated with local basis function i of element j. 0 = no
   ! associated basis fn.
! The minimum allowed nodes per oscillation
!integer, parameter :: nn_per_oscillation = 4

real(dp) :: osc(size(u) - 1)
integer :: i, ie, ip, nn
logical :: s, last_s
real(dp) :: thres
integer :: last_oscillation
osc(:) = u(2:) - u(:size(u)-1) ! Calculate differences
thres = (maxval(u) - minval(u)) * 1e-5_dp ! Determine treshold
!print *, "threshold:", thres
nn = 0
last_s = osc(1) > 0
!print *, "u:"
!print *, u
!print *, "osc:"
!print *, osc
if (size(ib, 1)-1 == 1) call stop_error("spurious check doesn't work for p=1")
last_oscillation = 1
do ie = 1, size(ib, 2)
    do ip = 1, size(ib, 1)
        i = ib(ip, ie)
        if (i == 0) cycle
        if (i < 0) cycle
        if (i > size(osc)) exit
        s = osc(i) > 0
        if (s .neqv. last_s) then
            if (abs(u(i)-u(last_oscillation)) < thres) then
                last_oscillation = i
                last_s = s
                cycle
            end if
            nn = nn + 1
            last_oscillation = i
        end if
        last_s = s
    end do
    !print *, "nn = ", nn, size(ib, 1), (size(ib, 1)-1)/3 + 1
    if (nn > (size(ib, 1)-1)/3 + 1) then
        print *, "spurious, nodes:", nn, "element:", ie
        spurious = .true.
        return
    end if
    nn = 0
end do
spurious = .false.
end function

subroutine filter_spurious_states(ib, lam, u, lam2, u2, skipped)
integer, intent(in) :: ib(:,:,:)   ! basis connectivity: ib(i,j) = index of basis
   ! function associated with local basis function i of element j. 0 = no
   ! associated basis fn.
real(dp), intent(in) :: u(:, :), lam(:)
real(dp), intent(out), allocatable :: u2(:, :), lam2(:)
logical, intent(out) :: skipped
integer :: m(size(lam))
integer :: i, j, c, c_begin, c_end, n_eig
logical :: sp
j = 0
print *, "Filtering high oscillatory states:"
do i = 1, size(lam)
    ! Loop over the vector components:
    sp = .false.
    c_begin = 1
    do c = 1, size(ib, 3)
        c_end = maxval(ib(:, :, c))
        if (spurious(u(c_begin:c_end, i), ib(:, :, c))) then
            sp = .true.
            exit
        end if
        c_begin = c_end+1
    end do
    if (sp) then
        m(i) = 0
    else
        j = j + 1
        m(i) = j
    end if
    print "(i4,i4,f12.5)", i, m(i), lam(i)
end do
n_eig = maxval(m)
allocate(u2(size(u, 1), n_eig), lam2(n_eig))
do i = 1, size(lam)
    if (m(i) /= 0) then
        u2(:, m(i)) = u(:, i)
        lam2(m(i)) = lam(i)
    end if
end do
! If we skipped any state (we filtered some in between), then these two numbers
! will mismatch:
!skipped = m(n_eig) /= n_eig
! But we actually want to see, whether we filtered anything at all:
if (size(m) == 0) then
    skipped = .false.
else
    skipped = m(size(m)) /= size(m)
end if
end subroutine

function solve_sym(Am, bv) result(c)
! solves symmetric dense system of equations
real(dp), intent(in) :: Am(:,:)   ! system matrix: Am c = bv
real(dp), intent(in) :: bv(:)     ! source vector: Am c = bv
real(dp) :: c(size(bv))     ! solution vector: Am c = bv
!real(dp) :: r(size(bv))
integer :: n
! lapack variables
integer :: lwork, info
integer, allocatable :: ipiv(:)
real(dp), allocatable :: Amt(:,:),bm(:,:),work(:)

n = size(c)
lwork = n
allocate(Amt(n,n), bm(n,1), ipiv(n), work(lwork))
Amt=Am; bm(:,1)=bv   ! temporaries for dsysv
call dsysv('L', n, 1, Amt, n, ipiv, bm, n, work, lwork, info)
if (info < 0) then
    print *, "The", -info, "-th argument had illegal value"
    call stop_error('DSYSV ERROR.')
end if
if (info > 0) then
    print *, "D(", info, ",", info, ") is exactly zero."
    print *, "The factorization has been completed, but the block diagonal"
    print *, "matrix D is exactly singular, so the solution could not be"
    print *, "computed."
    call stop_error('DSYSV ERROR.')
end if
c = bm(:, 1)
! error
!r=matmul(Am, c)-bv
!write(*,'(1x,a,es18.11)') "Solution vector residual ||Am c - bv||/||bv||: ", &
!   sqrt(dot_product(r,r)/dot_product(bv,bv))
end function

end module


!
! Program ad hoc: implement quantum computing principles
! Based on an article by Lov K. Grover about the quantum
! search algorithm, DDJ, april 2001
!
module quantum_computing
   type quantum_integer
      integer :: i
      complex :: ampl
   end type quantum_integer

   interface operator(==)
      module procedure quantum_single_is_equal
      module procedure quantum_array_equals_value
   end interface

contains

subroutine q_init( qi )
   type(quantum_integer), dimension(:), intent(inout) :: qi

   integer                                            :: i
   complex                                            :: uniform_ampl

   uniform_ampl = cmplx( 1.0/sqrt(real(size(qi))), 0.0 )
   do i = 1,size(qi)
      qi(i)%i    = i
      qi(i)%ampl = uniform_ampl
   enddo
end subroutine q_init

logical function quantum_single_is_equal( qi, iv )
   type(quantum_integer), intent(in) :: qi
   integer, intent(in)               :: iv

   quantum_single_is_equal = qi%i == iv
end function quantum_single_is_equal

function quantum_array_is_equal( qi, iv ) &
   result(log_array)
   type(quantum_integer), dimension(:), intent(in) :: qi
   integer, dimension(:), intent(in)               :: iv

   logical, dimension(1:size(qi))                  :: log_array
   integer                                         :: i

   do i = 1,size(qi)
      log_array(i) = qi(i)%i == iv(i)
   enddo
end function quantum_array_is_equal

function quantum_array_equals_value( qi, iv ) &
   result(log_array)
   type(quantum_integer), dimension(:), intent(in) :: qi
   integer, intent(in)                             :: iv

   logical, dimension(1:size(qi))                  :: log_array
   integer                                         :: i

   do i = 1,size(qi)
      log_array(i) = qi(i)%i == iv
   enddo
end function quantum_array_equals_value

function q_random( nostates, qi ) &
   result( qr )

   type(quantum_integer), dimension(:), intent(in) :: qi
   type(quantum_integer), dimension(1:size(qi))    :: qr
   integer, intent(in)                             :: nostates

   integer :: i
   integer :: j
   integer :: k
   integer :: and_bits
   complex :: new_ampl
   complex :: signed_ampl

   new_ampl = cmplx( 1.0/sqrt(real(nostates)), 0.0 )

   do i = 1,nostates
      qr(i)%i = i
      qr(i)%ampl = (0.0,0.0)
      do j = 1,nostates
         signed_ampl = new_ampl
         and_bits    = iand( qi(j)%i-1, qr(i)%i-1 )
         do k = 0,bit_size(and_bits)-1
            if ( btest(and_bits,k) ) signed_ampl = -signed_ampl
         enddo
         qr(i)%ampl = qr(i)%ampl + signed_ampl * qi(j)%ampl
      enddo
   enddo

end function q_random

function q_invert_phase( qi ) &
   result( qr )

   type(quantum_integer), dimension(:), intent(in) :: qi
   type(quantum_integer), dimension(1:size(qi))    :: qr

   integer :: i

   do i = 1,size(qi)
      qr(i)%i = i
      qr(i)%ampl = -qi(i)%ampl
   enddo

end function q_invert_phase

integer function q_observe( qi )
   type(quantum_integer), dimension(:) :: qi

   integer :: i
   real    :: rnd
   real    :: probability

   do i = 1,20
      call random_number( rnd )
   enddo

   probability = 0.0
   do i = 1,size(qi)
      probability = probability + abs( qi(i)%ampl ) ** 2
      if ( probability > rnd ) then
         q_observe = qi(i)%i
         exit
      endif
   enddo

   do i = 1,size(qi)
      if ( qi(i)%i /= q_observe ) then
         qi(i)%ampl = (0.0,0.0)
      else
         qi(i)%ampl = (1.0,0.0)
      endif
   enddo
end function q_observe

end module quantum_computing

program quantum_search
   use quantum_computing
   implicit none

   integer, parameter                           :: nostates = 4
   integer, parameter                           :: nosteps  = 1
   type(quantum_integer), dimension(1:nostates) :: qi
   integer, dimension(1:nostates)               :: iv
   integer                                      :: i
   integer                                      :: j

   !
   ! Initialise the quantum "system"
   !
   call q_init( qi )
   write(*,'(a,10f5.2)' ) 'Init', ( real(qi(j)%ampl), j = 1,nostates )

   !
   ! The test function is represented as an array
   !
   iv = 0
   iv(3) = 1

   !
   ! Preliminary randomisation - done by q_init()
   !
   !qi = q_random( nostates, qi )
   !write(*,'(a,10f5.2)' ) 'FR', ( real(qi(j)%ampl), j = 1,nostates )

   !
   ! Find the correct state
   ! Note:
   ! Counting starts at 1, not 0.
   !
   do i = 1,nosteps
      where ( iv == 1 )
         qi = q_invert_phase( qi )
      endwhere

      write(*,'(a,10f5.2)' ) 'First', ( real(qi(j)%ampl), j = 1,nostates )

      qi = q_random( nostates, qi )
      write(*,'(a,10f5.2)' ) 'Random', ( real(qi(j)%ampl), j = 1,nostates )

      where ( qi == 1 )
         qi = q_invert_phase( qi )
      endwhere
      write(*,'(a,10f5.2)' ) 'Second', ( real(qi(j)%ampl), j = 1,nostates )

      qi = q_random( nostates, qi )
      write(*,'(a,10f5.2)' ) 'SR', ( real(qi(j)%ampl), j = 1,nostates )
   enddo

   write(*,*) q_observe( qi )

   stop
end program quantum_search


c     DRSLASUM
c>> 1994-10-19 DRSLASUM Krogh  Changes to use M77CON
c>> 1994-07-14 DRSLASUM CLL
c>> 1992-05-07 CLL
c>> 1992-04-28 DRSLASUM Replaced '1' in format.
c>> 1987-12-09 DRSLASUM Lawson  Initial Code.
c--S replaces "?": DR?LASUM, ?LASUM
c     Demonstration program for evaluation of a Laguerre series.
c     ------------------------------------------------------------------
      integer j
      real             x,a(0:6),y,w,dif,reldif,pn(6)
      data a / 7.2e0, -43.2e0, 108.0e0, -144.0e0,
     *         108.0e0, -43.2e0, 7.2e0 /
      data pn / 0.1e0, 0.3e0, 1.0e0, 3.0e0, 10.0e0, 30.0e0 /
c     ------------------------------------------------------------------
      print '(1x,3x,a1,12x,a1,14x,a3,9x,a6/)','x','y','dif','reldif'
      do 10 j = 1,6
        x = pn(j)
        call slasum (x, 6, a, y)
        w = 0.01e0 * (x**6)
        dif = y - w
        reldif = dif / w
        print '(1x,f6.2,3x,g15.8,2(3x,g10.3))',x,y,dif,reldif
   10 continue
      end


module atomic_mod
use types_mod, only : spectrum_type, atmosphere_type, config_type, atomic_transition_type
use vars_mod, only : PI, PE, PC, PK, PH, UMA, OPA, PHK, ionization_state, EV_ERG, SQRTPI, conf, LARMOR
use maths_mod, only : extremes, saha, vecfvoigt, planck_vect_lambda, planck_lambda, formal_sol_vect, formal_sol_polarized,&
	strength_zeeman, vecfvoigt_zeeman, fvoigt
use background_opacity_mod, only : background_opacity
implicit none

contains

!-----------------------------------------------------------------
! Calculate the damping constant a for the Voigt profile
! following Gray 1976 "The observation and analysis of stellar photospheres"
!  Natural damping: eq (11.19)
!  van der Waals damping: eq (11.35) & (11.36)
!  Stark damping: eq (11.35) & (11.36)
!  Damping: eq (11.69)
! ion_pot : ionization potential in eV
! exc_pot_lower : excitation potential of the lower level in eV
! T : temperature array
! Pg : gas pressure array
! lambda : wavelength of the transition in A
! doppler_width : Doppler width in cm/s
!-----------------------------------------------------------------
	subroutine calculate_damping(T, nHtot, Pe, Pg, doppler_width, ion_pot, exc_pot_lower, gamma_rad, gamma_stark, gamma_vdw, lambda, &
		damping_out)
	real(kind=8) :: ion_pot, exc_pot_lower, T(:), nHtot(:), Pe(:), Pg(:), lambda, doppler_width(:)
	real(kind=8) :: damping_out(size(T)), gamma_rad, gamma_stark, gamma_vdw
	integer :: n, trans
	real(kind=8) :: c6, chi_lambda, cte, a, b
	real(kind=8), allocatable :: gamma6(:), gamma_nat(:), gamma_s(:)

		n = size(T)

		allocate(gamma6(n))
		allocate(gamma_s(n))
		allocate(gamma_nat(n))

! If the damping is not in the linelist, then use the formulas. In the other case, use those
! given by Kurucz

! RADIATIVE DAMPING
! Radiative damping
! 			Reference: Gray 1976, "The observation and analysis of stellar
!  		photospheres", pag 227, just after Eq. (11-19). This approximation
!  		is poor, but the radiative damping is usually negligible anyway.

		gamma_nat = 0.22233d0 / (lambda*1.d-8)**2

! STARK DAMPING
! Stark damping
! Formula used: gamma_4=38.8*(v**(1./3.))*(C4**(2./3.))*N , from
!   Unsold 1955, "Physik der Sternatmospharen", 2nd ed.,
!   Springer-Verlag, pp. 326 and 331. According to Gray (ref above),
!   pag 237, this is similar to
!   log (gamma_4) = 19.4 + 2./3*log C4 + log Pe - 5./6.*log T
!   The value of log C4 is approximated by -14. (see Gray, Table 11-3)

		gamma_s = 19.4 + 2.d0/3.d0*(-14.d0) + dlog10(Pe) - 5.d0/6.d0*dlog10(T)
		gamma_s = 10.d0**(gamma_s)

! HYDROGEN DAMPING
! Van der Waals damping:
! Reference: Gray (see above, pag 239, Eqs. (11-35) and (11-36))
! Formula used:
!    log (gamma_vdw) = 19.6 + 2./5.*log (C6(H)) + log Pg - 7./10.*log T

		chi_lambda = (PH*PC/EV_ERG) / (lambda*1.d-8)
		a = ion_pot-exc_pot_lower-chi_lambda
		b = ion_pot-exc_pot_lower
		c6 = 0.3d-30 * (1.d0/a**2 - 1.d0/b**2)
! It seems that the ionization potential and the energy of some levels are inconsistent, and E_exc>I
		if (c6 > 0.d0) then
			gamma6 = 10.d0**(19.6d0 + 0.4d0*dlog10(c6) + dlog10(Pg) - 0.7*dlog10(T))
		else
			gamma6 = 0.d0
		endif

		cte = 1.d-8 / (4.d0 * PI * PC)
		damping_out = cte * (gamma6+gamma_nat+gamma_s) * lambda**2 / (doppler_width * lambda / PC)

		deallocate(gamma6)
		deallocate(gamma_nat)
		deallocate(gamma_s)

	end subroutine calculate_damping

!-----------------------------------------------------------------
! Fill the strength and splitting variables of the atomic_transition structure
!-----------------------------------------------------------------
	subroutine generate_atomic_zeeman_components(at)
	type(atomic_transition_type) :: at
	integer :: i, n, nlow, nup, iup, ilow, i_pi, i_red, i_blue, cual
	real(kind=8) :: Mup, Mlow, strength

		nup = 2*at%J_up+1
		nlow = 2*at%J_low+1

		i_pi = 0
		i_blue = 0
		i_red = 0

! First count the number of components of each type (
		at%n_components = 0
		do iup = 1, nup
			Mup = at%J_up + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= at%J_low) then
					at%n_components(ilow) = at%n_components(ilow)+1
				endif
			enddo
		enddo

		allocate(at%splitting(3,maxval(at%n_components)))
		allocate(at%strength(3,maxval(at%n_components)))

! Now generate all the data
		do iup = 1, nup
			Mup = at%J_up + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= at%J_low) then
					if (ilow == 1) then
						i_blue = i_blue + 1
						cual = i_blue
					endif
					if (ilow == 2) then
						i_pi = i_pi + 1
						cual = i_pi
					endif
					if (ilow == 3) then
						i_red = i_red + 1
						cual = i_red
					endif

					at%strength(ilow,cual) = strength_zeeman(at%J_up,at%J_low,Mup,Mlow)
					at%splitting(ilow,cual) = (at%lande_up*Mup - at%lande_low*Mlow)

				endif
			enddo
		enddo

	end subroutine generate_atomic_zeeman_components

!-----------------------------------------------------------------
! Select the lines between wmin and wmax in A filling the global arrays
!
!
!FORMAT(F11.4,F7.3,F6.2,F12.3,F5.2,1X,A10,F12.3,F5.2,1X,A10,
!3F6.2,A4,2I2,I3,F6.3,I3,F6.3,2I5,1X,A1,A1,1X,A1,A1,i1,A3.2I5,I6)
! 1 wavelength (nm)  air above 200 nm   F11.4
! 2 log gf  F7.3
! 3 element code = element number + charge/100.  F6.2
! 4 first energy level in cm-1	F12.3
! 5 J for first level	F5.1
!   blank for legibility	1X
! 6 label field for first level   A10
! 7 second energy level in cm-1   F12.3
!		  (negative energies are predicted or extrapolated}
! 8 J for second level   F5.1
!   blank for legibility	1X
! 9 label field for second level   A10
!10 log of radiative damping constant, Gamma Rad  F6.2 or F6.3
!11 log of stark damping constant/electron number. Gamma Stark  F6.2 or F6.3
!12 log of van der Waals damping constant/neutral hydrogen number,
!  	  Gamma van der Waals	F6.2 or F6.3
!13 reference that can be expanded in subdirectory LINES   A4
!14 non-LTE level index for first level	I2
!15 non-LTE level index for second level   I2
!16 isotope number	I3
!17 hyperfine component log fractional strength  F6.3
!18 isotope number  (for diatomics there are two and no hyperfine)	I3
!19 log isotopic abundance fraction   F6.3
!20 hyperfine shift for first level in mK to be added to E  I5
!21 hyperfine shift for second level in mK to be added to E'  I5
!   the symbol "F" for legibilty   1X
!22 hyperfine F for the first level 	I1
!23 note on character of hyperfine data for first level: z none, ? guessed  A1
!   the symbol "-" for legibility	 1X
!24 hyperfine F' for the second level  I1
!25 note on character of hyperfine data for second level: z none, ? guessed  A1
!26 1-digit code, sometimes for line strength classes   I1
!27 3-character code such as AUT for autoionizing    A3
!28 lande g for first level times 1000   I5
!29 lande g for second level times 1000	I5
!30 isotope shift of wavelength in mA
! WARNING!!!
!  In this linelist, the first level is not always the level with the lowest energy
!  Therefore, we have to be sure that we take the excitation potential of the lower level
!  and that the Lande factors and J of the levels are associated correctly
!  I SHOULD CHANGE THE NAMES OF THE VARIABLES TO _first and _second instead of _up and _low
!-----------------------------------------------------------------
	subroutine read_lines(atm, spectrum)
	type(atmosphere_type) :: atm
	type(spectrum_type) :: spectrum
	real(kind=8) :: wlength, lgf, elem, ioniz, isot_ab
	real(kind=8) :: j_low, e_low, e_up, j_up, gamma_rad, gamm_stark, vdw_damp, hyperf_str, dnumax
	character(len=10) :: label_low, label_up
	character(len=4) :: reference
	character(len=1) :: hpflow_c, hpfup_c
	character(len=3) :: autoion
	integer :: nonlte_up, nonlte_low, isot, isot2, hpf_low, hpf_up, hpff_low, hpff_up, line_str
	integer :: i, j, lande_up, lande_low, isot_shift, lower_level
	integer :: index_from, index_to, index_from_old, index_to_old, indexx, el_dip, from_to(2)
	logical :: found_from, found_to, incluir

! Read the index to recognize the place to jump from the whole list
		open(unit=10,file=trim(adjustl(conf%linelist_file))//'.index',status='old',action='read')
		found_from = .false.
		found_to = .false.
		indexx = 0

		do while(.not.found_from .or. .not.found_to)
			if (.not.found_from) index_from = indexx
			if (.not.found_to) index_to = indexx
			read(10,*) wlength, indexx
			if (wlength >= spectrum%ini_lambda .and. .not.found_from) then
				found_from = .true.
			endif
			if (wlength >= spectrum%end_lambda .and. .not.found_to) then
				found_to = .true.
				index_to = indexx
			endif
		enddo
		close(10)

		open(unit=10,file=trim(adjustl(conf%linelist_file)),status='old',action='read')

! Jump to the place indicated by the index
		do i = 1, index_from
			read(10,*)
		enddo

		j = 0
		do i = 1, index_to-index_from
			read(10,FMT='(F11.4,F7.3,F6.2,F12.3,F6.1,1X,A10,F12.3,F6.1,1X,A10,3F6.2,A4,2I2,I3,F6.3,I3,&
				&F6.3,2I5,1X,A1,A1,1X,A1,A1,i1,A3,2I5,I6)') wlength, lgf, elem, e_low, j_low, label_low,&
				e_up, j_up, label_up, gamma_rad, gamm_stark, vdw_damp, reference, nonlte_up,&
				nonlte_low, isot, hyperf_str, isot2, isot_ab, hpf_low, hpf_up, hpff_low,&
				hpflow_c, hpff_up, hpfup_c, line_str, autoion, lande_up, lande_low, isot_shift
			wlength = wlength * 10.d0

! Test for molecules
! Molecules are indicated with an element < 1
! 0.01 for CO
! 0.02 for OH
! 0.03 for CN
! 0.04 for TiO
			if (elem < 1) then
				ioniz = 1
			else
				ioniz = floor((elem - int(elem)) * 100.d0+0.01d0)
			endif

! Take into account 1 A above the limits to include lines outside the region
! we want to synthesize
			incluir = .FALSE.
			if (wlength < spectrum%end_lambda+1 .and. wlength > spectrum%ini_lambda-1 .and. ioniz <= 1) then
				incluir = .TRUE.
			endif

			if (incluir) then
				j = j + 1
			endif
		enddo

 		spectrum%nlines = j

 		rewind(10)

! Jump to the place indicated by the index
		do i = 1, index_from
			read(10,*)
		enddo

		allocate(spectrum%line(spectrum%nlines))

		j = 0
		el_dip = 0
		do i = 1, index_to-index_from !564949-index_from
			read(10,FMT='(F11.4,F7.3,F6.2,F12.3,F6.1,1X,A10,F12.3,F6.1,1X,A10,3F6.2,A4,2I2,I3,F6.3,I3,&
				&F6.3,2I5,1X,A1,A1,1X,A1,A1,i1,A3,2I5,I6)') wlength, lgf, elem, e_low, j_low, label_low,&
				e_up, j_up, label_up, gamma_rad, gamm_stark, vdw_damp, reference, nonlte_up,&
				nonlte_low, isot, hyperf_str, isot2, isot_ab, hpf_low, hpf_up, hpff_low,&
				hpflow_c, hpff_up, hpfup_c, line_str, autoion, lande_low, lande_up, isot_shift

! This trick solves some problems with the rounding
! Test for molecules
			if (elem < 1) then
				ioniz = 1
			else
				ioniz = floor((elem - int(elem)) * 100.d0+0.01d0)
			endif

			wlength = wlength * 10.d0

			incluir = .FALSE.

			if (wlength < spectrum%end_lambda+1 .and. wlength > spectrum%ini_lambda-1 .and. ioniz <= 1) then
				incluir = .TRUE.
			endif

			if (incluir) then
				j = j + 1
				lower_level = 1
				if (e_up < e_low) lower_level = 2
				spectrum%line(j)%wlength = wlength
				spectrum%line(j)%freq = PC / (wlength * 1.d-8)
				spectrum%line(j)%gf = 10.d0**lgf

				if (lower_level == 1) then    ! The lower level is the first one
					spectrum%line(j)%expot = dabs(e_low) * PH * PC
					spectrum%line(j)%lande_up = lande_up / 1000.d0
					spectrum%line(j)%lande_low = lande_low / 1000.d0
					spectrum%line(j)%J_up = j_up
					spectrum%line(j)%J_low = j_low
				else  								! The lower level is the second one
					spectrum%line(j)%expot = dabs(e_up) * PH * PC
					spectrum%line(j)%lande_up = lande_low / 1000.d0
					spectrum%line(j)%lande_low = lande_up / 1000.d0
					spectrum%line(j)%J_up = j_low
					spectrum%line(j)%J_low = j_up
				endif

! Molecules are elements above 100
! CO is 101
! OH is 102
! CN is 103
! TiO is 104
				if (elem < 1) then
					spectrum%line(j)%element = int(100*elem)+100
! CO
					if (abs(elem-0.01) < 1.d-4) then
						spectrum%line(j)%mass = atm%mass(6)+atm%mass(8)   ! CO
						spectrum%line(j)%molecule = 1
					endif

! OH
					if (abs(elem-0.02) < 1.d-4) then
						spectrum%line(j)%mass = atm%mass(6)+atm%mass(1)   ! OH
						spectrum%line(j)%molecule = 2
					endif

! CN
					if (abs(elem-0.03) < 1.d-4) then
						spectrum%line(j)%mass = atm%mass(6)+atm%mass(1)   ! CN
						spectrum%line(j)%molecule = 3
					endif

! TiO
					if (abs(elem-0.04) < 1.d-4) then
						spectrum%line(j)%mass = atm%mass(46)+atm%mass(8)   ! TiO
						spectrum%line(j)%molecule = 4
					endif

					spectrum%line(j)%atomic_molecular = 2
				else
					spectrum%line(j)%element = int(elem)
					spectrum%line(j)%mass = atm%mass(int(elem))
					spectrum%line(j)%atomic_molecular = 1

				endif

				spectrum%line(j)%ionization = ioniz

! Put these values in case we will use them
				spectrum%line(j)%gamma_rad = 10.d0**gamma_rad
				spectrum%line(j)%gamma_stark = 10.d0**gamm_stark
				spectrum%line(j)%gamma_vdw = 10.d0**vdw_damp

				spectrum%line(j)%enhacement_vdw = 1.d0

! Find the limits of the atomic line
				dnumax = maxval(spectrum%line(j)%freq * dsqrt(atm%microturb**2.d0 + 2.d0 * PK * atm%T / (spectrum%line(j)%mass * UMA)) / PC)

				from_to = extremes(spectrum%freq, spectrum%line(j)%freq, 10.d0*dnumax)

				spectrum%line(j)%lambda_from = from_to(1)
				spectrum%line(j)%lambda_to = from_to(2)

! Compute the Zeeman components if a magnetic synthesis is done
				if (index(atm%magnetic, 'NONMAGNETIC') == 0) then
					call generate_atomic_zeeman_components(spectrum%line(j))
				endif

			endif
		enddo

		close(10)

	end subroutine read_lines

!-----------------------------------------------------------------
! Return the profiles weighted by the strength of the components for a given frequency
! It returns zeeman_profile(q,n_depths) with
!  q=1  Mlow=Mup-1  (sigma blue)
!  q=2  Mlow=Mup    (sigma pi)
!  q=3  Mlow=Mup+1  (sigma red)
!-----------------------------------------------------------------
	subroutine zeeman_profile(damping,freq,at,vmacros,B_field,dnu,zeeman_voigt,zeeman_faraday)
	real(kind=8) :: freq
	type(atomic_transition_type) :: at
	real(kind=8) :: damping(:), vmacros(:), dnu(:), B_field(:)
	real(kind=8) :: zeeman_voigt(3,size(damping)), zeeman_faraday(3,size(damping))
	integer :: n, nlow, nup, iup, ilow, i_pi, i_blue, i_red, cual
	real(kind=8) :: Mup, Mlow, strength
	real(kind=8), allocatable :: splitting(:), profile(:,:)

		n = size(damping)

		allocate(splitting(n))
		allocate(profile(2,n))

		nup = 2*at%J_up+1
		nlow = 2*at%J_low+1

		zeeman_voigt = 0.d0
		zeeman_faraday = 0.d0

		i_red = 0
		i_pi = 0
		i_blue = 0

		do iup = 1, nup
			Mup = at%J_up + 1 - iup  ! Mup=J...-J
			do ilow = 1, 3
				Mlow = Mup-2+ilow			! Mlow=Mup-1,Mup,Mup+1 (the allowed transitions)
				if (abs(Mlow) <= at%J_low) then

					if (ilow == 1) then
						i_blue = i_blue + 1
						cual = i_blue
					endif
					if (ilow == 2) then
						i_pi = i_pi + 1
						cual = i_pi
					endif
					if (ilow == 3) then
						i_red = i_red + 1
						cual = i_red
					endif

					strength = at%strength(ilow,cual)

					splitting = LARMOR * B_field * at%splitting(ilow,cual)

					profile = vecfvoigt_zeeman(damping,(at%freq - freq - at%freq*vmacros / PC + splitting ) / dnu)

					zeeman_voigt(ilow,:) = zeeman_voigt(ilow,:) + strength * profile(1,:)
					zeeman_faraday(ilow,:) = zeeman_faraday(ilow,:) + strength * profile(2,:)
				endif
			enddo
		enddo

		deallocate(splitting)
		deallocate(profile)

	end subroutine zeeman_profile

!-----------------------------------------------------------------
! Return the seven independent elements of the absorption matrix
! Remember that, zeeman_voigt(q,:) and zeeman_faraday(q,:) have
!  q=1  Mlow=Mup-1  (sigma blue)
!  q=2  Mlow=Mup    (sigma pi)
!  q=3  Mlow=Mup+1  (sigma red)
!-----------------------------------------------------------------
	subroutine zeeman_opacity(zeeman_voigt,zeeman_faraday,atmos,coefficients)
	real(kind=8) :: zeeman_voigt(:,:), zeeman_faraday(:,:), coefficients(:,:)
	type(atmosphere_type) :: atmos

! Classical absorption coefficients
		coefficients(1,:) = 0.5d0 * (zeeman_voigt(2,:)*atmos%sin_gamma**2 + &
			0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))*(1.d0+atmos%cos_gamma**2))  ! eta_I
		coefficients(2,:) = 0.5d0 * (zeeman_voigt(2,:) - &
			0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))) * atmos%sin_gamma**2*atmos%cos_2chi  ! eta_Q
		coefficients(3,:) = 0.5d0 * (zeeman_voigt(2,:) - &
			0.5d0*(zeeman_voigt(1,:)+zeeman_voigt(3,:))) * atmos%sin_gamma**2*atmos%sin_2chi  ! eta_U
		coefficients(4,:) = 0.5d0 * (zeeman_voigt(3,:)-zeeman_voigt(1,:)) * atmos%cos_gamma  ! eta_V

! Magneto-optical coefficients
		coefficients(5,:) = 0.5d0 * (zeeman_faraday(2,:) - &
			0.5d0*(zeeman_faraday(1,:)+zeeman_faraday(3,:))) * atmos%sin_gamma**2*atmos%cos_2chi  ! rho_Q
		coefficients(6,:) = 0.5d0 * (zeeman_faraday(2,:) - &
			0.5d0*(zeeman_faraday(1,:)+zeeman_faraday(3,:))) * atmos%sin_gamma**2*atmos%sin_2chi  ! rho_U
		coefficients(7,:) = 0.5d0 * (zeeman_faraday(3,:)-zeeman_faraday(1,:)) * atmos%cos_gamma  ! rho_V

	end subroutine zeeman_opacity

!-----------------------------------------------------------------
! Estimate the integration ranges of each line
!-----------------------------------------------------------------
	function estimate_range_line(lambda, dnu, damping, at_opacity, height)
	real(kind=8) :: lambda, dnu(:), damping(:), at_opacity(:), height(:), doppler_widths, estimate_range_line, tau, chiO, chiM
	logical :: done
	integer :: loop, n, i

		n = size(height)

! Go over a set of widhts and test whether the total opacity of the line is small enough
! so that we have arrived at the continuum
		doppler_widths = 1.d0
		done = .FALSE.
		do while (.not. done)
			tau = 0.d0

			chiM = at_opacity(1) * fvoigt(damping(1), doppler_widths) / (dnu(1) * SQRTPI)

			do i = 2, n
				chiO = at_opacity(i) * fvoigt(damping(i), doppler_widths) / (dnu(i) * SQRTPI)

				tau = tau + abs(height(i)-height(i-1)) * 0.5d0 * (chiO + chiM)

				chiM = chiO
			enddo

! 			print *, lambda, doppler_widths, tau, maxval(dnu)

			if (tau < 1.d-1) then
				done = .TRUE.
			endif

			doppler_widths = doppler_widths + 1.d0
		enddo

		estimate_range_line = doppler_widths

	end function estimate_range_line

!-----------------------------------------------------------------
! Add line opacity to the total opacity
!-----------------------------------------------------------------
	subroutine add_line_opacity(atm, spectrum, mu)
	type(config_type) :: conf
	type(atmosphere_type) :: atm
	type(spectrum_type) :: spectrum
	real(kind=8) :: mu, dnumax

	real(kind=8), allocatable :: u1(:), u2(:), u3(:), n1overn0(:), n2overn1(:), niovern(:), at_opacity(:)
	real(kind=8), allocatable :: dnu(:), doppler_atomic(:), perfil(:), ui(:), damping(:)
	integer, allocatable :: from_to(:,:)
	real(kind=8), allocatable :: zeeman_voigt(:,:), zeeman_faraday(:,:), coefficients(:,:)
	integer :: i, j, k, from_to_line(2)

		allocate(u1(atm%n_depths))
		allocate(u2(atm%n_depths))
		allocate(u3(atm%n_depths))
		allocate(ui(atm%n_depths))
		allocate(n1overn0(atm%n_depths))
		allocate(n2overn1(atm%n_depths))
		allocate(niovern(atm%n_depths))
		allocate(at_opacity(atm%n_depths))
		allocate(damping(atm%n_depths))
		allocate(dnu(atm%n_depths))
		allocate(doppler_atomic(atm%n_depths))
		allocate(perfil(atm%n_depths))

! If magnetic, allocate memory for the Voigt and Faraday profiles
		if (index(atm%magnetic, 'NONMAGNETIC') == 0) then
			allocate(zeeman_voigt(3,atm%n_depths))
			allocate(zeeman_faraday(3,atm%n_depths))
			allocate(coefficients(7,atm%n_depths))
			zeeman_voigt = 0.d0
			zeeman_faraday = 0.d0

! Additionally, compute the angles between the magnetic field and the LOS
! for the inclination angle of the LOS and the angles of B wrt to the local vertical
			atm%cos_gamma = (1.d0-mu**2) * sin(atm%thetaB) * cos(atm%chiB) + mu * cos(atm%thetaB)
			atm%sin_gamma = sqrt(1.d0 - atm%cos_gamma**2)
			atm%cos_2chi = cos(2.d0*atm%chiB)
			atm%sin_2chi = sin(2.d0*atm%chiB)
		endif

! Calculate the line opacity
		do i = 1, spectrum%nlines

! Compute line integrated opacity
! If atomic line
			if (spectrum%line(i)%atomic_molecular == 1) then
				u1 = atm%partition_functions(:, spectrum%line(i)%element, 1)
				u2 = atm%partition_functions(:, spectrum%line(i)%element, 2)
				u3 = atm%partition_functions(:, spectrum%line(i)%element, 3)

				n1overn0 = saha(atm%T, PK * atm%ne * atm%T, u1, u2, atm%ionization_pot(1,spectrum%line(i)%element))
				n2overn1 = saha(atm%T, PK * atm%ne * atm%T, u2, u3, atm%ionization_pot(2,spectrum%line(i)%element))

				if (spectrum%line(i)%ionization == 0) then
					niovern = 1.d0 / (1.d0 + n1overn0 + n2overn1 * n1overn0)
					ui = u1
				else if (spectrum%line(i)%ionization == 1) then
					niovern = 1.d0 / (1.d0 + 1.d0/n1overn0 + n2overn1)
					ui = u2
				else
					print *, 'Unknown ionization stage...'
					niovern = 0.d0
				endif

! Compute the line center opacity
				at_opacity = OPA * spectrum%line(i)%gf / ui * dexp(-spectrum%line(i)%expot / (PK * atm%T)) *&
									(1.d0 - dexp(-PHK * spectrum%line(i)%freq / atm%T)) * niovern * &
									(atm%nhtot * atm%abundances(spectrum%line(i)%element))

! Doppler width in velocity and frequency units
				doppler_atomic = dsqrt(atm%microturb**2.d0 + 2.d0 * PK * atm%T / (spectrum%line(i)%mass * UMA))
				dnu = spectrum%line(i)%freq * doppler_atomic / PC

! Compute damping
				call calculate_damping(atm%T, atm%nHtot, atm%Pe, atm%P_total, doppler_atomic, &
					atm%ionization_pot(spectrum%line(i)%ionization+1,spectrum%line(i)%element), spectrum%line(i)%expot/EV_ERG, &
					spectrum%line(i)%gamma_rad, spectrum%line(i)%gamma_stark, spectrum%line(i)%gamma_vdw, spectrum%line(i)%wlength, damping)

! Try to estimate the range of wavelengths in which the line has opacity contribution
				dnumax = estimate_range_line(spectrum%line(i)%wlength, dnu, damping, at_opacity, atm%height) * maxval(dnu)

! If the line is estimated to be very broad, take into account that the result
! might be truncated if the incorrect chunks are used
				from_to_line = extremes(spectrum%freq, spectrum%line(i)%freq, dnumax)

				spectrum%line(i)%lambda_from = from_to_line(1)
				spectrum%line(i)%lambda_to = from_to_line(2)

			else

! If molecular line
				at_opacity = OPA * spectrum%line(i)%gf / atm%partition_functions_molecular(:,spectrum%line(i)%molecule) * &
									dexp(-spectrum%line(i)%expot / (PK * atm%T)) *&
									(1.d0 - dexp(-PHK * spectrum%line(i)%freq / atm%T)) * &
									atm%mol_density(spectrum%line(i)%molecule,:)

				doppler_atomic = dsqrt(atm%microturb**2.d0 + 2.d0 * PK * atm%T / (spectrum%line(i)%mass * UMA))
				dnu = spectrum%line(i)%freq * doppler_atomic / PC

				damping = 0.d0

			endif

! Compute opacity
			if (index(atm%magnetic, 'NONMAGNETIC') /= 0) then

! Non-magnetic
				do k = spectrum%line(i)%lambda_from, spectrum%line(i)%lambda_to
					perfil = vecfvoigt(damping,(spectrum%line(i)%freq - spectrum%freq(k) - spectrum%line(i)%freq * atm%vmacro / PC) / dnu)
					spectrum%chi(1,:,k) = spectrum%chi(1,:,k) + at_opacity * perfil / (dnu * SQRTPI)
				enddo

			else

! Magnetic
! Do not do the full calculation for a non-magnetic line
				if (spectrum%line(i)%lande_up == 0.d0 .and. spectrum%line(i)%lande_low == 0.d0) then
					do k = spectrum%line(i)%lambda_from, spectrum%line(i)%lambda_to
						perfil = vecfvoigt(damping,(spectrum%line(i)%freq - spectrum%freq(k) - spectrum%line(i)%freq * atm%vmacro / PC) / dnu)
						spectrum%chi(1,:,k) = spectrum%chi(1,:,k) + at_opacity * perfil / (dnu * SQRTPI)
					enddo
				else
					do k = spectrum%line(i)%lambda_from, spectrum%line(i)%lambda_to
						call zeeman_profile(damping, spectrum%freq(k), spectrum%line(i), atm%vmacro, atm%B, dnu, zeeman_voigt, zeeman_faraday)
						call zeeman_opacity(zeeman_voigt, zeeman_faraday, atm, coefficients)

						do j = 1, 7
							spectrum%chi(j,:,k) = spectrum%chi(j,:,k) + at_opacity * coefficients(j,:) / (dnu * SQRTPI)
						enddo

					enddo
				endif

			endif

		enddo

		deallocate(u1)
		deallocate(u2)
		deallocate(u3)
		deallocate(ui)
		deallocate(n1overn0)
		deallocate(n2overn1)
		deallocate(niovern)
		deallocate(at_opacity)
		deallocate(dnu)
		deallocate(doppler_atomic)
		deallocate(perfil)
		deallocate(damping)

		if (index(atm%magnetic, 'NONMAGNETIC') == 0) then
			deallocate(zeeman_voigt)
			deallocate(zeeman_faraday)
			deallocate(coefficients)
		endif

	end subroutine add_line_opacity

!-----------------------------------------------------------------
! Add line opacity to the total opacity
!-----------------------------------------------------------------
	subroutine add_background_opacity(atm, spectrum)
	integer :: i, j
	type(atmosphere_type) :: atm
	type(spectrum_type) :: spectrum

		spectrum%chi = 0.d0

		do i = 1, atm%n_depths
			do j = 1, spectrum%nlambda
				spectrum%chi(1,i,j) = background_opacity(atm%T(i), atm%Pe(i), atm%PH(i), atm%PHminus(i), &
					atm%PHplus(i), atm%PH2(i), atm%PH2plus(i), PC / spectrum%freq(j)*1.d8)
			enddo
		enddo

	end subroutine add_background_opacity

!-----------------------------------------------------------------
! Add line opacity to the total opacity
!-----------------------------------------------------------------
	subroutine solve_RT(atm, spectrum, mu, weight)
	integer :: i
	type(atmosphere_type) :: atm
	type(spectrum_type) :: spectrum
	real(kind=8) :: mu, weight

		spectrum%boundary = 0.d0

! Source function and boundary condition
		do i = 1, spectrum%nlambda
			spectrum%source(:,i) = planck_vect_lambda(PC/spectrum%freq(i),atm%T)
			spectrum%boundary(1,i) = planck_lambda(PC / spectrum%freq(i), atm%T(atm%n_depths))
		enddo

		if (index(atm%magnetic, 'NONMAGNETIC') /= 0) then
! Non-magnetic
			spectrum%flux(1,:) = spectrum%flux(1,:) + &
				weight * formal_sol_vect(atm%height, spectrum%chi(1,:,:), spectrum%source(:,:), mu, spectrum%boundary(1,:), atm%direction)

		else
! Magnetic
			do i = 1, spectrum%nlambda
				spectrum%flux(:,i) = spectrum%flux(:,i) + &
					weight * formal_sol_polarized(atm%height, spectrum%chi(:,:,i), spectrum%source(:,i), mu, spectrum%boundary(:,i), atm%direction)
			enddo

		endif

	end subroutine solve_RT

!-----------------------------------------------------------------
! Generate wavelength axis
!-----------------------------------------------------------------
	subroutine setup_spectrum(conf, atm, spectrum)
	type(atmosphere_type) :: atm
	type(spectrum_type) :: spectrum
	type(config_type) :: conf
	integer :: i

		spectrum%nlambda = (spectrum%end_lambda - spectrum%ini_lambda) / conf%step_lambda
		allocate(spectrum%source(atm%n_depths, spectrum%nlambda))

		allocate(spectrum%freq(spectrum%nlambda))

		if (index(atm%magnetic, 'NONMAGNETIC') /= 0) then
! Non-magnetic
			allocate(spectrum%flux(1,spectrum%nlambda))
			allocate(spectrum%chi(1,atm%n_depths, spectrum%nlambda))
			allocate(spectrum%boundary(1,spectrum%nlambda))

		else
! Magnetic
			allocate(spectrum%flux(4,spectrum%nlambda))
			allocate(spectrum%chi(7,atm%n_depths, spectrum%nlambda))
			allocate(spectrum%boundary(4,spectrum%nlambda))

		endif

! Generate the frequency axis
 		do i = 1, spectrum%nlambda
 			spectrum%freq(i) = PC / (1.d-8 * (spectrum%ini_lambda + (i-1.d0) * conf%step_lambda))
 		enddo

 	end subroutine setup_spectrum

end module atomic_mod


      subroutine runY_00(k,l,Xtwiddle,Gtwiddle,Shat2,N0)
      implicit none
C---  Expression for Eq. 5.54
C---  Calculates D00
C---  Small terms of order Xtwiddle(0,k)*Di,Xtwiddle(0,0)*Dii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat2(np,z1max,-2:0)

      do ep=-2,0

      Dv(dd00+N0,ep)=
     .  (Gtwiddle(k,1)*Shat2(1,l,ep)
     .  +Gtwiddle(k,2)*Shat2(2,l,ep)
     .  +Gtwiddle(k,3)*Shat2(3,l,ep)
     .  +Xtwiddle(0,k)*Dv(di(l)+N0,ep)
     .  -Xtwiddle(0,0)*Dv(dii(z2(k,l))+N0,ep))/(2*Gtwiddle(k,l))

c      write(6,*) 'runY_00:Dv(dd00+N0,ep)',Dv(dd00+N0,ep)

      enddo

      return
      end


subroutine dergl(g_l,der1,rnot,dx,mesh,nrad)
  !
  !     Calculate the first derivate of f_l.
  !
  !USE param
  IMPLICIT NONE
  real*8, intent(out) :: der1(nrad)
  real*8, intent(in)  :: g_l(nrad)
  real*8, intent(in)  :: dx,rnot
  integer, intent(in) :: mesh, nrad
  ! locals
  real*8  :: r(nrad), f_l(nrad), dfldi(mesh)

  integer :: j,i
  real*8  :: rad

  do i=1,mesh
     r(i) = rnot*exp(dx*(i-1))
     f_l(i) = g_l(i)/r(i)
  enddo
  !  Use unsymmetric 6-point formulae for the first derivative at the
  !  first 3 mesh points.
  dfldi(1) =  ( - 137.D0*f_l(1) + 300.D0*f_l(2) - 300.D0*f_l(3) + 200.D0*f_l(4) -  75.D0*f_l(5) +  12.D0*f_l(6) ) / 60.D0
  dfldi(2) = ( -  12.D0*f_l(1) -  65.D0*f_l(2) + 120.D0*f_l(3) -  60.D0*f_l(4) +  20.D0*f_l(5) -   3.D0*f_l(6) ) / 60.D0
  dfldi(3) = (     3.D0*f_l(1) -  30.D0*f_l(2) -  20.D0*f_l(3) +  60.D0*f_l(4) -  15.D0*f_l(5) +   2.D0*f_l(6) ) / 60.D0
  RAD=R(1)
  DER1(1)=dfldi(1)/RAD/DX
  RAD=R(2)
  DER1(2)=dfldi(2)/RAD/DX
  RAD=R(3)
  DER1(3)=dfldi(3)/RAD/DX
  !  Use symmetric 7-point formula to generate the first derivative at
  !  all intermediate mesh points.
  DO J=4,MESH-3
     dfldi(J) = (        f_l(J+3) - f_l(J-3) -  9.D0 * (f_l(J+2) - f_l(J-2)) + 45.D0 * (f_l(J+1) - f_l(J-1)) ) / 60.D0
     RAD=R(J)
     DER1(J)=dfldi(J)/RAD/DX
  ENDDO
  !  Use unsymmetric 6-point formulae for the second derivative at the
  !  last 3 mesh points.
  dfldi(MESH-2) = - (    3.D0*f_l(MESH  ) -  30.D0*f_l(MESH-1) -  20.D0*f_l(MESH-2) +  60.D0*f_l(MESH-3) -  15.D0*f_l(MESH-4) +   2.D0*f_l(MESH-5) ) / 60.D0
  RAD=R(MESH-2)
  DER1(MESH-2)=dfldi(MESH-2)/RAD/DX

  dfldi(MESH-1) = - (-  12.D0*f_l(MESH  ) -  65.D0*f_l(MESH-1) + 120.D0*f_l(MESH-2) -  60.D0*f_l(MESH-3) +  20.D0*f_l(MESH-4) -   3.D0*f_l(MESH-5) ) / 60.D0
  RAD=R(MESH-1)
  DER1(MESH-1)=dfldi(MESH-1)/RAD/DX

  dfldi(MESH  ) = - (- 137.D0*f_l(MESH  ) + 300.D0*f_l(MESH-1) - 300.D0*f_l(MESH-2) + 200.D0*f_l(MESH-3) -  75.D0*f_l(MESH-4) +  12.D0*f_l(MESH-5) ) / 60.D0

  RAD=R(MESH)
  DER1(MESH)=dfldi(MESH)/RAD/DX

  return
end subroutine dergl


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44
C  THIS IS A TEST PROGRAM FOR SUBROUTINE ITER.
C  ITER PROVIDES ITERATIVE CONVERGENCE FOR OBLATE
C  PLANETS FOR SUBROUTINE TRANV.   IN THE TEST PROGRAM
C  PROGRAM THE RADIAL ECCENTRICITY (EPS) VARIES FROM
C  .1D0 TO .9DO.

	DOUBLE PRECISION PI, CHI, PHI, EPS
	PI = 3.141592653589D0
	CHI = PI/4.D0
        EPS = .1D0
	DO 10 I = 1,9
	   CALL PRNT(8,1,EPS,'ECCENTRICITY = .')
           CALL ITER(CHI,PHI,EPS,PI)
	   CALL PRNT(8,1,PHI,'         PHI = .')
	   CALL XVMESSAGE(' ',' ')
           EPS = EPS + .1D0
 10	CONTINUE
	RETURN
	END


C++***************************************************************
C Program to compute some statistical parameters
C of an image, to be used as scaling values for further display
C
C JLP
C Version of 04-08-2008
C--***************************************************************
        PROGRAM AUTO_SCALE
        IMPLICIT NONE
C For 32-bit computers, PNTR should be declared as integer*4:
C        INTEGER*4 PNTR_RE,PNTR_IM
C For 64-bit computers, PNTR should be declared as integer*8:
        INTEGER*8 PNTR_IMAGE,PNTR_WORK
        INTEGER*4 MADRID(1)
        REAL*4 MEAN1,SIGMA1,MEAN2,SIGMA2,MIN1,MAX1
        REAL*4 SKY,SUM,R,SIGMA
        INTEGER*4 IXMI,IYMI,IXMA,IYMA,ISIZE,NX,NY
        INTEGER*4 IX1,IX2,IY1,IY2,NX2,NY2
        LOGICAL LIMITS
        CHARACTER NAME*40,COMMENTS*80,BUFFER*80
        COMMON /VMR/MADRID

C To be able to use parameters in command line
        CALL JLP_BEGIN

C Inquire the format (input/output) :
        CALL JLP_INQUIFMT

C Input :
        WRITE(6,*) 'Input file: '
        READ(5,10) NAME
        WRITE(6,*) 'OK, input file: >',NAME,'<'
        NX=0
        CALL JLP_VM_READIMAG(PNTR_IMAGE,NX,NY,NAME,COMMENTS)
        IF(NX.EQ.0) THEN
          CALL JLP_END
          STOP
        ENDIF

C debug:
C        CALL DD(MADRID(PNTR_IMAGE))

C Check if limits:
        LIMITS=.FALSE.
        WRITE(6,60)
60      FORMAT(' Enter limits: IX1,IX2,IY1,IY2 (return if all image)')
        READ(5,10,ERR=98,END=98) BUFFER
10        FORMAT(A)
        READ(BUFFER,*,ERR=98,END=98) IX1,IX2,IY1,IY2
        IF((IX1.LT.0.OR.IX1.GT.NX.OR.IY1.LT.0.OR.IY1.GT.NY).OR.
     1     (IX2.LT.0.OR.IX2.GT.NX.OR.IY2.LT.0.OR.IY2.GT.NY))THEN
          WRITE(6,*)' AUTO_SCALE/Fatal error, wrong limits:',
     1               IX1,IX2,IY1,IY2
          CALL JLP_END
          STOP
        ENDIF
        LIMITS=.TRUE.
C
98      IF(LIMITS)THEN
          NX2=IX2-IX1+1
          NY2=IY2-IY1+1
          ISIZE=NX2*NY2*4
          CALL JLP_GETVM(PNTR_WORK,ISIZE)
          CALL TRANSFER(MADRID(PNTR_IMAGE),MADRID(PNTR_WORK),
     1      NX,NY,IX1,IY1,NX2,NY2)
          NX=NX2
          NY=NY2
        ELSE
          IX1=1
          IY1=1
          PNTR_WORK=PNTR_IMAGE
        ENDIF

C debug:
C        CALL DD(MADRID(PNTR_IMAGE))
C Statistics:
          CALL JLP_AUTO_SCALE(MADRID(PNTR_WORK),NX,NY,NX,MIN1,MAX1,
     1        MEAN1,MEAN2,SIGMA1,SIGMA2,IXMI,IYMI,IXMA,IYMA)

C Compute actual coordinates of maximum and minimum:
        IXMI=IXMI+IX1-1
        IXMA=IXMA+IX1-1
        IYMI=IYMI+IY1-1
        IYMA=IYMA+IY1-1

C Output:
        WRITE(6,87) MIN1,IXMI,IYMI,MAX1,IXMA,IYMA,MEAN1,
     1        SIGMA1,MEAN2,SIGMA2
87        FORMAT(' Minimum : ',1PG13.5,' at (ix,iy): ',I6,1X,I6,/,
     1        ' Maximum : ',1PG13.5,' at (ix,iy): ',I6,1X,I6,/,
     1        ' Mean and sigma with all points: ',1PG13.5,1X,1PG13.5,/,
     1        ' Mean and sigma with 3 sigma rejection: ',1PG13.5,
     1        1X,1PG13.5)

C Output:
        SUM=FLOAT(NX*NY)*MEAN1
        ISIZE=NX*NY
        WRITE(6,89) SUM,ISIZE
89        FORMAT(' Total sum: ',1PG13.5,'   Total number of points: ',I8)

C Background determination:
        IF(.NOT.LIMITS)THEN
          CALL AUTO_SKY(MADRID(PNTR_IMAGE),NX,NY,NX,SKY,SIGMA)
        ENDIF

        CALL JLP_END
        STOP
        END
C*************************************************************************
        SUBROUTINE  DD(ARRAY)
        REAL ARRAY(1)
         PRINT *,'DD/ DEBUG'
         PRINT *,'DD/ DEBUG: array(1)=',array(1)
        RETURN
        END
C*************************************************************************
        SUBROUTINE TRANSFER(FROM,TTOO,NX,NY,IX1,IY1,NX2,NY2)
        INTEGER*4 NX,NY,IX1,IY1,NX1,NX2
        REAL*4 FROM(NX,NY),TTOO(NX2,NY2)
C
        DO J=1,NY2
          JJ=IY1+J-1
          DO I=1,NX2
            II=IX1+I-1
            TTOO(I,J)=FROM(II,JJ)
          END DO
        END DO

        RETURN
        END
C*************************************************************************
        include 'jlpsub:jlp_auto_scale.for'
        include 'jlpsub:auto_sky.for'


module assert
! Gfortran >= 6 needed for ieee_arithmetic: ieee_is_nan

  use, intrinsic:: iso_c_binding, only: sp=>c_float, dp=>c_double
  use, intrinsic:: iso_fortran_env, only: stderr=>error_unit
  use, intrinsic:: ieee_arithmetic, only: ieee_is_finite, ieee_is_nan
  use error, only: errorstop
  implicit none
  private

  integer,parameter :: wp = sp

  public :: wp,isclose, assert_isclose, errorstop

contains

elemental logical function isclose(actual, desired, rtol, atol, equal_nan)
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
!
!  rtol overrides atol when both are specified
!
! https://www.python.org/dev/peps/pep-0485/#proposed-implementation
! https://github.com/PythonCHB/close_pep/blob/master/is_close.py

  real(wp), intent(in) :: actual, desired
  real(wp), intent(in), optional :: rtol, atol
  logical, intent(in), optional :: equal_nan

  real(wp) :: r,a
  logical :: n
  ! this is appropriate INSTEAD OF merge(), since non present values aren't defined.
  r = 1e-5_wp
  a = 0._wp
  n = .false.
  if (present(rtol)) r = rtol
  if (present(atol)) a = atol
  if (present(equal_nan)) n = equal_nan

  !print*,r,a,n,actual,desired

!--- sanity check
  if ((r < 0._wp).or.(a < 0._wp)) call errorstop
!--- simplest case -- too unlikely, especially for arrays?
  !isclose = (actual == desired)
  !if (isclose) return
!--- equal nan
  isclose = n.and.(ieee_is_nan(actual).and.ieee_is_nan(desired))
  if (isclose) return
!--- Inf /= -Inf, unequal NaN
  if (.not.ieee_is_finite(actual) .or. .not.ieee_is_finite(desired)) return
!--- floating point closeness check
  isclose = abs(actual-desired) <= max(r * max(abs(actual), abs(desired)), a)

end function isclose

impure elemental subroutine assert_isclose(actual, desired, rtol, atol, equal_nan, err_msg)
! NOTE: with Fortran 2018 this can be Pure
!
! inputs
! ------
! actual: value "measured"
! desired: value "wanted"
! rtol: relative tolerance
! atol: absolute tolerance
! equal_nan: consider NaN to be equal?
! err_msg: message to print on mismatch
!
! rtol overrides atol when both are specified

  real(wp), intent(in) :: actual, desired
  real(wp), intent(in), optional :: rtol, atol
  logical, intent(in), optional :: equal_nan
  character(*), intent(in), optional :: err_msg

  if (.not.isclose(actual,desired,rtol,atol,equal_nan)) then
    write(stderr,*) merge(err_msg,'',present(err_msg)),': actual',actual,'desired',desired
    call errorstop
  endif

end subroutine assert_isclose

end module assert