C
C      ________________________________________________________
C     |                                                        |
C     |   MINIMIZE A FUNCTION USING THE FLETCHER-REEVES FORM   |
C     |            OF THE CONJUGATE GRADIENT METHOD            |
C     |            WITH (OR WITHOUT) PRECONDITIONING           |
C     |                                                        |
C     |    INPUT:                                              |
C     |                                                        |
C     |         X     --ARRAY CONTAINING STARTING GUESS        |
C     |                                                        |
C     |         STEP  --STARTING GUESS FOR MINIMIZER IN DIREC- |
C     |                 TION OF NEGATIVE GRADIENT DURING FIRST |
C     |                 ITERATION (E. G. STEP=1) WHEN STEP=0,  |
C     |                 THE PROGRAM SELECTS A STARTING GUESS   |
C     |                                                        |
C     |         T     --COMPUTING TOLERANCE (ITERATIONS STOP   |
C     |                 WHEN MAX-NORM OF GRADIENT .LE. T)      |
C     |                                                        |
C     |         LIMIT --MAXIMUM NUMBER OF ITERATIONS           |
C     |                                                        |
C     |         N     --NUMBER OF UNKNOWNS                     |
C     |                                                        |
C     |         M     --NUMBER OF ITERATIONS UNTIL THE SEARCH  |
C     |                 DIRECTIONS ARE RENORMALIZED ALONG THE  |
C     |                 NEGATIVE GRADIENT (TYPICALLY, M = N)   |
C     |                                                        |
C     |         VALUE --NAME OF COST EVALUATION FUNC. ROUTINE  |
C     |                 (EXTERNAL IN MAIN PROGRAM)             |
C     |                 VALUE(X) IS VALUE OF COST AT X         |
C     |                                                        |
C     |         GRAD  --NAME OF GRADIENT EVALUATION SUBROUTINE |
C     |                 (EXTERNAL IN MAIN PROGRAM)             |
C     |                 GRAD(G,X) PUTS IN G THE GRADIENT AT X  |
C     |                                                        |
C     |         BOTH  --NAME SUBROUTINE TO EVALUATE BOTH COST  |
C     |                 AND ITS GRADIENT (EXTERNAL IN MAIN     |
C     |                 PROGRAM) BOTH(V,G,X) PUTS THE VALUE IN |
C     |                 V AND THE GRADIENT IN G FOR THE POINT X|
C     |                                                        |
C     |         PRE   --NAME OF PRECONDITIONING SUBROUTINE     |
C     |                 (EXTERNAL IN MAIN PROGRAM)             |
C     |                 PRE(Y,Z) APPLIES THE PRECONDITIONER TO |
C     |                 Z, STORING THE RESULT IN Y.            |
C     |                 IF PRECONDITIONING NOT USED SET Y = Z  |
C     |                                                        |
C     |         H     --WORK ARRAY (LENGTH AT LEAST 3N)        |
C     |                                                        |
C     |    OUTPUT:                                             |
C     |                                                        |
C     |         X     --MINIMIZER                              |
C     |                                                        |
C     |         E     --MAX-NORM OF GRADIENT                   |
C     |                                                        |
C     |         IT    --NUMBER OF ITERATIONS PERFORMED         |
C     |                                                        |
C     |         STEP  --STEP SIZE ALONG SEARCH DIRECTION FOR   |
C     |                 FINAL ITERATION                        |
C     |                                                        |
C     |    BUILTIN FUNCTIONS: DABS,DEXP,IDINT,DLOG,DSQRT,DMAX1,|
C     |                         DMIN1,DSIGN                    |
C     |    PACKAGE ROUTINES: CUB,FD,FV,FVD,INS                 |
C     |________________________________________________________|
C
      SUBROUTINE CG(X,E,IT,STEP,T,LIMIT,N,M,VALUE,GRAD,BOTH,PRE,H)
      INTEGER I,IT,J,K,L,LIMIT,M,N,NA,NB,NC,ND
      REAL*8 H(N,1),X(1),Y(50),Z(50),A1,A2,A3,A4,A5,A6,A7,A8,A,B,C,C0,C1
      REAL*8 D,D0,DA,DB,E,F,F0,F1,FA,FB,FC,G,L3,P,Q,R,S,STEP,T,V,W
      REAL*8 FV,FD,VALUE
      EXTERNAL BOTH,GRAD,PRE,VALUE
      DATA A1/.1D0/,A2/.9D0/,A3/5.D0/,A4/.2D0/,A5/10.D0/,A6/.9D0/
      DATA A7/.3D0/
      A8 = A3 + .01D0
      IT = 0
      CALL BOTH(F,H(1,3),X)
      E = 0.
      DO 10 I = 1,N
10         IF ( DABS(H(I,3)) .GT. E ) E = DABS(H(I,3))
      IF ( E .LE. T ) RETURN
      L3 = 1./DLOG(A3)
      CALL PRE(H(1,2),H(1,3))
      A = STEP
      IF ( A .GT. 0. ) GOTO 30
      DO 20 I = 1,N
20         IF ( DABS(X(I)) .GT. A ) A = DABS(X(I))
      A = .01*A/E
      IF ( A .EQ. 0. ) A = 1.
30    G = 0.
      DO 40 I = 1,N
40         G = G + H(I,2)*H(I,3)
      IF ( G .LT. 0. ) GOTO 620
50    L = 0
      DO 60 I = 1,N
60         H(I,1) = -H(I,2)
      D = -G
70    FA = FV(A,X,H,N,VALUE)
      C0 = A
      F0 = FA
      J = 2
      Y(1) = 0.
      Z(1) = F
      Y(2) = A
      Z(2) = FA
      V = A1*D
      W = A2*D
      IQ = 0
      IF ( FA .LE. F ) GOTO 80
      C = A
      B = 0.
      A = 0.
      FC = FA
      FB = F
      FA = F
      GOTO 90
80    C = 0.
      B = 0.
      FC = F
      FB = F
      IQ = 1
90    NA = 0
      NB = 0
      NC = 0
      ND = 0
      Q = (D+(F-F0)/C0)/C0
      IF ( Q .LT. 0. ) GOTO 110
      Q = A
100   ND = ND + 1
      IF ( ND .GT. 25 ) GOTO 610
      Q = A3*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .LT. W*Q ) GOTO 100
      GOTO 260
110   Q = .5*D/Q
      IF ( Q .LT. .01*C0 ) Q = .01*C0
      P = FV(Q,X,H,N,VALUE)
      IF ( P .LE. F0 ) GOTO 120
      F1 = F0
      C1 = C0
      F0 = P
      C0 = Q
      GOTO 130
120   F1 = P
      C1 = Q
130   CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
135   IF ( A .EQ. 0. ) GOTO 140
      IF ( FA-F .GE. V*A ) GOTO 160
      IF ( FA-F .LT. W*A ) GOTO 210
      GOTO 280
140   Q = C0
      IF ( C1 .LT. Q ) Q = C1
150   NA = NA + 1
      IF ( NA .GT. 25 ) GOTO 630
      Q = A4*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .GE. V*Q ) GOTO 150
      GOTO 250
160   IF ( C0 .GT. C1 ) GOTO 200
      IF ( F0-F .GT. V*C0 ) GOTO 180
      IF ( F0-F .GE. W*C0 ) GOTO 320
      IF ( C1 .LE. A5*C0 ) GOTO 320
      R = DLOG(C1/C0)
      S = -IDINT(R*L3+.999)
      R = .999*DEXP(R/S)
      Q = C1
170   Q = Q*R
      IF ( Q .LT. C0 ) GOTO 320
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      NA = NA + 1
      IF ( P-F .GT. V*Q ) GOTO 170
      GOTO 320
180   Q = C0
190   NA = NA + 1
      IF ( NA .GT. 25 ) GOTO 630
      Q = A4*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .GE. V*Q ) GOTO 190
      GOTO 250
200   Q = A
      GOTO 190
210   IF ( C0 .LT. C1 ) GOTO 290
      IF ( F0-F .GE. V*C0 ) GOTO 230
      IF ( F0-F .GE. W*C0 ) GOTO 250
      Q = C0
220   ND = ND  + 1
      IF ( ND .GT. 25 ) GOTO 610
      Q = A3*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .LT. W*Q ) GOTO 220
      GOTO 250
230   IF ( C0 .LE. A5*C1 ) GOTO 250
      R = DLOG(C0/C1)
      S = IDINT(R*L3+.999)
      R = 1.001*DEXP(R/S)
      Q = A
240   Q = Q*R
      IF ( Q .GT. C0 ) GOTO 250
      ND = ND + 1
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .LT. W*Q ) GOTO 240
250   IF ( IQ .EQ. 1 ) GOTO 320
260   IF ( B .EQ. 0. ) GOTO 280
      IF ( C .EQ. 0. ) GOTO 270
      V = C - A
      W = A - B
      R = 1./V
      S = 1./W
      P = FC - FA
      Q = FB - FA
      E = P*R + Q*S
      IF ( DSIGN(E,C-B) .NE. E ) GOTO 320
      IF ( E .EQ. 0. ) GOTO 320
      Q = (P*R)*W - (Q*S)*V
      Q = A - .5*Q/E
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      GOTO 320
270   R = 1./A
      S = 1./B
      P = R*(FA-F) - D
      Q = S*(FB-F) - D
      E = A - B
      V = (R*P-S*Q)/E
      W = (A*Q*S-B*P*R)/E
      V = W*W-3.*V*D
      IF ( V .LT. 0. ) V = 0.
      V = DSQRT(V)
      IF ( W+V .EQ. 0. ) GOTO 320
      Q = -D/(W+V)
      IF ( Q .LE. 0. ) GOTO 320
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      GOTO 320
280   IF ( IQ .EQ. 1 ) GOTO  320
      Q = (D+(F-FA)/A)/A
      IF ( Q .GE. 0. ) GOTO 320
      Q = .5*D/Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      GOTO 320
290   IF ( F0-F .GT. V*C0 ) GOTO 300
      IF ( F0-F .GT. W*C0 ) GOTO 320
300   Q = A
310   ND = ND + 1
      IF ( ND .GT. 25 ) GOTO 610
      Q = A3*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .LT. W*Q ) GOTO 310
      GOTO 250
320   DA = FD(A,X,H,N,GRAD)
      IF ( DA .GT. A6*G ) GOTO 410
      IF ( DA .GE. 0. ) GOTO 560
      R = A
      Q = 0.
      DO 330 I = 1,J
           IF ( Y(I) .GT. A ) GOTO 370
           IF ( Y(I) .LE. Q ) GOTO 330
           IF ( Y(I) .EQ. A ) GOTO 330
           Q = Y(I)
330   CONTINUE
      IF ( A .LE. A8*Q ) GOTO 560
      Q = A
340   ND = ND + 1
      IF ( ND .GT. 25 ) GOTO 610
      Q = A3*Q
      P = FV(Q,X,H,N,VALUE)
      F1 = FA
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P .LT. F1 ) GOTO 340
      IF ( A .GT. R ) GOTO 360
      DO 350 I = 1,N
350        H(I,2) = X(I) + A*H(I,1)
      GOTO 560
360   DA = FD(A,X,H,N,GRAD)
      IF ( DA .GT. A6*G ) GOTO 410
      GOTO 560
370   Q = Y(I)
      DO 380 K = I,J
           IF ( Y(K) .LE. A ) GOTO 380
           IF ( Y(K) .LT. Q ) Q = Y(K)
380   CONTINUE
      IF ( Q .LE. A5*A ) GOTO 560
      F0 = DLOG(Q/A)
      S = IDINT(F0*L3+.999)
      F0 = 1.001*DEXP(F0/S)
      S = A
390   S = S*F0
      IF ( S .GE. Q ) GOTO 320
      P = FV(S,X,H,N,VALUE)
      F1 = FA
      CALL INS(S,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P .LT. F1 ) GOTO 390
      IF ( A .GT. R ) GOTO 320
      DO 400 I = 1,N
400        H(I,2) = X(I) + A*H(I,1)
      GOTO 560
410   B = 0.
      K = 1
      I = K
420   I = I + 1
      IF ( I .GT. J ) GOTO 430
      IF ( Y(I) .GE. A ) GOTO 420
      IF ( Y(I) .LT. B ) GOTO 420
      B = Y(I)
      K = I
      GOTO 420
430   FB = Z(K)
      DB = D
      IF ( B .NE. 0. ) DB = FD(B,X,H,N,GRAD)
440   W = 2.*DABS(B-A)
      CALL CUB(C,A,B,FA,FB,DA,DB)
      NC = 1
      GOTO 480
450   W = .5*W
      IF ( W .LT. DABS(C0-C) ) GOTO 550
      IF ( C0 .LT. C ) GOTO 460
      IF ( D0 .GE. D ) GOTO 470
      GOTO 550
460   IF ( D0 .GT. D ) GOTO 550
470   CALL CUB(C,C,C0,F,F0,D,D0)
      NC = NC + 1
      IF ( NC .GT. 30 ) GOTO 600
480   R = DMAX1(A,B)
      S = DMIN1(A,B)
      IF ( C .GT. R ) GOTO 490
      IF ( C .GT. S ) GOTO 500
      C = S + (S-C)
      S = .5*(A+B)
      IF ( C .GT. S ) C = S
      GOTO 500
490   C = R - (C-R)
      S = .5*(A+B)
      IF ( C .LT. S ) C = S
500   C0 = A
      F0 = FA
      D0 = DA
      CALL FVD(F,D,C,X,H,N,BOTH)
      IF ( F .LT. FA ) GOTO 510
      B = C
      FB = F
      DB = D
      GOTO 450
510   IF ( C .LT. A ) GOTO 540
      IF ( D .LT. 0. ) GOTO 530
520   B = A
      FB = FA
      DB = DA
530   A = C
      FA = F
      DA = D
      IF ( D .GT. A6*G ) GOTO 450
      GOTO 560
540   IF ( D .LT. 0. ) GOTO 520
      GOTO 530
550   C = .5*(A+B)
      NB = NB + 1
      W = DABS(B-A)
      GOTO 500
560   E = 0.
      DO 570 I = 1,N
           IF ( DABS(H(I,3)) .GT. E ) E = DABS(H(I,3))
570        X(I) = H(I,2)
      IT = IT + 1
      IF ( E .LE. T ) GOTO 660
      IF ( IT .GE. LIMIT ) GOTO 660
      F = FA
      D = DA
      A = A7*A
      CALL PRE(H(1,2),H(1,3))
      R = 0.
      DO 580 I = 1,N
580        R = R + H(I,2)*H(I,3)
      IF ( R .LT. 0. ) GOTO 620
      S = R/G
      G = R
      L = L + 1
      IF ( L .GE. M ) GOTO 50
      D = 0.
      DO 590 I = 1,N
           H(I,1) = -H(I,2) + S*H(I,1)
590        D = D + H(I,1)*H(I,3)
      GOTO 70
600   IF ( D .LT. G ) GOTO 560
      WRITE(6,*) 'UNABLE TO OBTAIN DESCENT DIRECTION'
      STOP
610   WRITE(6,*) 'THE FUNCTION DECREASES WITH NO MINIMUM'
      STOP
620   WRITE(6,*) 'PRECONDITIONER NOT POSITIVE DEFINITE'
      STOP
630   Q = Q*A3**25
      ND = 0
640   ND = ND + 1
      IF ( ND .GT. 25 ) GOTO 650
      Q = A3*Q
      P = FV(Q,X,H,N,VALUE)
      CALL INS(Q,P,A,B,C,FA,FB,FC,J,Y,Z)
      IF ( P-F .GT. V*Q ) GOTO 640
      GOTO 135
650   WRITE(6,*) 'UNABLE TO SATISFY ARMIJO CONDITION'
      RETURN
660   STEP = A
      RETURN
      END
      DOUBLE PRECISION FUNCTION FV(A,X,H,N,VALUE)
      REAL*8 H(N,1),X(1),A,VALUE
      EXTERNAL VALUE
      DO 10 I = 1 , N
10         H(I,2) = X(I) + A*H(I,1)
      FV = VALUE(H(1,2))
      RETURN
      END
      DOUBLE PRECISION FUNCTION FD(A,X,H,N,GRAD)
      REAL*8 H(N,1),X(1),A,D
      EXTERNAL GRAD
      DO 10 I = 1 , N
10         H(I,2) = X(I) + A*H(I,1)
      CALL GRAD(H(1,3),H(1,2))
      D = 0.
      DO 20 I = 1,N
20         D = D + H(I,1)*H(I,3)
      FD = D
      RETURN
      END
      SUBROUTINE FVD(V,D,A,X,H,N,BOTH)
      REAL*8 H(N,1),X(1),A,D,V
      EXTERNAL BOTH
      DO 10 I = 1 , N
10         H(I,2) = X(I) + A*H(I,1)
      CALL BOTH(V,H(1,3),H(1,2))
      D = 0.
      DO 20 I = 1,N
20         D = D + H(I,1)*H(I,3)
      RETURN
      END
      SUBROUTINE CUB(X,A,B,C,D,E,F)
      REAL*8 A,B,C,D,E,F,G,V,W,X,Y,Z
      G = B - A
      IF ( G .EQ. 0. ) GOTO 50
      V = E + F - 3*(D-C)/G
      W = V*V-E*F
      IF ( W .LT. 0. ) W = 0.
      W = DSIGN(DSQRT(W),G)
      Y = E + V
      Z = F + V
      IF ( DSIGN(Y,G) .NE. Y ) GOTO 30
      IF ( DSIGN(Z,G) .NE. Z ) GOTO 20
      IF ( Z .EQ. 0. ) GOTO 20
10    X = B - G*F/(Z+W)
      RETURN
20    IF ( C .LT. D ) X = A
      IF ( C .GE. D ) X = B
      RETURN
30    IF ( DSIGN(Z,G) .NE. Z ) GOTO 40
      IF ( DABS(E) .GT. DABS(F) ) GOTO 10
40    X = A + G*E/(Y-W)
      RETURN
50    X = A
      RETURN
      END
      SUBROUTINE INS(S,F,A,B,C,FA,FB,FC,J,Y,Z)
      REAL*8 A,B,C,F,FA,FB,FC,S,Y(1),Z(1)
      INTEGER J
      J = J + 1
      Y(J) = S
      Z(J) = F
      IF ( F .LE. FA ) GOTO 20
      IF ( F .LE. FB ) GOTO 10
      IF ( F .GT. FC ) RETURN
      C = S
      FC = F
      RETURN
10    C = B
      B = S
      FC = FB
      FB = F
      RETURN
20    C = B
      B = A
      A = S
      FC = FB
      FB = FA
      FA = F
      RETURN
      END


      program GF_sde_tnds  ! Calculation of the half-space
                           ! electromagnetic Green's tensor
                           ! by the short-dsitance expansion
                           ! for the case of a transparent,
                           ! NONDISPERSIVE substrate.
                           !
                           ! ONLY the reflected part, GR, is computed
c------------------------------------------------------------------
c               Authors:
c                  George Y. Panasyuk, Vadim A. Markel, John C. Schotland
c                  University of Pennsylvania
c               E-mail address for questions and comments:
c                  vmarkel@mail.med.upenn.edu
c               For updates and additional info check
c                  URL: http://whale.seas.upenn.edu/CODES/
c------------------------------------------------------------------
      implicit none

      integer*4 idummy, kl, nl, key, nord
      logical*4 logscale
      character*4 hdummy, output_prec, lambda_scale

      real*8 rdummy
      real*8 p1, p2, p3, p4
      real*8 ru, rz, pi, twopi

      real*8 k1, rho, z1, z2, z_p, s
      real*8 lambda, lambda_min, lambda_max, dlambda, rlambda, power
      real*8 eps, eps_1, eps_2_r, eps_2, da, db
      real*8 eps_m,eps_p, ep2,ep3,ep4,ep5

      real*8 zh, zh2, zh3, zh4, rhoh, rhoh2, rhoh3, rhoh4
      real*8 Lam, sf, tt, p5,p6,p7, bi1,bi2,bi3,bi4
      real*8 v,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14, v_p
      real*8 pi1,pi2,pi3,pi4,pi5,pi6,pi7,pi8,pi9,pi10,pi11,pi12,pi13
      real*8 d1,d2,d3,d4,d5,d6,d7
      real*8 L,Lhat,Lhat2,Lhat3,Lhat4
      real*8 s3, s4, s5, s6

      complex*16 cu, cz
      complex*16 Kxx0,Kyy0,Kzz0,Kxz0, Kxx2,Kyy2,Kzz2,Kxz2
      complex*16 Kxx3,Kyy3,Kzz3,Kxz3, Kxx4,Kyy4,Kzz4,Kxz4
      complex*16 Kxx5,Kyy5,Kzz5,Kxz5, Kxx6,Kyy6,Kzz6,Kxz6
      complex*16 Kxx7,Kyy7,Kzz7,Kxz7
      complex*16 GRxx(0:7), GRyy(0:7), GRzz(0:7), GRxz(0:7), GRzx(0:7)
c
c------ Mathematical constants ------------------------------------
c
      rz = 0.0d0
      ru = 1.0d0
      cu = (0.0d0, 1.0d0)
      cz = (0.0d0, 0.0d0)
      pi = 2*dasin(1.0d0)
      twopi = 2.0d0*pi

      sf  = 64.
      tt  = 32.
      bi1 = 20160.
      bi2 = 3360.
      bi3 = 840.
      bi4 = 105.
c
c---------- Reading input parameters -----------------------------------
c
      open(unit=70, file='GF.par', status='old', err=101)
      read(70,*) hdummy
      read(70,*) hdummy

      read(70,*, err=101) key
      if(key .eq. 0) then
         write(*,*) 'GF_sde_tnds ignores the KEY=0 option'
         write(*,*) 'Even though you have given me KEY=0,'
         write(*,*) '   ... I will set KEY=1 and assume'
         write(*,*) '   ... a nondispersive transparent substrate'
         key = 1
      end if
      if (key .eq. 1) then
         write(*,*) 'Assuming that the substrate has a'
         write(*,*) '   ... wavelength-independent, REAL permittivity'
         write(*,*) '   ... eps_2 = eps_2_r + i*0'
         write(*,*) '   ... where eps_2_r is given in GF.par'
         write(*,*) 'If you dont like this, use GF_sde_tdss,'
         write(*,*) '   ... set KEY=2,'
         write(*,*) '   ... and program your own formula for eps_2_r'
         write(*,*) '   ... But make sure that eps_2 is REAL'
      else if (key .eq. 2) then
         write(*,*) 'KEY=2 is not allowed in GF_sde_tnds'
         write(*,*) 'If you wish to program your own'
         write(*,*) '   ... wavelength-dependent eps_2_r,'
         write(*,*) '   ... use GF_sde_tdss'
         write(*,*) 'Exiting'
         stop
      else
         write(*,*) 'Error. Incorrect parameter: KEY=', key
         write(*,*) 'KEY is allowed to take only the values 0,1,2'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*,err=101) nord
      if(nord .lt. 0) then
         write(*,*) 'Warning. You have requested NORD<0.'
         write(*,*) 'This option is used only in GF_k2g'
         write(*,*) 'For GF_sde_tnds, the sign of NORD does not matter'
         write(*,*) 'I will set NORD=|NORD| and continue.'
         nord = -nord
         write(*,*) 'NORD=', nord
         write(*,*) '--------------------------------------------'
      end if

      if(nord .gt. 7) then
         write(*,*) 'Error. Incorrect parameter: NORD>7'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if (nord .eq. 1) then
         write(*,*) 'The first order correction is identicallyz zero'
         write(*,*) '    (see paper)'
         write(*,*) 'Therefore, there is no difference between NORD=0'
         write(*,*) '    and NORD=1'
         write(*,*) 'I will set NORD=0 and continue'
         write(*,*) 'The result is not affected. Goodby.'
         nord = 0
      end if

      read(70,2,err=101) output_prec
      if(output_prec .eq. 'S') goto 3
      if(output_prec .eq. 's') goto 3
      if(output_prec .eq. 'D') goto 3
      if(output_prec .eq. 'd') goto 3
         write(*,*) 'Incorrect parameter OUTPUT_PREC'
         write(*,*) 'Only chars S, s, D, d are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 3    continue

      read(70,4,err=101) lambda_scale
      if(lambda_scale .eq. 'LOG') goto 5
      if(lambda_scale .eq. 'log') goto 5
      if(lambda_scale .eq. 'LIN') goto 5
      if(lambda_scale .eq. 'lin') goto 5
         write(*,*) 'Incorrect parameter LAMBDA_SCALE'
         write(*,*) 'Only "LOG", "log", "LIN", "lin" are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 5    continue

      read(70,*) lambda_min, lambda_max, nl
      write(*,*) 'lambda_min,lambda_max:', sngl(lambda_min),
     $                                     sngl(lambda_max), '  [nm]'
      write(*,*) 'nl:', nl
      if(lambda_min.lt.rz) then
         write(*,*) 'Error. Incorrect parameters: lambda_min<0'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if(lambda_min.gt.lambda_max) then
         write(*,*) 'Error. Incorrect parameters: lambda_min>lambda_max'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if((lambda_min.eq.lambda_max) .and. (nl.ne.1) ) then
         write(*,*) 'Warning. lambda_min=lambda_max but nl=/=1'
         write(*,*) 'Setting nl=1 and continuing'
         nl=1
      else if((lambda_min .lt. lambda_max) .and. (nl.lt.2)) then
         write(*,*) 'Warning. lambda_min<lambda_max but nl<2'
         write(*,*) 'Setting nl=2 and continuing'
         nl=2
      end if

      read(70,*) z1, z2, rho
      if(z1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z1<=0; z1=', z1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(z2.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z2<=0; z2=', z2
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(rho.le.rz) then
         write(*,*) 'Error. Incorrect parameter: rho<=0; rho=', rho
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) eps_2_r, rdummy
      if(eps_2_r .lt. rz) then
         write(*,*) 'Error. Incorrect parameter: eps_2_r<0;
     $                                           eps_2_r=', eps_2_r
         write(*,*) 'GF_sde_tnds only allows positive eps_2_r'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) rdummy
      read(70,*) rdummy
      read(70,*) rdummy

      read(70,*) eps_1
      if(eps_1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: eps_1<=0; eps_1=',
     $                                                     eps_1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) idummy
      read(70,*) idummy
      read(70,*) idummy
      read(70,*) rdummy, rdummy

      close(unit=70)
c
c------- End reading parameters -----------------------------
c

c
c------- Input-dependent constants --------------------------
c
      if(nl .gt. 1) then
         dlambda = (lambda_max - lambda_min)/dfloat(nl-1)
      else
         dlambda = rz
      end if
      logscale = .false.
      if(lambda_scale .eq. 'LOG') logscale=.true.
      if(lambda_scale .eq. 'log') logscale=.true.
      if(logscale) then
         write(*,*) 'Using logscale'
         if(lambda_min .eq. rz) then
            write(*,*) 'If using logscale, lambda_min=0 is not allowed'
            write(*,*) 'Correct GF.par and try again; exiting'
            stop
         end if
         rlambda = lambda_max/lambda_min
      end if

c
c-------- End input-dependent constants block ------------------------
c
      open(71, file='GRxx_tsub', status='unknown', err=102)
      open(72, file='GRyy_tsub', status='unknown', err=102)
      open(73, file='GRzz_tsub', status='unknown', err=102)
      open(74, file='GRxz_tsub', status='unknown', err=102)

      open(76, file='Kxx_tsub', status='unknown', err=102)
      open(77, file='Kyy_tsub', status='unknown', err=102)
      open(78, file='Kzz_tsub', status='unknown', err=102)
      open(79, file='Kxz_tsub', status='unknown', err=102)

      if(key.eq.1) then
         eps_2 = eps_2_r
      else
         write(*,*) 'Unexpected error 1; exiting'
         write(*,*) 'Please report this error to code developers'
         stop
      end if

      eps =  eps_2/eps_1

      eps_m = eps - ru
      eps_p = eps + ru

      s = (ru-eps)/(ru+eps)
      ep2 = eps*eps
      ep3 = ep2*eps
      ep4 = ep3*eps
      ep5 = ep4*eps

      d1 = dsqrt(eps_p)
      d2 = dsqrt(eps)
      d3 = (ru + d1)/(eps + d2*d1)
      d4 = (eps + ru)**2
      d5 = 3.*(d2 + ru)
      d6 = (ru - 3.*(d2 - eps) + 2.*ep2)/d5
      d7 = ru + d2 + 2.*eps*(ru - d2*eps_m) - ep3
      Lam = (eps/eps_m/d1)*dlog(d3)

      Kxx3 =  cu*(eps/d4)*(d6 + Lam)
      Kyy3 =  Kxx3
      Kzz3 = -cu*(2./d4)*(d7/d5 + Lam*ep2)
      Kxz3 =  cz

c     higher orders (only imaginary parts of Gab):

      p1 = 2.*ep3 + 5.*ep2 + ru
      p2 = ep2 + 6.*eps + ru
      p3 = eps_m*(2.*ep4+7.*ep3+7.*ep2-eps+ru)
      p4 = 4.*ep5+17.*ep4+22.*ep3-14.*ep2+2.*eps+ru
      p5 = 4.*ep5+19.*ep4+34.*ep3+22.*ep2+14.*eps+3.
      p6 = eps_m*(ep3+5.*ep2+9.*eps+ru)
      p7 = ep4+6.*ep3+18.*ep2+6.*eps+ru

      v   = d2
      v2  = v*v
      v3  = v2*v
      v4  = v3*v
      v5  = v4*v
      v6  = v5*v
      v7  = v6*v
      v8  = v7*v
      v9  = v8*v
      v10 = v9*v
      v11 = v10*v
      v12 = v11*v
      v13 = v12*v
      v14 = v13*v
      v_p = v + ru

c............................................................

      pi1 = 4.*v10+4.*v9+4.*v8+8.*v7 -
     $      14.*v6+2.*v5-21.*v4+11.*v3-9.*v2 -
     $      2.*v-2.
      pi2 = v2*(8.*v8+8.*v7+26.*v6+18.*v5 +
     $      15.*v4-33.*v3-v2+2.*v+2.)
      pi3 = 8.*v10+8.*v9+30.*v8+14.*v7 +
     $      29.*v6-19.*v5-3.*v4-18.*v3-18.*v2
     $      -8.*v-8.
      pi4 = 2.*v10+2.*v9+6.*v8+5.*v7+2.*v6 -
     $      10.*v5+3.*v3+3.*v2+v+ru
      pi5 = 2.*v10+2.*v9+11.*v8+15.*v7+7.*v6 -
     $      10.*v5-10.*v4-12.*v3-12.*v2-4.*v-4.
      pi6 = 16.*v14+16.*v13+16.*v12+16.*v11 -
     $      52.*v10-70.*v9-30.*v8-120.*v7+154.*v6-
     $      34.*v5+183.*v4-77.*v3+63.*v2+12.*v+12.
      pi7 = 32.*v14+32.*v13+80.*v12+80.*v11-
     $      24.*v10-8.*v9-246.*v8-150.*v7-177.*v6+
     $      191.*v5-33.*v4-38.*v3-38.*v2-8.*v-8.
      pi8 = eps*(48.*v12+48.*v11+200.*v10+200.*v9
     $      +298.*v8+250.*v7+7.*v6-425.*v5-137.*v4
     $      +10.*v3+10.*v2+8.*v+8.)
      pi9 = eps*(32.*v12+32.*v11+96.*v10+96.*v9+
     $      40.*v8+64.*v7-154.*v6-50.*v5-187.*v4+
     $      37.*v3-75.*v2-18.*v-18.)
      pi10 = 48.*v14+48.*v13+232.*v12+232.*v11+
     $       482.*v10+338.*v9+443.*v8-85.*v7+11.*v6
     $       -382.*v5-382.*v4-344.*v3-344.*v2-96.*v-96
      pi11 = 8.*v14+8.*v13+18.*v12+18.*v11-
     $       14.*v10-11.*v9-73.*v8-50.*v7-43.*v6+
     $       67.*v5-3.*v4-12.*v3-12.*v2-3.*v-3.
      pi12 = 8.*v14+8.*v13+32.*v12+32.*v11+
     $       42.*v10+38.*v9-17.*v8-85.*v7-29.*v6+
     $       18.*v5+18.*v4+16.*v3+16.*v2+4.*v+4.
      pi13 = 8.*v14+8.*v13+46.*v12+46.*v11+
     $       133.*v10+157.*v9+109.*v8-50.*v7-50.*v6-
     $       136.*v5-136.*v4-96.*v3-96.*v2-24.*v-24.

      z_p   = z2 + z1
      L     = dsqrt(rho*rho + z_p*z_p)
      zh    = z_p/L
      zh2   = zh*zh
      zh3   = zh2*zh
      zh4   = zh2*zh2
      rhoh  = rho/L
      rhoh2 = rhoh*rhoh
      rhoh3 = rhoh2*rhoh
      rhoh4 = rhoh2*rhoh2

      s3 = ru/eps_p**3
      s4 = s3/eps_p
      s5 = s4*pi*eps_m
      s6 = s3*pi*eps_m
c
c------- Start loop over wavelengths ---------------------------------
c
      do 1, kl=1,nl
      if(logscale) then
         power = dfloat(kl-1)/dfloat(nl-1)
         lambda = lambda_min * rlambda**power
      else
         lambda = lambda_min + dlambda*dfloat(kl-1)
      end if
      write(*,*) kl, ':   lambda=', sngl(lambda), '[nm]'

      k1 = twopi*dsqrt(eps_1)/lambda
      Lhat  = L*k1
      Lhat2 = Lhat*Lhat
      Lhat3 = Lhat2*Lhat
      Lhat4 = Lhat3*Lhat

c     O(1/r/r/r) and O(1/r) contributions in refl part:

      Kxx0 = -s*(3.*zh2 - 2.)
      Kyy0 = -s
      Kzz0 = -s*(3.*zh2 - ru)
      Kxz0 = -s*3.*rhoh*zh

      Kxx2 = s*zh*((ru + s)/(ru + zh) - zh)/2.
      Kyy2 = s*(s - zh)/2./(ru + zh)
      Kzz2 = -s*((zh2 - s)/2. + ru)
      Kxz2 = -s*(eps*(L - z_p)/eps_p/rho + zh*rhoh/2.)

c     higher orders in h-expansion in refl part:

      Kxx4 = -cu*s6*zh*p1/16.
      Kyy4 =     Kxx4
      Kzz4 = -cu*s6*zh*eps*p2/8.
      Kxz4 =  cu*s6*rhoh*eps*p2/16.
      da = 4.*(pi1/v_p - 15.*eps*Lam)
      db = pi2/v_p + 45.*ep2*Lam
      Kxx5 = cu*s3*(da*zh2 - db*rhoh2)/120.
      db = pi3/v_p + 15.*ep2*Lam
      Kyy5 = cu*s3*(da*zh2 - db*rhoh2)/120.
      da = 2.*(pi4/v_p + 15.*ep2*Lam)
      db = pi5/v_p - 15.*ep3*Lam
      Kzz5 = cu*s3*(da*zh2 - db*rhoh2)/30.
      Kxz5 = -cu*s3*zh*rhoh*da/15./2.

      Kxx6 = cu*s5*zh*(rhoh2*p4/4. - p3*zh2/3.)/sf
      Kyy6 = cu*s5*zh*(rhoh2*p5/4. - p3*zh2/3.)/sf
      Kzz6 = cu*s5*eps*zh*(rhoh2*p7/2. - p6*zh2/3.)/tt
      Kxz6 = cu*s5*eps*rhoh*(p6*zh2 - rhoh2*p7/4.)/sf

      Kxx7 = cu*s4*(8.*zh4*(pi6/v_p+bi4*eps*Lam)+12.*zh2*rhoh2*
     $       (315.*ep2*Lam-pi7/v_p)+rhoh4*(pi8/v_p+525.*ep3*Lam))/bi1
      Kyy7 = cu*s4*(8.*zh4*(pi6/v_p+bi4*eps*Lam)+12.*zh2*rhoh2*
     $       (bi4*ep2*Lam-pi9/v_p)+rhoh4*(pi10/v_p+bi4*ep3*Lam))/bi1
      Kzz7 = cu*s4*(8.*zh4*(pi11/v_p-bi4*ep2*Lam)/3.-8.*zh2*rhoh2*
     $       (bi4*ep3*Lam+pi12/v_p)+rhoh4*(pi13/v_p-bi4*ep4*Lam))/bi2
      Kxz7 = cu*s4*(-4.*zh3*rhoh*(pi11/v_p-bi4*ep2*Lam)/3. +
     $       zh*rhoh3*(bi4*ep3*Lam+pi12/v_p))/bi3

      GRxx(0) = Kxx0/Lhat3
      GRyy(0) = Kyy0/Lhat3
      GRzz(0) = Kzz0/Lhat3
      GRxz(0) = Kxz0/Lhat3

      GRxx(1) = GRxx(0)
      GRyy(1) = GRyy(0)
      GRzz(1) = GRzz(0)
      GRxz(1) = GRxz(0)

      GRxx(2) = GRxx(1) + Kxx2/Lhat
      GRyy(2) = GRyy(1) + Kyy2/Lhat
      GRzz(2) = GRzz(1) + Kzz2/Lhat
      GRxz(2) = GRxz(1) + Kxz2/Lhat

      GRxx(3) = GRxx(2) + Kxx3
      GRyy(3) = GRyy(2) + Kyy3
      GRzz(3) = GRzz(2) + Kzz3
      GRxz(3) = GRxz(2) + Kxz3

      GRxx(4) = GRxx(3) + Kxx4*Lhat
      GRyy(4) = GRyy(3) + Kyy4*Lhat
      GRzz(4) = GRzz(3) + Kzz4*Lhat
      GRxz(4) = GRxz(3) + Kxz4*Lhat

      GRxx(5) = GRxx(4) + Kxx5*Lhat2
      GRyy(5) = GRyy(4) + Kyy5*Lhat2
      GRzz(5) = GRzz(4) + Kzz5*Lhat2
      GRxz(5) = GRxz(4) + Kxz5*Lhat2

      GRxx(6) = GRxx(5) + Kxx6*Lhat3
      GRyy(6) = GRyy(5) + Kyy6*Lhat3
      GRzz(6) = GRzz(5) + Kzz6*Lhat3
      GRxz(6) = GRxz(5) + Kxz6*Lhat3

      GRxx(7) = GRxx(6) + Kxx7*Lhat4
      GRyy(7) = GRyy(6) + Kyy7*Lhat4
      GRzz(7) = GRzz(6) + Kzz7*Lhat4
      GRxz(7) = GRxz(6) + Kxz7*Lhat4

      GRzx(0) = -GRxz(0)
      GRzx(1) = -GRxz(1)
      GRzx(2) = -GRxz(2)
      GRzx(3) = -GRxz(3)
      GRzx(4) = -GRxz(4)
      GRzx(5) = -GRxz(5)
      GRzx(6) = -GRxz(6)
      GRzx(7) = -GRxz(7)

      if((output_prec.eq.'S') .or. (output_prec.eq.'s')) then

         write(71,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxx(nord))), sngl(dimag(GRxx(nord)))
         write(72,6,err=102) sngl(lambda),
     $      sngl(dreal(GRyy(nord))), sngl(dimag(GRyy(nord)))
         write(73,6,err=102) sngl(lambda),
     $      sngl(dreal(GRzz(nord))), sngl(dimag(GRzz(nord)))
         write(74,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxz(nord))), sngl(dimag(GRxz(nord)))

         write(76,8,err=102) sngl(lambda),
     $      sngl(dreal(Kxx0)), sngl(dimag(Kxx0)),
     $      sngl(dreal(Kxx2)), sngl(dimag(Kxx2)),
     $      sngl(dreal(Kxx3)), sngl(dimag(Kxx3)),
     $      sngl(dreal(Kxx4)), sngl(dimag(Kxx4)),
     $      sngl(dreal(Kxx5)), sngl(dimag(Kxx5)),
     $      sngl(dreal(Kxx6)), sngl(dimag(Kxx6)),
     $      sngl(dreal(Kxx7)), sngl(dimag(Kxx7))
         write(77,8,err=102) sngl(lambda),
     $      sngl(dreal(Kyy0)), sngl(dimag(Kyy0)),
     $      sngl(dreal(Kyy2)), sngl(dimag(Kyy2)),
     $      sngl(dreal(Kyy3)), sngl(dimag(Kyy3)),
     $      sngl(dreal(Kyy4)), sngl(dimag(Kyy4)),
     $      sngl(dreal(Kyy5)), sngl(dimag(Kyy5)),
     $      sngl(dreal(Kyy6)), sngl(dimag(Kyy6)),
     $      sngl(dreal(Kyy7)), sngl(dimag(Kyy7))
         write(78,8,err=102) sngl(lambda),
     $      sngl(dreal(Kzz0)), sngl(dimag(Kzz0)),
     $      sngl(dreal(Kzz2)), sngl(dimag(Kzz2)),
     $      sngl(dreal(Kzz3)), sngl(dimag(Kzz3)),
     $      sngl(dreal(Kzz4)), sngl(dimag(Kzz4)),
     $      sngl(dreal(Kzz5)), sngl(dimag(Kzz5)),
     $      sngl(dreal(Kzz6)), sngl(dimag(Kzz6)),
     $      sngl(dreal(Kzz7)), sngl(dimag(Kzz7))
         write(79,8,err=102) sngl(lambda),
     $      sngl(dreal(Kxz0)), sngl(dimag(Kxz0)),
     $      sngl(dreal(Kxz2)), sngl(dimag(Kxz2)),
     $      sngl(dreal(Kxz3)), sngl(dimag(Kxz3)),
     $      sngl(dreal(Kxz4)), sngl(dimag(Kxz4)),
     $      sngl(dreal(Kxz5)), sngl(dimag(Kxz5)),
     $      sngl(dreal(Kxz6)), sngl(dimag(Kxz6)),
     $      sngl(dreal(Kxz7)), sngl(dimag(Kxz7))

      else if((output_prec.eq.'D') .or. (output_prec.eq.'d')) then

         write(71,10,err=102) sngl(lambda),
     $                       dreal(GRxx(nord)), dimag(GRxx(nord))
         write(72,10,err=102) sngl(lambda),
     $                       dreal(GRyy(nord)), dimag(GRyy(nord))
         write(73,10,err=102) sngl(lambda),
     $                       dreal(GRzz(nord)), dimag(GRzz(nord))
         write(74,10,err=102) sngl(lambda),
     $                       dreal(GRxz(nord)), dimag(GRxz(nord))

         write(76,12,err=102) sngl(lambda),
     $      dreal(Kxx0), dimag(Kxx0),
     $      dreal(Kxx2), dimag(Kxx2),
     $      dreal(Kxx3), dimag(Kxx3),
     $      dreal(Kxx4), dimag(Kxx4),
     $      dreal(Kxx5), dimag(Kxx5),
     $      dreal(Kxx6), dimag(Kxx6),
     $      dreal(Kxx7), dimag(Kxx7)
         write(77,12,err=102) sngl(lambda),
     $      dreal(Kyy0), dimag(Kyy0),
     $      dreal(Kyy2), dimag(Kyy2),
     $      dreal(Kyy3), dimag(Kyy3),
     $      dreal(Kyy4), dimag(Kyy4),
     $      dreal(Kyy3), dimag(Kyy5),
     $      dreal(Kyy6), dimag(Kyy6),
     $      dreal(Kyy7), dimag(Kyy7)
         write(78,12,err=102) sngl(lambda),
     $      dreal(Kzz0), dimag(Kzz0),
     $      dreal(Kzz2), dimag(Kzz2),
     $      dreal(Kzz3), dimag(Kzz3),
     $      dreal(Kzz4), dimag(Kzz4),
     $      dreal(Kzz5), dimag(Kzz5),
     $      dreal(Kzz6), dimag(Kzz6),
     $      dreal(Kzz7), dimag(Kzz7)
         write(79,12,err=102) sngl(lambda),
     $      dreal(Kxz0), dimag(Kxz0),
     $      dreal(Kxz2), dimag(Kxz2),
     $      dreal(Kxz3), dimag(Kxz3),
     $      dreal(Kxz4), dimag(Kxz4),
     $      dreal(Kxz5), dimag(Kxz5),
     $      dreal(Kxz6), dimag(Kxz6),
     $      dreal(Kxz7), dimag(Kxz7)

      else

          write(*,*) 'Unexpected error 2; exiting'
          write(*,*) 'Please report this error to code developers'
          stop

      end if

c$$$  These lines to be used for debugging only
c$$$      write(*,*) '---------------------------------------------'
c$$$      write(*,*) 'XX:', dreal(GRxx(nord)), dimag(GRxx(nord))
c$$$      write(*,*) 'YY:', dreal(GRyy(nord)), dimag(GRyy(nord))
c$$$      write(*,*) 'ZZ:', dreal(GRzz(nord)), dimag(GRzz(nord))
c$$$      write(*,*) 'XZ:', dreal(GRxz(nord)), dimag(GRxz(nord))

 1    continue
      close(unit=71)
      close(unit=72)
      close(unit=73)
      close(unit=74)

      close(unit=76)
      close(unit=77)
      close(unit=78)
      close(unit=79)

      stop

 101  continue
      write(*,*) 'Error opening input file GF.par; exiting'
      stop

 102  continue
      write(*,*) 'Error opening an output file or writing data; exiting'
      stop

 2    format(a1)
 4    format(a3)
 6    format(3G16.7E3)
 8    format(15G16.7E3)
 10   format(G16.7E3,  2G23.14E3)
 12   format(G16.7E3, 14G23.14E3)

      end


    Program ztgevc_example

!     ZTGEVC Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use blas_interfaces, Only: dznrm2
      Use lapack_example_aux, Only: nagf_blas_zmload, &
        nagf_file_print_matrix_complex_gen_comp, &
        nagf_sort_cmplxvec_rank_rearrange, nagf_sort_realvec_rank
      Use lapack_interfaces, Only: zgeqrf, zggbak, zggbal, zgghrd, zhgeqz, &
        zlacpy, ztgevc, zungqr, zunmqr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Complex (Kind=dp), Parameter :: cone = (1.0E0_dp, 0.0E0_dp)
      Complex (Kind=dp), Parameter :: czero = (0.0E0_dp, 0.0E0_dp)
      Integer, Parameter :: nin = 5, nout = 6
      Logical, Parameter :: prbal = .False., prhess = .False.
!     .. Local Scalars ..
      Complex (Kind=dp) :: scal
      Integer :: i, icols, ifail, ihi, ilo, info, irows, j, jwork, k, lda, &
        ldb, ldvl, ldvr, lwork, m, n
      Logical :: ileft, iright
      Character (1) :: compq, compz, howmny, job, side
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        tau(:), v(:, :), vl(:, :), vr(:, :), work(:), zwork(:)
      Real (Kind=dp), Allocatable :: lscale(:), rscale(:), rwork(:)
      Integer, Allocatable :: irank(:)
      Logical, Allocatable :: select(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, aimag, all, cmplx, conjg, maxloc, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZTGEVC Example Program Results'
      Flush (nout)

!     ileft  is TRUE if left  eigenvectors are required
!     iright is TRUE if right eigenvectors are required

      ileft = .True.
      iright = .True.

!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      lda = n
      ldb = n
      ldvl = n
      ldvr = n
      lwork = 6*n
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), tau(n), vl(ldvl,ldvl), &
        vr(ldvr,ldvr), work(lwork), lscale(n), rscale(n), rwork(6*n), &
        select(n), irank(n), v(n,n))

!     READ matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, n)

!     READ matrix B from data file
      Read (nin, *)(b(i,1:n), i=1, n)

!     Balance matrix pair (A,B)
      job = 'B'
      Call zggbal(job, n, a, lda, b, ldb, ilo, ihi, lscale, rscale, rwork, &
        info)

      If (prbal) Then
!       Matrix A after balancing
!       ifail: behaviour on error exit
!               =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
          lda, 'Bracketed', 'F7.4', 'Matrix A after balancing', 'Integer', &
          rlabs, 'Integer', clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)

!       Matrix B after balancing
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
          ldb, 'Bracketed', 'F7.4', 'Matrix B after balancing', 'Integer', &
          rlabs, 'Integer', clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)
      End If

!     Reduce B to triangular form using QR
      irows = ihi + 1 - ilo
      icols = n + 1 - ilo
      Call zgeqrf(irows, icols, b(ilo,ilo), ldb, tau, work, lwork, info)

!     Apply the orthogonal transformation to A
      Call zunmqr('L', 'C', irows, icols, irows, b(ilo,ilo), ldb, tau, &
        a(ilo,ilo), lda, work, lwork, info)

!     Initialize VL (for left eigenvectors)
      If (ileft) Then

        Call nagf_blas_zmload('General', n, n, czero, cone, vl, ldvl)
        Call zlacpy('Lower', irows-1, irows-1, b(ilo+1,ilo), ldb, &
          vl(ilo+1,ilo), ldvl)
        Call zungqr(irows, irows, irows, vl(ilo,ilo), ldvl, tau, work, lwork, &
          info)

      End If

!     Initialize VR for right eigenvectors
      If (iright) Then
        Call nagf_blas_zmload('General', n, n, czero, cone, vr, ldvr)
      End If

!     Compute the generalized Hessenberg form of (A,B)
      compq = 'V'
      compz = 'V'
      Call zgghrd(compq, compz, n, ilo, ihi, a, lda, b, ldb, vl, ldvl, vr, &
        ldvr, info)

      If (prhess) Then
!       Matrix A in generalized Hessenberg form
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, a, &
          lda, 'Bracketed', 'F7.3', 'Matrix A in Hessenberg form', 'Integer', &
          rlabs, 'Integer', clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)

!       Matrix B in generalized Hessenberg form
        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, b, &
          ldb, 'Bracketed', 'F7.3', 'Matrix B in Hessenberg form', 'Integer', &
          rlabs, 'Integer', clabs, 80, 0, ifail)
        Write (nout, *)
        Flush (nout)
      End If

!     Routine ZHGEQZ
!     Workspace query: jwork = -1
      jwork = -1
      job = 'S'
      Call zhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, &
        vl, ldvl, vr, ldvr, work, jwork, rwork, info)

      lwork = nint(real(work(1)))
      Allocate (zwork(lwork))

!     Compute the generalized Schur form
      Call zhgeqz(job, compq, compz, n, ilo, ihi, a, lda, b, ldb, alpha, beta, &
        vl, ldvl, vr, ldvr, zwork, lwork, rwork, info)

!     Sort and print generalized eigenvalues if none are infinite.
      If (all(real(beta(1:n))>0.0_dp)) Then
!       Store absolute values of eigenvalues for ranking
        work(1:n) = alpha(1:n)/beta(1:n)
        rwork(1:n) = abs(work(1:n))

!       Rank eigenvalues
        ifail = 0
        Call nagf_sort_realvec_rank(rwork, 1, n, 'Descending', irank, ifail)

!       Sort eigenvalues in work(1:n)
        Call nagf_sort_cmplxvec_rank_rearrange(work, 1, n, irank, ifail)

        Write (nout, 100)
        Do i = 1, n
          Write (nout, 110) i, '(', real(work(i)), ',', aimag(work(i)), ')'
        End Do
        Write (nout, *)
        Flush (nout)
      Else
        irank(1:n) = (/ (i,i=1,n) /)
      End If

!     Compute left and right generalized eigenvectors
!     of the balanced matrix
      howmny = 'B'
      If (ileft .And. iright) Then
        side = 'B'
      Else If (ileft) Then
        side = 'L'
      Else If (iright) Then
        side = 'R'
      End If

      Call ztgevc(side, howmny, select, n, a, lda, b, ldb, vl, ldvl, vr, ldvr, &
        n, m, work, rwork, info)

!     Compute right eigenvectors of the original matrix

      If (iright) Then
        job = 'B'
        side = 'R'

        Call zggbak(job, side, n, ilo, ihi, lscale, rscale, n, vr, ldvr, info)

!       Normalize the right eigenvectors
        Do i = 1, n
          j = irank(i)
          rwork(1:n) = abs(vr(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(vr(k,i))/abs(vr(k,i))/dznrm2(n, vr(1,i), 1)
          v(1:n, j) = vr(1:n, i)*scal
          v(k, j) = cmplx(real(v(k,j)), kind=dp)
        End Do

!       Print the right eigenvectors

        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, v, &
          n, 'Bracketed', 'F7.4', 'Right eigenvectors', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

        Write (nout, *)
        Flush (nout)

      End If

!     Compute left eigenvectors of the original matrix

      If (ileft) Then
        job = 'B'
        side = 'L'

        Call zggbak(job, side, n, ilo, ihi, lscale, rscale, n, vl, ldvl, info)

!       Normalize the left eigenvectors
        Do i = 1, n
          j = irank(i)
          rwork(1:n) = abs(vl(1:n,i))
          k = maxloc(rwork(1:n), 1)
          scal = conjg(vl(k,i))/abs(vl(k,i))/dznrm2(n, vl(1,i), 1)
          v(1:n, j) = vl(1:n, i)*scal
          v(k, j) = cmplx(real(v(k,j)), kind=dp)
        End Do

!       Print the left eigenvectors

        ifail = 0
        Call nagf_file_print_matrix_complex_gen_comp('General', ' ', n, n, v, &
          n, 'Bracketed', 'F7.4', 'Left eigenvectors', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

      End If

100   Format (1X, /, 1X, 'Generalized eigenvalues')
110   Format (1X, I4, 5X, A, F7.3, A, F7.3, A)
    End Program


C     PROGRAM No. 9: CONSTANT STRENGTH SOURCE/DOUBLET POTENTIAL
C     ---------------------------------------------------------
C     THIS PROGRAM FINDS THE PRESSURE DISTRIBUTION ON AN ARBITRARY AIRFOIL
C     BY REPRESENTING THE SURFACE AS A FINITE NUMBER OF SOURCE/DOUBLET PANELS
C     WITH CONSTANT STRENGTH (DIRICHLET B.C., PROGRAM BY STEVEN YON, 1989).

      REAL EP(400,2),PT1(400,2),PT2(400,2),TH(400)
      REAL CO(400,2),A(400,400),B(400,400),G(400)
      REAL EPT(400,2),SIG(400),PHI(400),DL(400)

      OPEN(8,FILE='CPSD.DAT',STATUS='NEW')
      OPEN(9,FILE='AFOIL2.DAT',STATUS='OLD')

      WRITE(6,*) 'ENTER NUMBER OF PANELS'
      READ(5,*) M
      N=M+1
      WRITE(6,*) 'ENTER ANGLE OF ATTACK IN DEGREES'
      READ(5,*) ALPHA
      AL=ALPHA/57.2958

C     READ IN THE PANEL END POINTS
      DO I=1,M+1
      READ(9,*) EPT(I,1), EPT(I,2)
      END DO

C     CONVERT PANELING TO CLOCKWISE
      DO I=1,M+1
      EP(I,1)=EPT(N-I+1,1)
      EP(I,2)=EPT(N-I+1,2)
      END DO

C     ESTABLISH COORDINATES OF PANEL END POINTS
      DO I=1,M
      PT1(I,1)=EP(I,1)
      PT2(I,1)=EP(I+1,1)
      PT1(I,2)=EP(I,2)
      PT2(I,2)=EP(I+1,2)
      END DO

C     FIND PANEL ANGLES TH(J)
      DO I=1,M
      DZ=PT2(I,2)-PT1(I,2)
      DX=PT2(I,1)-PT1(I,1)
      TH(I)=ATAN2(DZ,DX)
      END DO

C     ESTABLISH SOURCE STRENGTHS (SIGMA=V DOT N)
      DO I=1,M
      SIG(I)=(COS(AL)*SIN(TH(I))-SIN(AL)*COS(TH(I)))
      END DO

C     ESTABLISH SURFACE POINTS (COLLOCATION POINTS)
      DO I=1,M
      CO(I,1)=(PT2(I,1)-PT1(I,1))/2+PT1(I,1)
      CO(I,2)=(PT2(I,2)-PT1(I,2))/2+PT1(I,2)
      END DO

C     ESTABLISH INFLUENCE COEFFICIENTS
      DO I=1,M
      TEMP=0
      DO J=1,M

C     CONVERT THE COLLOCATION POINT TO LOCAL PANEL COORDS.
      XT=CO(I,1)-PT1(J,1)
      ZT=CO(I,2)-PT1(J,2)
      X2T=PT2(J,1)-PT1(J,1)
      Z2T=PT2(J,2)-PT1(J,2)

      X=XT*COS(TH(J))+ZT*SIN(TH(J))
      Z=-XT*SIN(TH(J))+ZT*COS(TH(J))
      X2=X2T*COS(TH(J))+Z2T*SIN(TH(J))
      Z2=0

C     SAVE PANEL LENGTHS
      IF(I.EQ.1) THEN
      DL(J)=X2
      END IF

C     COMPUTE R AND THETA VALUES FOR THE COLOC. POINT
      R1=SQRT(X**2+Z**2)
      R2=SQRT((X-X2)**2+Z**2)

      TH1=ATAN2(Z,X)
      TH2=ATAN2(Z,X-X2)

C     COMPUTE THE DOUBLET INFLUENCE COEFFICIENTS
      IF(I.EQ.J) THEN
       A(I,J)=0.5
      ELSE
       A(I,J)=-0.15916*(TH2-TH1)
      END IF

C     COMPUTE THE SOURCE INFLUENCE COEFF'S AND ADD
C     THEM UP TO GIVE THE RHS
      IF(I.EQ.J) THEN
       TEMP=TEMP+SIG(J)/3.14159265*(X*LOG(R1))
      ELSE
       TEMP=TEMP+SIG(J)/6.28319*(X*LOG(R1)
     *        -(X-X2)*LOG(R2)+Z*(TH2-TH1))
      END IF

      END DO

C     ADD WAKE INFLUENCE COEFF.
       XW=CO(I,1)-PT2(M,1)
       ZW=CO(I,2)-PT2(M,2)
       DTHW=-ATAN(ZW/XW)

       A(I,N)=-0.15916*(DTHW)
       A(I,N+1)=TEMP

      END DO

C     ADD AN EXPLICIT KUTTA CONDITION
      DO I=1,N+1
       A(N,I)=0
      END DO
       A(N,1)=-1
       A(N,M)=1
       A(N,N)=-1
C     SOLVE FOR THE SOLUTION VECTOR OF DOUBLET STRENGTHS
      N=N+1

      CALL MATRX(A,N,G)

C     CONVERT DOUBLET STRENGTHS INTO TANGENTIAL
C     VELOCITIES ALONG THE AIRFOIL SURFACE AND CP'S
C     ON EACH PANEL.

 200   CONTINUE

      DO I=1,M
       PHI(I)=CO(I,1)*COS(AL)+CO(I,2)*SIN(AL)+G(I)
      END DO

      DO I=1,M-1
       R=(DL(I+1)+DL(I))/2
       VEL=(PHI(I)-PHI(I+1))/R
       CP=1-VEL**2
       WRITE(8,*) PT2(I,1),', ',CP
      END DO

      WRITE(6,*) ' '
      WRITE(6,*) 'LIFT COEFFICIENT=',G(M+1)

      STOP
      END

      SUBROUTINE MATRX(A,N,G)
C     MATRX IS A MATRIX REDUCER OF THE GAUSSIAN TYPE
C     A(I,J) IS THE MATRIX, A(I,N) IS THE RHS VECTOR
C     AND G(I) IS THE SOLUTION VECTOR.
      REAL A(400,400),TEMP(400,400),G(400)
C     INITIALIZE THE G VECTOR TO ALL ZEROES
      DO I=1,N-1
       G(I)=0
      END DO

C     CONVERT COEFFICIENT MATRIX TO
C     UPPER TRIANGULAR FORM
      DO I=1,N-1
 5     IF(ABS(A(I,I)).LT.0.0000001) GOTO 9

       P=A(I,I)
       DO J=I,N
        A(I,J)=A(I,J)/P
       END DO
       DO K=I+1,N-1
        P2=A(K,I)
        DO L=I,N
         A(K,L)=A(K,L)-P2*A(I,L)
        END DO
       END DO
      END DO

C     BACK SUBSTITUTE TRIANGULARIZED MATRIX TO GET
C     VALUES OF SOLUTION VECTOR
      DO I=N-1,1,-1
       G(I)=A(I,N)
       DO J=1,N-1
        A(I,I)=0
        G(I)=G(I)-A(I,J)*G(J)
       END DO
      END DO
      RETURN

C     ORDER MATRIX SO THAT DIAGONAL COEFFICIENTS ARE
C     NOT =0 AND STOP IS MATRIX IS SINGULAR
 9    IF(I.NE.N-1) THEN
       DO J=1,N
        TEMP(I,J)=A(I,J)
        A(I,J)=A(I+1,J)
        A(I+1,J)=TEMP(I,J)
       END DO
       GOTO 5
      ELSE
       GOTO 10
      END IF

 10   WRITE(6,*) 'NO SOLUTION'
      STOP
      END


MODULE gquadrature

implicit none

CONTAINS
!
!----------------------------------------------------------------------------
!
subroutine rutope(ndimn, ngaus, posgp, weigp)

integer, intent(in) :: ndimn, ngaus
real*8 :: posgp(ndimn,*), weigp(*)
!
!     This routine sets up the integration constants of open rules for
!     triangles and tetrahedra
!
!     NDIMN = 1             NDIME = 2             NDIME = 3
!
!     NGAUS  EXACT POL.    NGAUS  EXACT POL.     NGAUS  EXACT POL.
!     -----  ---------     -----  ----------     -----  ----------
!         1         p1         1       p1            1       p1
!         2         p3         3       p2            4       p2
!         3         p5         4       p3            5       p3
!                              6       p4           11       p4
!                              7       p5           14       p5
!                             13       p9
!
!...  Line integral (the same as for brick elements)
!
  if(ngaus .eq. 1) then
    posgp(1,1) = 0.0
    weigp(  1) = 2.0
  else if(ngaus .eq. 2) then
    posgp(1,1) =-0.577350269189626
    posgp(1,2) = 0.577350269189626
    weigp(  1) = 1.0
    weigp(  2) = 1.0
  else if(ngaus .eq. 3) then
    posgp(1,1) =-0.774596669241483
    posgp(1,2) = 0.0
    posgp(1,3) = 0.774596669241483
    weigp(  1) = 0.555555555555556
    weigp(  2) = 0.888888888888889
    weigp(  3) = 0.555555555555556
  else
    write(*,*) "Quadrature unavailable for number of points:", ngaus
  end if

end subroutine rutope

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

END MODULE gquadrature