*DECK LLSIA
      SUBROUTINE LLSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP,
     +   KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO)
C***BEGIN PROLOGUE  LLSIA
C***PURPOSE  Solve a linear least squares problems by performing a QR
C            factorization of the matrix using Householder
C            transformations.  Emphasis is put on detecting possible
C            rank deficiency.
C***LIBRARY   SLATEC
C***CATEGORY  D9, D5
C***TYPE      SINGLE PRECISION (LLSIA-S, DLLSIA-D)
C***KEYWORDS  LINEAR LEAST SQUARES, QR FACTORIZATION
C***AUTHOR  Manteuffel, T. A., (LANL)
C***DESCRIPTION
C
C     LLSIA computes the least squares solution(s) to the problem AX=B
C     where A is an M by N matrix with M.GE.N and B is the M by NB
C     matrix of right hand sides.  User input bounds on the uncertainty
C     in the elements of A are used to detect numerical rank deficiency.
C     The algorithm employs a row and column pivot strategy to
C     minimize the growth of uncertainty and round-off errors.
C
C     LLSIA requires (MDA+6)*N + (MDB+1)*NB + M dimensioned space
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - All input arrays are changed on exit.        *
C   *                                                                *
C   ******************************************************************
C     SUBROUTINE LLSIA(A,MDA,M,N,B,MDB,NB,RE,AE,KEY,MODE,NP,
C    1   KRANK,KSURE,RNORM,W,LW,IWORK,LIW,INFO)
C
C     Input..
C
C     A(,)          Linear coefficient matrix of AX=B, with MDA the
C      MDA,M,N      actual first dimension of A in the calling program.
C                   M is the row dimension (no. of EQUATIONS of the
C                   problem) and N the col dimension (no. of UNKNOWNS).
C                   Must have MDA.GE.M and M.GE.N.
C
C     B(,)          Right hand side(s), with MDB the actual first
C      MDB,NB       dimension of B in the calling program. NB is the
C                   number of M by 1 right hand sides. Must have
C                   MDB.GE.M. If NB = 0, B is never accessed.
C
C   ******************************************************************
C   *                                                                *
C   *         Note - Use of RE and AE are what make this             *
C   *                code significantly different from               *
C   *                other linear least squares solvers.             *
C   *                However, the inexperienced user is              *
C   *                advised to set RE=0.,AE=0.,KEY=0.               *
C   *                                                                *
C   ******************************************************************
C     RE(),AE(),KEY
C     RE()          RE() is a vector of length N such that RE(I) is
C                   the maximum relative uncertainty in column I of
C                   the matrix A. The values of RE() must be between
C                   0 and 1. A minimum of 10*machine precision will
C                   be enforced.
C
C     AE()          AE() is a vector of length N such that AE(I) is
C                   the maximum absolute uncertainty in column I of
C                   the matrix A. The values of AE() must be greater
C                   than or equal to 0.
C
C     KEY           For ease of use, RE and AE may be input as either
C                   vectors or scalars. If a scalar is input, the algo-
C                   rithm will use that value for each column of A.
C                   The parameter key indicates whether scalars or
C                   vectors are being input.
C                        KEY=0     RE scalar  AE scalar
C                        KEY=1     RE vector  AE scalar
C                        KEY=2     RE scalar  AE vector
C                        KEY=3     RE vector  AE vector
C
C     MODE          The integer mode indicates how the routine
C                   is to react if rank deficiency is detected.
C                   If MODE = 0 return immediately, no solution
C                             1 compute truncated solution
C                             2 compute minimal length solution
C                   The inexperienced user is advised to set MODE=0
C
C     NP            The first NP columns of A will not be interchanged
C                   with other columns even though the pivot strategy
C                   would suggest otherwise.
C                   The inexperienced user is advised to set NP=0.
C
C     WORK()        A real work array dimensioned 5*N.  However, if
C                   RE or AE have been specified as vectors, dimension
C                   WORK 4*N. If both RE and AE have been specified
C                   as vectors, dimension WORK 3*N.
C
C     LW            Actual dimension of WORK
C
C     IWORK()       Integer work array dimensioned at least N+M.
C
C     LIW           Actual dimension of IWORK.
C
C     INFO          Is a flag which provides for the efficient
C                   solution of subsequent problems involving the
C                   same A but different B.
C                   If INFO = 0 original call
C                      INFO = 1 subsequent calls
C                   On subsequent calls, the user must supply A, KRANK,
C                   LW, IWORK, LIW, and the first 2*N locations of WORK
C                   as output by the original call to LLSIA. MODE must
C                   be equal to the value of MODE in the original call.
C                   If MODE.LT.2, only the first N locations of WORK
C                   are accessed. AE, RE, KEY, and NP are not accessed.
C
C     Output..
C
C     A(,)          Contains the upper triangular part of the reduced
C                   matrix and the transformation information. It togeth
C                   with the first N elements of WORK (see below)
C                   completely specify the QR factorization of A.
C
C     B(,)          Contains the N by NB solution matrix for X.
C
C     KRANK,KSURE   The numerical rank of A,  based upon the relative
C                   and absolute bounds on uncertainty, is bounded
C                   above by KRANK and below by KSURE. The algorithm
C                   returns a solution based on KRANK. KSURE provides
C                   an indication of the precision of the rank.
C
C     RNORM()       Contains the Euclidean length of the NB residual
C                   vectors  B(I)-AX(I), I=1,NB.
C
C     WORK()        The first N locations of WORK contain values
C                   necessary to reproduce the Householder
C                   transformation.
C
C     IWORK()       The first N locations contain the order in
C                   which the columns of A were used. The next
C                   M locations contain the order in which the
C                   rows of A were used.
C
C     INFO          Flag to indicate status of computation on completion
C                  -1   Parameter error(s)
C                   0 - Rank deficient, no solution
C                   1 - Rank deficient, truncated solution
C                   2 - Rank deficient, minimal length solution
C                   3 - Numerical rank 0, zero solution
C                   4 - Rank .LT. NP
C                   5 - Full rank
C
C***REFERENCES  T. Manteuffel, An interval analysis approach to rank
C                 determination in linear least squares problems,
C                 Report SAND80-0655, Sandia Laboratories, June 1980.
C***ROUTINES CALLED  R1MACH, U11LS, U12LS, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810801  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Fixed an error message.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  LLSIA
      DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*)
      INTEGER IWORK(*)
C
C***FIRST EXECUTABLE STATEMENT  LLSIA
      IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514
      IT=INFO
      INFO=-1
      IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501
      IF(M.LT.1) GO TO 502
      IF(N.LT.1) GO TO 503
      IF(N.GT.M) GO TO 504
      IF(MDA.LT.M) GO TO 505
      IF(LIW.LT.M+N) GO TO 506
      IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515
      IF(NB.EQ.0) GO TO 4
      IF(NB.LT.0) GO TO 507
      IF(MDB.LT.M) GO TO 508
      IF(IT.EQ.0) GO TO 4
      GO TO 400
    4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509
      IF(KEY.EQ.0 .AND. LW.LT.5*N) GO TO 510
      IF(KEY.EQ.1 .AND. LW.LT.4*N) GO TO 510
      IF(KEY.EQ.2 .AND. LW.LT.4*N) GO TO 510
      IF(KEY.EQ.3 .AND. LW.LT.3*N) GO TO 510
      IF(NP.LT.0 .OR. NP.GT.N) GO TO 516
C
      EPS=10.*R1MACH(4)
      N1=1
      N2=N1+N
      N3=N2+N
      N4=N3+N
      N5=N4+N
C
      IF(KEY.EQ.1) GO TO 100
      IF(KEY.EQ.2) GO TO 200
      IF(KEY.EQ.3) GO TO 300
C
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      IF(AE(1).LT.0.0) GO TO 513
      DO 20 I=1,N
      W(N4-1+I)=RE(1)
      W(N5-1+I)=AE(1)
   20 CONTINUE
      CALL U11LS(A,MDA,M,N,W(N4),W(N5),MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  100 CONTINUE
      IF(AE(1).LT.0.0) GO TO 513
      DO 120 I=1,N
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      W(N4-1+I)=AE(1)
  120 CONTINUE
      CALL U11LS(A,MDA,M,N,RE,W(N4),MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  200 CONTINUE
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      DO 220 I=1,N
      W(N4-1+I)=RE(1)
      IF(AE(I).LT.0.0) GO TO 513
  220 CONTINUE
      CALL U11LS(A,MDA,M,N,W(N4),AE,MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
      GO TO 400
C
  300 CONTINUE
      DO 320 I=1,N
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      IF(AE(I).LT.0.0) GO TO 513
  320 CONTINUE
      CALL U11LS(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE,
     1            W(N1),W(N2),W(N3),IWORK(N1),IWORK(N2))
C
C     DETERMINE INFO
C
  400 IF(KRANK.NE.N) GO TO 402
          INFO=5
          GO TO 410
  402 IF(KRANK.NE.0) GO TO 404
          INFO=3
          GO TO 410
  404 IF(KRANK.GE.NP) GO TO 406
          INFO=4
          RETURN
  406 INFO=MODE
      IF(MODE.EQ.0) RETURN
  410 IF(NB.EQ.0) RETURN
C
C     SOLUTION PHASE
C
      N1=1
      N2=N1+N
      N3=N2+N
      IF(INFO.EQ.2) GO TO 420
      IF(LW.LT.N2-1) GO TO 510
      CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(N1),W(N1),IWORK(N1),IWORK(N2))
      RETURN
C
  420 IF(LW.LT.N3-1) GO TO 510
      CALL U12LS(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(N1),W(N2),IWORK(N1),IWORK(N2))
      RETURN
C
C     ERROR MESSAGES
C
  501 CALL XERMSG ('SLATEC', 'LLSIA',
     +   'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0)
      RETURN
  502 CALL XERMSG ('SLATEC', 'LLSIA', 'M.LT.1', 2, 1)
      RETURN
  503 CALL XERMSG ('SLATEC', 'LLSIA', 'N.LT.1', 2, 1)
      RETURN
  504 CALL XERMSG ('SLATEC', 'LLSIA', 'N.GT.M', 2, 1)
      RETURN
  505 CALL XERMSG ('SLATEC', 'LLSIA', 'MDA.LT.M', 2, 1)
      RETURN
  506 CALL XERMSG ('SLATEC', 'LLSIA', 'LIW.LT.M+N', 2, 1)
      RETURN
  507 CALL XERMSG ('SLATEC', 'LLSIA', 'NB.LT.0', 2, 1)
      RETURN
  508 CALL XERMSG ('SLATEC', 'LLSIA', 'MDB.LT.M', 2, 1)
      RETURN
  509 CALL XERMSG ('SLATEC', 'LLSIA', 'KEY OUT OF RANGE', 2, 1)
      RETURN
  510 CALL XERMSG ('SLATEC', 'LLSIA', 'INSUFFICIENT WORK SPACE', 8, 1)
      INFO=-1
      RETURN
  511 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .LT. 0', 2, 1)
      RETURN
  512 CALL XERMSG ('SLATEC', 'LLSIA', 'RE(I) .GT. 1', 2, 1)
      RETURN
  513 CALL XERMSG ('SLATEC', 'LLSIA', 'AE(I) .LT. 0', 2, 1)
      RETURN
  514 CALL XERMSG ('SLATEC', 'LLSIA', 'INFO OUT OF RANGE', 2, 1)
      RETURN
  515 CALL XERMSG ('SLATEC', 'LLSIA', 'MODE OUT OF RANGE', 2, 1)
      RETURN
  516 CALL XERMSG ('SLATEC', 'LLSIA', 'NP OUT OF RANGE', 2, 1)
      RETURN
      END


      DOUBLE PRECISION FUNCTION DT_RM2(Amlo2,Amhi2,Q2)

      IMPLICIT NONE
      DOUBLE PRECISION Amhi2 , Amlo2 , GEV2MB , ONE , PI , Q2 , TINY10 ,
     &                 tmpmhi , tmpmlo , TWO , TWOPI , ZERO
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,TINY10=1.0D-10,ONE=1.0D0,TWO=2.0D0)
      PARAMETER (TWOPI=6.283185307179586476925286766559D+00,
     &           PI=TWOPI/TWO,GEV2MB=0.38938D0)
C VDM parameter for photon-nucleus interactions
      INCLUDE 'inc/dtvdmp'

      IF ( RL2.LE.ZERO ) THEN
         DT_RM2 = -ONE/(Amhi2+Q2) + Q2/(TWO*(Amhi2+Q2)**2)
     &            - (-ONE/(Amlo2+Q2)+Q2/(TWO*(Amlo2+Q2)**2))
     &            + EPSpol*(-Q2/(TWO*(Amhi2+Q2)**2)
     &            +Q2/(TWO*(Amlo2+Q2)**2))
      ELSE
         tmpmlo = LOG(ONE+RL2/(Amlo2+Q2))
         tmpmhi = LOG(ONE+RL2/(Amhi2+Q2))
         DT_RM2 = Q2/(RL2*(Amhi2+Q2)) - (Q2+RL2)/RL2**2*tmpmhi -
     &            (Q2/(RL2*(Amlo2+Q2))-(Q2+RL2)/RL2**2*tmpmlo)
     &            + EPSpol*(-Q2/(RL2*(Amhi2+Q2))+Q2/RL2**2*tmpmhi-
     &            (-Q2/(RL2*(Amlo2+Q2))+Q2/RL2**2*tmpmlo))
      END IF

      END FUNCTION


!*==zlacn2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZLACN2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE )
!
!       .. Scalar Arguments ..
!       INTEGER            KASE, N
!       DOUBLE PRECISION   EST
!       ..
!       .. Array Arguments ..
!       INTEGER            ISAVE( 3 )
!       COMPLEX*16         V( * ), X( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZLACN2 estimates the 1-norm of a square, complex matrix A.
!> Reverse communication is used for evaluating matrix-vector products.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>         The order of the matrix.  N >= 1.
!> \endverbatim
!>
!> \param[out] V
!> \verbatim
!>          V is COMPLEX*16 array, dimension (N)
!>         On the final return, V = A*W,  where  EST = norm(V)/norm(W)
!>         (W is not returned).
!> \endverbatim
!>
!> \param[in,out] X
!> \verbatim
!>          X is COMPLEX*16 array, dimension (N)
!>         On an intermediate return, X should be overwritten by
!>               A * X,   if KASE=1,
!>               A**H * X,  if KASE=2,
!>         where A**H is the conjugate transpose of A, and ZLACN2 must be
!>         re-called with all the other parameters unchanged.
!> \endverbatim
!>
!> \param[in,out] EST
!> \verbatim
!>          EST is DOUBLE PRECISION
!>         On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
!>         unchanged from the previous call to ZLACN2.
!>         On exit, EST is an estimate (a lower bound) for norm(A).
!> \endverbatim
!>
!> \param[in,out] KASE
!> \verbatim
!>          KASE is INTEGER
!>         On the initial call to ZLACN2, KASE should be 0.
!>         On an intermediate return, KASE will be 1 or 2, indicating
!>         whether X should be overwritten by A * X  or A**H * X.
!>         On the final return from ZLACN2, KASE will again be 0.
!> \endverbatim
!>
!> \param[in,out] ISAVE
!> \verbatim
!>          ISAVE is INTEGER array, dimension (3)
!>         ISAVE is used to save variables between calls to ZLACN2
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complex16OTHERauxiliary
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  Originally named CONEST, dated March 16, 1988.
!>
!>  Last modified:  April, 1999
!>
!>  This is a thread safe version of ZLACON, which uses the array ISAVE
!>  in place of a SAVE statement, as follows:
!>
!>     ZLACON     ZLACN2
!>      JUMP     ISAVE(1)
!>      J        ISAVE(2)
!>      ITER     ISAVE(3)
!> \endverbatim
!
!> \par Contributors:
!  ==================
!>
!>     Nick Higham, University of Manchester
!
!> \par References:
!  ================
!>
!>  N.J. Higham, "FORTRAN codes for estimating the one-norm of
!>  a real or complex matrix, with applications to condition estimation",
!>  ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
!>
!  =====================================================================
      SUBROUTINE ZLACN2(N,V,X,Est,Kase,Isave)
      IMPLICIT NONE
!*--ZLACN2137
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Kase , N
      DOUBLE PRECISION Est
!     ..
!     .. Array Arguments ..
      INTEGER Isave(3)
      COMPLEX*16 V(*) , X(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      INTEGER ITMAX
      PARAMETER (ITMAX=5)
      DOUBLE PRECISION ONE , TWO
      PARAMETER (ONE=1.0D0,TWO=2.0D0)
      COMPLEX*16 CZERO , CONE
      PARAMETER (CZERO=(0.0D0,0.0D0),CONE=(1.0D0,0.0D0))
!     ..
!     .. Local Scalars ..
      INTEGER i , jlast
      DOUBLE PRECISION absxi , altsgn , estold , safmin , temp
!     ..
!     .. External Functions ..
      INTEGER IZMAX1
      DOUBLE PRECISION DLAMCH , DZSUM1
      EXTERNAL IZMAX1 , DLAMCH , DZSUM1
!     ..
!     .. External Subroutines ..
      EXTERNAL ZCOPY
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , DBLE , DCMPLX , DIMAG
!     ..
!     .. Executable Statements ..
!
      safmin = DLAMCH('Safe minimum')
      IF ( Kase==0 ) THEN
         DO i = 1 , N
            X(i) = DCMPLX(ONE/DBLE(N))
         ENDDO
         Kase = 1
         Isave(1) = 1
         RETURN
      ENDIF
!
      IF ( Isave(1)==2 ) THEN
!
!     ................ ENTRY   (ISAVE( 1 ) = 2)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
         Isave(2) = IZMAX1(N,X,1)
         Isave(3) = 2
      ELSEIF ( Isave(1)==3 ) THEN
!
!     ................ ENTRY   (ISAVE( 1 ) = 3)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
         CALL ZCOPY(N,X,1,V,1)
         estold = Est
         Est = DZSUM1(N,V,1)
!
!     TEST FOR CYCLING.
         IF ( Est<=estold ) GOTO 200
!
         DO i = 1 , N
            absxi = ABS(X(i))
            IF ( absxi>safmin ) THEN
               X(i) = DCMPLX(DBLE(X(i))/absxi,DIMAG(X(i))/absxi)
            ELSE
               X(i) = CONE
            ENDIF
         ENDDO
         Kase = 2
         Isave(1) = 4
         RETURN
      ELSEIF ( Isave(1)==4 ) THEN
!
!     ................ ENTRY   (ISAVE( 1 ) = 4)
!     X HAS BEEN OVERWRITTEN BY CTRANS(A)*X.
!
         jlast = Isave(2)
         Isave(2) = IZMAX1(N,X,1)
         IF ( (ABS(X(jlast))/=ABS(X(Isave(2)))) .AND. (Isave(3)<ITMAX) )&
     &        THEN
            Isave(3) = Isave(3) + 1
            GOTO 100
         ENDIF
         GOTO 200
      ELSEIF ( Isave(1)==5 ) THEN
!
!     ................ ENTRY   (ISAVE( 1 ) = 5)
!     X HAS BEEN OVERWRITTEN BY A*X.
!
         temp = TWO*(DZSUM1(N,X,1)/DBLE(3*N))
         IF ( temp>Est ) THEN
            CALL ZCOPY(N,X,1,V,1)
            Est = temp
         ENDIF
!
         Kase = 0
         GOTO 99999
      ELSE
!
!     ................ ENTRY   (ISAVE( 1 ) = 1)
!     FIRST ITERATION.  X HAS BEEN OVERWRITTEN BY A*X.
!
         IF ( N==1 ) THEN
            V(1) = X(1)
            Est = ABS(V(1))
!        ... QUIT
            Kase = 0
            GOTO 99999
         ENDIF
         Est = DZSUM1(N,X,1)
!
         DO i = 1 , N
            absxi = ABS(X(i))
            IF ( absxi>safmin ) THEN
               X(i) = DCMPLX(DBLE(X(i))/absxi,DIMAG(X(i))/absxi)
            ELSE
               X(i) = CONE
            ENDIF
         ENDDO
         Kase = 2
         Isave(1) = 2
         RETURN
      ENDIF
!
!     MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
!
 100  DO i = 1 , N
         X(i) = CZERO
      ENDDO
      X(Isave(2)) = CONE
      Kase = 1
      Isave(1) = 3
      RETURN
!
!     ITERATION COMPLETE.  FINAL STAGE.
!
 200  altsgn = ONE
      DO i = 1 , N
         X(i) = DCMPLX(altsgn*(ONE+DBLE(i-1)/DBLE(N-1)))
         altsgn = -altsgn
      ENDDO
      Kase = 1
      Isave(1) = 5
      RETURN
!
!     End of ZLACN2
!
99999 END SUBROUTINE ZLACN2


! Program to test WHERE inside FORALL and the WHERE assignment need temporary
program where_6
   integer :: A(5,5)

   A(1,:) = (/1,0,0,0,0/)
   A(2,:) = (/2,1,1,1,0/)
   A(3,:) = (/1,2,2,0,2/)
   A(4,:) = (/2,1,0,2,3/)
   A(5,:) = (/1,0,0,0,0/)

   ! Where inside FORALL.
   ! WHERE masks must be evaluated before executing the assignments
   m=5
   forall (I=1:4)
      where (A(I,:) .EQ. 0)
         A(1:m,I) = A(1:m,I+1) + I
      elsewhere (A(I,:) >2)
         A(I,1:m) = 6
      endwhere
   end forall
   if (any (A .ne. reshape ((/1,2,6,2,1,0,1,2,1,2,0,1,2,5,0,0,1,6,2,0,0,0,2,&
                             6,0/), (/5, 5/)))) call abort
end


PROGRAM Test_CosFilter
  USE Type_Kinds          , ONLY: fp=>fp_kind
  USE File_Utility        , ONLY: Get_Lun
  USE Message_Handler     , ONLY: SUCCESS
  USE FFT_Spectral_Utility, ONLY: CosFilter
  IMPLICIT NONE

  INTEGER,  PARAMETER :: N = 1000
  REAL(fp), PARAMETER :: dF = 0.1_fp
  REAL(fp), PARAMETER :: FBEGIN1 = 500.0_fp
  REAL(fp), PARAMETER :: FBEGIN2 = 3500.0_fp

  INTEGER :: i, ierr1, ierr2, fileId
  REAL(fp), DIMENSION(N) :: f, f1, f2
  REAL(fp), DIMENSION(N) :: filter1, filter2

  ! Create frequency arrays
  f = (/ (i,i=0,N-1) /)
  f1 = FBEGIN1 + (f*dF)
  f2 = FBEGIN2 + (f*dF)

  ! Call the function
  ierr1=CosFilter(f1, filter1)
  ierr2=CosFilter(f2, filter2, Reverse=1)
  IF ( ierr1 /= SUCCESS .OR. ierr2 /= SUCCESS ) STOP

  ! Output an ASCII file for viewing results
  fileId=Get_Lun()
  OPEN(fileId,FILE='Test_CosFilter.dat',STATUS='UNKNOWN')
  WRITE(fileId,*) N
  DO i=1, N
    WRITE(fileId,*) f1(i), filter1(i)
  END DO
  DO i=1, N
    WRITE(fileId,*) f2(i), filter2(i)
  END DO
  CLOSE(fileId)

END PROGRAM Test_CosFilter


!##############################################################################
!# Tutorial 006h: Discretise with Q1, manually visualise a function
!##############################################################################

module tutorial006h

  ! Include basic Feat-2 modules
  use fsystem
  use storage
  use genoutput

  use triangulation
  use meshgeneration

  use element
  use spatialdiscretisation
  use linearsystemscalar
  use bilinearformevaluation

  use matrixio
  use vectorio
  use ucd

  implicit none
  private

  public :: start_tutorial006h

contains

  ! ***************************************************************************

  subroutine start_tutorial006h

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialdiscretisation) :: rdiscretisation
    type(t_vectorScalar) :: rx
    type(t_ucdExport) :: rexport
    character(LEN=SYS_STRLEN) :: spostdir

    integer :: ivt
    real(DP) :: dx,dy
    real(DP), dimension(:,:), pointer :: p_DvertexCoords
    real(DP), dimension(:), pointer :: p_Ddata

    ! Print a message
    call output_lbrk()
    call output_separator (OU_SEP_STAR)
    call output_line ("This is FEAT-2. Tutorial 006h")
    call output_separator (OU_SEP_MINUS)

    ! =================================
    ! Create a brick mesh
    ! =================================

    ! The mesh must always be in "standard" format.
    ! First create a 5x5-mesh on [0,1]x[0,1], then convert to standard.
    call meshgen_rectangular2DQuadMesh (rtriangulation, 0.0_DP, 1.0_DP, 0.0_DP, 1.0_DP, 4, 4)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rdiscretisation
    ! which describes the discretisation.
    ! =================================

    call spdiscr_initDiscr_simple (rdiscretisation,EL_Q1_2D,rtriangulation)

    ! =================================
    ! Create a scalar vector.
    ! =================================

    ! Create a vector.
    call lsyssc_createVector (rdiscretisation,rx)

    ! =================================
    ! Fill the vector with data.
    ! =================================

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx,p_Ddata)

    ! Get a pointer to the point coordinates.
    call storage_getbase_double2d (rtriangulation%h_DvertexCoords,p_DvertexCoords)

    ! Set the entries of the vector according to the function
    !    u(x,y) = x^2 * y^2
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      dy = p_DvertexCoords(2,ivt)
      p_Ddata(ivt) = dx**2 * dy**2
    end do

    ! =================================
    ! Write a VTK file with the mesh
    ! and this solution vector.
    ! =================================

    if (sys_getenv_string("POSTDIR",spostdir)) then
      call output_line ("Writing file "//trim(spostdir)//"'/tutorial006h.vtk'.")

      ! Open
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         trim(spostdir)//"/tutorial006h.vtk")
    else
      call output_line ("Writing file './post/tutorial006h.vtk'.")

      ! Open
      call ucd_startVTK (rexport,UCD_FLAG_STANDARD,rtriangulation,&
                         "./post/tutorial006h.vtk")
    end if

    ! Pass the vector as solution.
    call ucd_addVectorByVertex (rexport, "x", UCD_VAR_STANDARD, rx)

    ! Write / close
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! =================================
    ! Cleanup
    ! =================================

    ! Release the vector
    call lsyssc_releaseVector (rx)

    ! Release the Q1-discretisation
    call spdiscr_releaseDiscr (rdiscretisation)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


      subroutine elmdd(aphi,el,elp,elpp,fxi,ijz,qpit75)
c
c     This subroutine calculates the E-lambda function (el) and its
c     first two derivatives (elp and elpp) with respect to ionic
c     strength (fxi) for the charge pair product ijz. The E-lambda
c     function and its derivatives are used to evaluate Pitzer's
c     equations. Here aphi is the Debye-Huckel A(phi) parameter.
c
c     Note: el = elp = elpp = 0 if ijz is less than or equal to 0.
c
c     This subroutine is called by:
c
c       EQLIBG/gelam.f.
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       aphi   = Debye-Huckel A(phi) parameter
c       fxi    = the ionic strength (the 2nd-order electrostatic
c                  moment function I)
c       ijz    = input charge product
c
c     Principal output:
c
c       el     = array of values of E-lambda functions
c       elp    = array of first ionic strength derivatives of
c                  E-lambda functions
c       elpp   = array of second ionic strength derivatives of
c                  E-lambda functions
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ijz
c
      logical qpit75
c
      real(8) aphi,el,elp,elpp,fxi
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      real(8) ck,cx,dhj0,d2hj0,hj0,hj1,hj2,ri,sjp,sjpp,x,fxisqt,xp,xpp
c
c-----------------------------------------------------------------------
c
      el = 0.
      elp = 0.
      elpp = 0.
c
      if (ijz .gt. 0.) then
c
        fxisqt = sqrt(fxi)
        cx = 3.*ijz*aphi
        x = 2.*cx*fxisqt
c
c       Compute x' and x''.
c
        xp = cx/fxisqt
        xpp = -(0.5*xp)/fxi
c
c       Get J0(x) and related functions.
c
        if (.not.qpit75) then
c
c         Use the Chebyshev polynomial approximation
c         of Harvie (1981). This is what should normally
c         be used. Note that hj1 and hj2 are outputs
c         that are not used.
c
          call ghj0(dhj0,d2hj0,hj0,hj1,hj2,x)
        else
c
c         Use the less accurate approximation of
c         Pitzer (1975).
c
c         Calling sequence substitutions:
c           dhj0 for dpj0
c           d2hj0 for d2pj0
c           hj0 for pj0
c
          call gpj0(dhj0,d2hj0,hj0,x)
        endif
c
c       Convert these to derivatives with respect to I.
c
        sjp = dhj0*xp
        sjpp = dhj0*xpp + d2hj0*xp*xp
c
        ck = 0.25*ijz
        ri = 1./fxi
c
        el = ri*ck*hj0
        elp = ri*(ck*sjp - el)
        elpp = ri*(ck*sjpp - 2.*elp)
      endif
c
      end


FUNCTION random_Poisson(mu, first) RESULT(ran_Poisson)
!**********************************************************************

!     Translated to Fortran 90 by Alan Miller from:
!                                    RANLIB
!
!           Library of Fortran Routines for Random Number Generation
!
!                           Compiled and Written by:
!
!                                Barry W. Brown
!                                 James Lovato
!
!                    Department of Biomathematics, Box 237
!                    The University of Texas, M.D. Anderson Cancer Center
!                    1515 Holcombe Boulevard
!                    Houston, TX      77030
!
! This work was supported by grant CA-16672 from the National Cancer Institute.

!                 GENerate POIsson random deviate Function

!  Generates a single random deviate from a Poisson
!  distribution with mean mu.

!                           Arguments

!  mu --> The mean of the Poisson distribution from which
!         a random deviate is to be generated.
!                           REAL mu

!                           Method

!  For details see:

!      Ahrens, J.H. and Dieter, U.
!      Computer Generation of Poisson Deviates
!      From Modified Normal Distributions.
!      ACM Trans. Math. Software, 8, 2 (June 1982), 163-179

!  MUPREV = PREVIOUS MU, MUOLD = MU AT LAST EXECUTION OF STEP P OR B.
!  TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT
!  COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K) - DEL

!  SEPARATION OF CASES A AND B

IMPLICIT NONE

!     .. Scalar Arguments ..
REAL, INTENT(IN)    :: mu
LOGICAL, INTENT(IN) :: first
INTEGER             :: ran_Poisson

INTERFACE
  FUNCTION random_normal() RESULT (ran_norm)
    IMPLICIT NONE
    REAL :: ran_norm
  END FUNCTION random_normal
END INTERFACE

INTERFACE
  FUNCTION random_exponential() RESULT (ran_exp)
    IMPLICIT NONE
    REAL :: ran_exp
  END FUNCTION random_exponential
END INTERFACE

!     .. Local Scalars ..
REAL    :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118,        &
           a4 = -.1661269, a5 = .1421878, a6 = -.1384794, a7 = .1250060,  &
           b1, b2, c, c0, c1, c2, c3, d, del, difmuk, e, fk, fx, fy, g,   &
           omega, p, p0, px, py, q, s, t, u, v, x, xx
INTEGER :: j, k, kflag, l, m
!     ..
!     .. Local Arrays ..
REAL    :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., 40320., 362880. /)
REAL    :: pp(35)
!     ..
!     ..
!     .. Executable Statements ..
IF (.NOT. first) GO TO 10
IF (mu < 10.0) GO TO 120

!     C A S E  A. (RECALCULATION OF S, D, L IF MU HAS CHANGED)

s = SQRT(mu)
d = 6.0*mu*mu

!     THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL PROBABILITIES FK
!     WHENEVER K >= M(MU).
!     L = INT(MU-1.1484) IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 .

l = INT(mu-1.1484)

!     STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE

10 g = mu + s*random_normal()
IF (g < 0.0) GO TO 20
ran_Poisson = INT(g)

!     STEP I. IMMEDIATE ACCEPTANCE IF ran_Poisson IS LARGE ENOUGH

IF (ran_Poisson.GE.l) RETURN

!     STEP S. SQUEEZE ACCEPTANCE - SAMPLE U

fk = REAL(ran_Poisson)
difmuk = mu - fk
CALL RANDOM_NUMBER(u)
IF (d*u >= difmuk*difmuk*difmuk) RETURN

!     STEP P. PREPARATIONS FOR STEPS Q AND H.
!             (RECALCULATIONS OF PARAMETERS IF NECESSARY)
!             .3989423=(2*PI)**(-.5)  .416667E-1=1./24.  .1428571=1./7.
!             THE QUANTITIES B1, B2, C3, C2, C1, C0 ARE FOR THE HERMITE
!             APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK.
!             C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION.

20 IF (.NOT. first) GO TO 30
omega = .3989423/s
b1 = .4166667E-1 / mu
b2 = .3*b1*b1
c3 = .1428571*b1*b2
c2 = b2 - 15.*c3
c1 = b1 - 6.*b2 + 45.*c3
c0 = 1. - b1 + 3.*b2 - 15.*c3
c = .1069/mu
30 IF (g < 0.0) GO TO 50

!             'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN)

kflag = 0
GO TO 70

!     STEP Q. QUOTIENT ACCEPTANCE (RARE CASE)

40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN

!     STEP E. EXPONENTIAL SAMPLE - random_expon() FOR STANDARD EXPONENTIAL
!             DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT'
!             (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.)

50 e = random_exponential()
CALL RANDOM_NUMBER(u)
u = u + u - 1.0
t = 1.8 + SIGN(e, u)
IF (t <= (-.6744)) GO TO 50
ran_Poisson = INT(mu+s*t)
fk = REAL(ran_Poisson)
difmuk = mu - fk

!             'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN)

kflag = 1
GO TO 70

!     STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION)

60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50
RETURN

!     STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY.
!             CASE ran_Poisson < 10 USES FACTORIALS FROM TABLE FACT

70 IF (ran_Poisson >= 10) GO TO 80
px = -mu
py = mu**ran_Poisson / fact(ran_Poisson + 1)
GO TO 110

!      CASE ran_Poisson >= 10 USES POLYNOMIAL APPROXIMATION
!      A0-A7 FOR ACCURACY WHEN ADVISABLE
!      .8333333E-1=1./12.  .3989423=(2*PI)**(-.5)

80 del = .8333333E-1 / fk
del = del - 4.8*del*del*del
v = difmuk/fk
IF (ABS(v) <= 0.25) GO TO 90
px = fk*LOG(1.0+v) - difmuk - del
GO TO 100

90 px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2)*v+a1)*v+a0) - del
100 py = .3989423/SQRT(fk)
110 x = (0.5-difmuk)/s
xx = x*x
fx = -0.5*xx
fy = omega* (((c3*xx+c2)*xx+c1)*xx+c0)
IF (kflag > 0) THEN
  GO TO 60
ELSE
  GO TO 40
END IF

!     C A S E  B. (START NEW TABLE AND CALCULATE P0 IF NECESSARY)

120 IF (first) THEN
  m = MAX(1, INT(mu))
  l = 0
  p = EXP(-mu)
  q = p
  p0 = p
END IF

!     STEP U. UNIFORM SAMPLE FOR INVERSION METHOD

130 CALL RANDOM_NUMBER(u)
ran_Poisson = 0
IF (u <= p0) RETURN

!     STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE
!             PP-TABLE OF CUMULATIVE POISSON PROBABILITIES
!             (0.458 = PP(9) FOR MU = 10)

IF (l == 0) GO TO 150
j = 1
IF (u > 0.458) j = MIN(l, m)
DO k = j, l
  IF (u <= pp(k)) GO TO 180
END DO
IF (l == 35) GO TO 130

!     STEP C. CREATION OF NEW POISSON PROBABILITIES P
!             AND THEIR CUMULATIVES Q = PP(K)

150 l = l + 1
DO k = l, 35
  p = p*mu/REAL(k)
  q = q + p
  pp(k) = q
  IF (u <= q) GO TO 170
END DO
l = 35
GO TO 130

170 l = k
180 ran_Poisson = k
RETURN

END FUNCTION random_Poisson


subroutine fuzzy
use fdeclarations

implicit none

print *, ' '
print *, 'Select the preferred scenario to implement'
print *, '[1] Average'
print *, '[2] Worst'
print *, '[3] Optimum'
print *, '[4] Default'
read *, scenario

print *, ' '
print *, 'Select the preferred defuzzification method'
print *, '[1] Centroid'
print *, '[2] Max membership'
print *, '[3] Weighted average'
print *, '[4] Mean-max membership'
print *, '[5] Default'
read *, dfuzz
write(*,*) ' '

if (cross==1) then
write(*,*) 'Initializing fuzzy logic...'
call sleep(2)
do zz=1,10
write(*,*) ' '
write(*,*) 'ITERATION', zz
write(*,*) '----------------------'
call sleep(2)
call randomizer
call iterator

write(*,*) 'Developing rules database...'
call classifier
open(49, file='log.txt', action='write', status='replace')
write(49,*) ' Classification matrix'
write(49,*) ' V      D      S      T      HS'
do i=1,ii
write(49,10) (cmatrix(i,j), j=1,w)
end do

!write(49,*) ' '
!write(49,*) 'rmatrix'
!do i=1,e
!write(49,10) (rmatrix(i,j), j=1,w-1)
!end do

call combinations
open (unit=59, file='amatrix.txt', status='old', action='read')
read (59,*) nn
allocate(amatrix(nn,w-1))
do i=1,nn
read(59,*) (amatrix(i,j), j=1,w-1)
end do

call fruler
!write(49,*) ' '
!write(49,*) 'pmatrix'
!do i=1,nn
!write(49,10) (pmatrix(i,j), j=1,w+2)
!end do
write(49,*) ' '
write(49,*) ' Fuzzy memberships matrix depending on the selected scenario'
write(49,*) ' Average, Worst, Optimum'
do i=1,nn
write(49,10) (p22matrix(i,j), j=1,w-2)
end do
write(*,*) 'Development of rules successful!'
write(*,*) ' '
call sleep(2)

write(*,*) 'Fuzzifying inputs...'
call fuzzifier
!write(49,*) ' '
!write(49,*) 'V Fuzzification'
!do i=1,n
!write(49,10) (uf(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'D Fuzzification'
!do i=1,n
!write(49,10) (df(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'S Classes'
!do i=1,n
!write(49,10) (sf(i,j), j=1,e)
!end do

!write(49,*) ' '
!write(49,*) 'T Fuzzification'
!do i=1,n
!write(49,10) (tf(i,j), j=1,e)
!end do
write(*,*) 'Fuzzification successful!'
write(*,*) ' '
write(*,*) 'Applying fuzzy rules...'
write(*,*) ' '

call sleep(2)
allocate(bmatrix(e**(w-1),w-1,z))
allocate(high(z))
allocate(good(z))
allocate(moderate(z))
allocate(poor(z))
allocate(bad(z))
allocate(fmatrix(nn,w-1,z))
allocate(mmatrix(nn,w,z))

do i=1,z !!!!!!!
open(29, file='bmatrix.txt', action='write', status='replace')
write(29,*) nn
call permutator
close(29, status='keep')

open (unit=39, file='bmatrix.txt', status='old', action='read')
read (39,*) nn
do jj=1,nn
read(39,*) (fmatrix(jj,j,i), j=1,w-1)
end do
close(39, status='keep')

write(49,*) 'fmatrix'
do jj=1,nn
write(49,10) (fmatrix(jj,j,i), j=1,w-1)
end do

call rules1

write(49,*) ' Fuzzy memberships matrix for each class'
write(49,*) ' H      G      M      P      B'
do jj=1,nn
write(49,10) (mmatrix(jj,j,i), j=1,w)
end do
write(*,*) 'Rules application for observation', i, 'successful'
end do !!!!!!!!!!!!
write(*,*) ' '
write(*,*) 'Rules application successful!'

write (49,*) ' '
write (49,*) ' High habitat suitability membership'
do i=1,z
write(49,10) (high(i))
end do

write (49,*) ' '
write (49,*) ' Good habitat suitability membership'
do i=1,z
write(49,10) (good(i))
end do

write (49,*) ' '
write (49,*) ' Moderate habitat suitability membership'
do i=1,z
write(49,10) (moderate(i))
end do

write (49,*) ' '
write (49,*) ' Poor habitat suitability membership'
do i=1,z
write(49,10) (poor(i))
end do

write (49,*) ' '
write (49,*) ' Bad habitat suitability membership'
do i=1,z
write(49,10) (bad(i))
end do

write(*,*)
print *, 'Defuzzifying...'
call sleep(2)
if (dfuzz==1) then
call centroid
else if (dfuzz==2) then
call maxmem
else if (dfuzz==3) then
call waver
else if (dfuzz==4) then
call meanmax
else
call centroid
end if
print *, 'Defuzzification successful!'
print *, ' '

print *, 'Calculating response variable...'
write(*,*) ' '
call sleep(2)

!open(19, file='suitability.txt', action='write', status='replace')
do i=1,z
write(*,*) 'Response variable calculation for observation', i, 'successful'
!write(19,10) (suitability(i,ff), ff=1,10)
end do
write(*,*) ' '
write(*,*) 'Response variable calculation successful!'

deallocate(a)
deallocate(bins)
deallocate(iimatrix)
deallocate(amatrix)
deallocate(pmatrix)
deallocate(p22matrix)
deallocate(uf)
deallocate(df)
deallocate(tf)
deallocate(sf)
deallocate(imatrix)
deallocate(dmatrix)
deallocate(ematrix)
deallocate(bmatrix)
deallocate(fmatrix)
deallocate(mmatrix)
deallocate(p11matrix)
deallocate(high)
deallocate(good)
deallocate(moderate)
deallocate(poor)
deallocate(bad)

close(49, status='keep')
close(59, status='keep')
!close(19, status='keep')

call performance
write(*,44) ' Performance - CCI  ', icci(zz)*100, ' %'

end do
write(*,*) ' '
write(*,*) 'End of cross-validation process!'
write(*,*) ' '

!write(*,*) 'comatrix2'
!do i=1,z
!write(*,10) (comatrix(i,2,ff), ff=1,10)
!end do
!write(*,*) 'comatrix1'
!do i=1,z
!write(*,10) (comatrix(i,1,ff), ff=1,10)
!end do
!write(*,*) 'comatrix3'
!do i=1,z
!write(*,10) (comatrix(i,3,ff), ff=1,10)
!end do
!write(*,*) 'suitability'
!do i=1,z
!write(*,10) (suitability(i,ff), ff=1,10)
!end do
!write(*,*) 'icci'
!write(*,*) icci
cci=(sum(icci(1:10))/10)*100
!write(*,*) cci
call sleep(2)
else
GOTO 299
end if
299 CONTINUE
z=n
zz=1
call tester

44 format (a,f6.2,a)
10 format (8f7.3)

end subroutine fuzzy


      SUBROUTINE PDLAGGE( M, N, D, A, IA, JA, DESCA, ISEED, ORDER, WORK,
     $                    LWORK, INFO )
*
*  -- ScaLAPACK routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            IA, INFO, JA, LWORK, M, N, ORDER
*     ..
*     .. Array Arguments ..
      INTEGER            DESCA( * ), ISEED( 4 )
      DOUBLE PRECISION   A( * ), D( * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  PDLAGGE generates a real symmetric matrix A, by pre- and post-
*  multiplying a real diagonal matrix D with a random orthogonal
*  matrices:  A = U*D*VT.
*
*  This is just a quick implementation which will be replaced in the
*  future. The random matrix A1(m,n) is generated and random left
*  orthogonal matrix U(m,m) is obtained  by running QR on A1:
*     A1(m,n) = U(m,m)*R,
*  where U(m,m) is a product of min(m,n) Householder rotations.
*  Afterwards the space of A1 is reused for a second random matrix
*  A2(m,n), which is used to obtain the right orthogonal matrix VT(n,n)
*  by running LQ on A2:
*     A2(m,n) = L*VT(n,n).
*  This requires vastly more computation than necessary, but not
*  significantly more communication than is used in the rest of this
*  routine, and hence is not that much slower than an efficient
*  solution.
*
*  Notes
*  =====
*
*  Each global data object is described by an associated description
*  vector.  This vector stores the information required to establish
*  the mapping between an object element and its corresponding process
*  and memory location.
*
*  Let A be a generic term for any 2D block cyclicly distributed array.
*  Such a global array has an associated description vector DESCA.
*  In the following comments, the character _ should be read as
*  "of the global array".
*
*  NOTATION        STORED IN      EXPLANATION
*  --------------- -------------- --------------------------------------
*  DTYPE_A(global) DESCA( DTYPE_ )The descriptor type.  In this case,
*                                 DTYPE_A = 1.
*  CTXT_A (global) DESCA( CTXT_ ) The BLACS context handle, indicating
*                                 the BLACS process grid A is distribu-
*                                 ted over. The context itself is glo-
*                                 bal, but the handle (the integer
*                                 value) may vary.
*  M_A    (global) DESCA( M_ )    The number of rows in the global
*                                 array A.
*  N_A    (global) DESCA( N_ )    The number of columns in the global
*                                 array A.
*  MB_A   (global) DESCA( MB_ )   The blocking factor used to distribute
*                                 the rows of the array.
*  NB_A   (global) DESCA( NB_ )   The blocking factor used to distribute
*                                 the columns of the array.
*  RSRC_A (global) DESCA( RSRC_ ) The process row over which the first
*                                 row of the array A is distributed.
*  CSRC_A (global) DESCA( CSRC_ ) The process column over which the
*                                 first column of the array A is
*                                 distributed.
*  LLD_A  (local)  DESCA( LLD_ )  The leading dimension of the local
*                                 array.  LLD_A >= MAX(1,LOCr(M_A)).
*
*  Let K be the number of rows or columns of a distributed matrix,
*  and assume that its process grid has dimension p x q.
*  LOCr( K ) denotes the number of elements of K that a process
*  would receive if K were distributed over the p processes of its
*  process column.
*  Similarly, LOCc( K ) denotes the number of elements of K that a
*  process would receive if K were distributed over the q processes of
*  its process row.
*  The values of LOCr() and LOCc() may be determined via a call to the
*  ScaLAPACK tool function, NUMROC:
*          LOCr( M ) = NUMROC( M, MB_A, MYROW, RSRC_A, NPROW ),
*          LOCc( N ) = NUMROC( N, NB_A, MYCOL, CSRC_A, NPCOL ).
*  An upper bound for these quantities may be computed by:
*          LOCr( M ) <= ceil( ceil(M/MB_A)/NPROW )*MB_A
*          LOCc( N ) <= ceil( ceil(N/NB_A)/NPCOL )*NB_A
*
*  Arguments
*  =========
*
*  M       (global input) INTEGER
*           Number of rows of the matrix A. M >= 0.
*
*  N       (global input) INTEGER
*          Number  of columns of matrix A.  N >= 0.
*
*  D       (local input) DOUBLE PRECISION array, dimension (N)
*          The diagonal elements of the diagonal matrix D.
*
*  A       (local output) DOUBLE PRECISION array
*          Global dimension (M, N), local dimension (MP, NQ)
*
*  IA      (global input) INTEGER
*          The global row index of the submatrix of the distributed
*          matrix A to operate on.
*
*  JA      (global input) INTEGER
*          The global column index of the submatrix of the distributed
*          matrix A to operate on.
*
*  DESCA   (global and local input) INTEGER array of dimension DLEN_
*          The array descriptor for the distributed matrix A.
*
*  ISEED   (global input/output) INTEGER array, dimension (4)
*          On entry, the seed of the random number generator; the array
*          elements must be between 0 and 4095, and ISEED(4) must be
*          odd. On exit, the seed is updated and will remain identical
*          on all processes in the context.
*
*  ORDER   (global input) INTEGER
*          Number of reflectors in the matrix Q
*          At present, ORDER .NE. N is not supported
*
*  WORK    (local workspace) DOUBLE PRECISION array, dimension (LWORK)
*
*  LWORK   (local input) INTEGER dimension of WORK
*          LWORK >= MAX( QR_WORK, LQ_WORK )
*          QR_WORK = LDAA*MAX( 1, NQ ) + 200 + MAX( 1, DTAU1 ) +
*                    MAX( SIZEMQRLEFT, SIZEQRF)
*          LQ_WORK = LDAA*MAX( 1, NQ ) + 200 + MAX( 1, DTAU2) +
*                    MAX( SIZEMLQRIGHT, SIZEQRF )
*          Where:
*          LDAA = DESCA( LLD_ )
*          MB_A = DESCA( MB_ )
*          NB_A = DESCA( NB_ )
*          RSRC_A = DESCA( RSRC_ )
*          CSRC_A = DESCA( CSRC_ )
*          LCM = ILCM( NPROW, NPCOL )
*          LCMQ = LCM / NPCOL
*          IROFFA = MOD( IA-1, MB_A )
*          ICOFFA = MOD( JA-1, NB_A )
*          IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW )
*          IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL )
*          MP = NUMROC( N+IROFFA, MB_A, MYROW, IAROW, NPROW )
*          NQ = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL )
*          DTAU1 = NUMROC( JA + SIZE- 1, NB_A, MYCOL, IACOL, NPROW )
*          DTAU2 = NUMROC( IA + SIZE- 1, MB_A, MYROW, IAROW, NPROW )
*          SIZEMQRLEFT = MAX( (MB_A*(MB_A-1))/2, ( MP + NQ ) * MB_A )
*               + ( MP + NB_A ) * NB_A
*          SIZEMLQRIGHT =  MAX( (MB_A*(MB_A-1))/2, (MP + NQ)*MB_A ) +
*                      MB_A * MB_A
*          SIZEQRF = NB_A*NP + MB_A*NQ + NB_A*NB_A
*
*  INFO    (local output) INTEGER
*
*          = 0:  successful exit
*          < 0:  If the i-th argument is an array and the j-entry had
*                an illegal value, then INFO = -(i*100+j), if the i-th
*                argument is a scalar and had an illegal value, then
*                INFO = -i.
*
* ======================================================================
*
*     .. Parameters ..
      INTEGER            BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
     $                   MB_, NB_, RSRC_, CSRC_, LLD_
      PARAMETER          ( BLOCK_CYCLIC_2D = 1, DLEN_ = 9, DTYPE_ = 1,
     $                   CTXT_ = 2, M_ = 3, N_ = 4, MB_ = 5, NB_ = 6,
     $                   RSRC_ = 7, CSRC_ = 8, LLD_ = 9 )
      DOUBLE PRECISION   ZERO
      PARAMETER          ( ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            CSRC_A, DTAU1, DTAU2, I, IACOL, IAROW, ICOFFA,
     $                   IROFFA, LCM, LCMQ, LDAA, LQ_WORK, LWMIN, MB_A,
     $                   MP, MYCOL, MYROW, NB_A, NPCOL, NPROW, NQ,
     $                   PTR2AA, PTR2TAU, PTR2WORK, QR_WORK, RSRC_A,
     $                   SIZE, SIZELQF, SIZEMLQRIGHT, SIZEMQRLEFT,
     $                   SIZEQRF
*     ..
*     .. External Subroutines ..
      EXTERNAL           BLACS_GRIDINFO, CHK1MAT, PDELSET, PDGELQF,
     $                   PDGEQRF, PDLASET, PDMATGEN, PDORMLQ, PDORMQR,
     $                   PXERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILCM, INDXG2P, NUMROC
      EXTERNAL           ILCM, INDXG2P, NUMROC
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, MOD
*     ..
*     .. Executable Statements ..
*     This is just to keep ftnchek happy
      IF( BLOCK_CYCLIC_2D*DLEN_*DTYPE_*M_*N_.LT.0 )RETURN
*
*     Initialize grid information.
*
      CALL BLACS_GRIDINFO( DESCA( CTXT_ ), NPROW, NPCOL, MYROW, MYCOL )
*
*     Check LWORK.
*
      INFO = 0
      SIZE = MIN( M, N )
      IF( NPROW.EQ.-1 ) THEN
         INFO = -607
      ELSE
         CALL CHK1MAT( M, 1, N, 2, IA, JA, DESCA, 8, INFO )
      END IF
*     Calculation of a minimum workspace.
      LDAA = DESCA( LLD_ )
      MB_A = DESCA( MB_ )
      NB_A = DESCA( NB_ )
      RSRC_A = DESCA( RSRC_ )
      CSRC_A = DESCA( CSRC_ )
      LCM = ILCM( NPROW, NPCOL )
      LCMQ = LCM / NPCOL
      IROFFA = MOD( IA-1, MB_A )
      ICOFFA = MOD( JA-1, NB_A )
      IAROW = INDXG2P( IA, MB_A, MYROW, RSRC_A, NPROW )
      IACOL = INDXG2P( JA, NB_A, MYCOL, CSRC_A, NPCOL )
      DTAU1 = NUMROC( JA+SIZE-1, NB_A, MYCOL, IACOL, NPCOL )
      DTAU2 = NUMROC( IA+SIZE-1, MB_A, MYROW, IAROW, NPROW )
      MP = NUMROC( M+IROFFA, MB_A, MYROW, IAROW, NPROW )
      NQ = NUMROC( N+ICOFFA, NB_A, MYCOL, IACOL, NPCOL )
*
      SIZEMQRLEFT = MAX( ( MB_A*( MB_A-1 ) ) / 2, ( MP+NQ )*MB_A ) +
     $              ( MP+NB_A )*NB_A
      SIZEMLQRIGHT = MAX( ( MB_A*( MB_A-1 ) ) / 2, ( MP+NQ )*MB_A ) +
     $               MB_A*MB_A
      SIZEQRF = NB_A*MP + MB_A*NQ + NB_A*NB_A + 100
      SIZELQF = NB_A*( MP+NQ+NB_A ) + 100
*
      QR_WORK = LDAA*MAX( 1, NQ ) + 200 + MAX( 1, DTAU1 ) +
     $          MAX( SIZEMQRLEFT, SIZEQRF )
      LQ_WORK = LDAA*MAX( 1, NQ ) + 200 + MAX( 1, DTAU2 ) +
     $          MAX( SIZEMLQRIGHT, SIZELQF )
      LWMIN = MAX( QR_WORK, LQ_WORK )
      WORK( 1 ) = LWMIN
      IF( LWORK.EQ.-1 )
     $   GO TO 20
*
*     Test the input arguments.
*
      IF( INFO.EQ.0 ) THEN
         IF( SIZE.NE.ORDER ) THEN
            INFO = -9
         ELSE IF( LWORK.LT.LWMIN ) THEN
            INFO = -11
         END IF
      END IF
      IF( INFO.LT.0 ) THEN
         CALL PXERBLA( DESCA( CTXT_ ), 'PDLAGGE', -INFO )
         RETURN
      END IF
*
*     Build a diagonal matrix A with the eigenvalues specified in D.
*
      CALL PDLASET( 'Full', M, N, ZERO, ZERO, A, IA, JA, DESCA )
      DO 10 I = 1, SIZE
         CALL PDELSET( A, I, I, DESCA, D( I ) )
   10 CONTINUE
*
*     Local dimension of array TAU in tis case is LOCc(JA+MIN(M,N)-1).
*
      PTR2AA = 2
      PTR2TAU = PTR2AA + LDAA*MAX( 1, NQ ) + 100
      PTR2WORK = PTR2TAU + MAX( 1, DTAU1 ) + 100
*
      CALL PDLASET( 'All', M, N, ZERO, ZERO, WORK( PTR2AA ), IA, JA,
     $              DESCA )
*
*     Build a random matrix AA1.
*
      CALL PDMATGEN( DESCA( CTXT_ ), 'N', 'N', M, N, DESCA( MB_ ),
     $               DESCA( NB_ ), WORK( PTR2AA ), DESCA( LLD_ ),
     $               DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 1 ), 0, MP,
     $               0, NQ, MYROW, MYCOL, NPROW, NPCOL )
*
*     Produce QR decomposition AA1 -> U*R.
*
      CALL PDGEQRF( M, N, WORK( PTR2AA ), IA, JA, DESCA,
     $              WORK( PTR2TAU ), WORK( PTR2WORK ), SIZEQRF, INFO )
*
*     A = U*A.
*
      CALL PDORMQR( 'L', 'N', M, N, SIZE, WORK( PTR2AA ), IA, JA, DESCA,
     $              WORK( PTR2TAU ), A, IA, JA, DESCA, WORK( PTR2WORK ),
     $              SIZEMQRLEFT, INFO )
*
*     Reinitialize pointer to WORK array. Dimension of array TAU in
*     this case is  LOCr(IA+MIN(M,N)-1).
*
      PTR2WORK = PTR2TAU + MAX( 1, DTAU2 ) + 100
*
*     Use the same workspace to generate a random matrix AA2.
*
      CALL PDMATGEN( DESCA( CTXT_ ), 'N', 'N', M, N, DESCA( MB_ ),
     $               DESCA( NB_ ), WORK( PTR2AA ), DESCA( LLD_ ),
     $               DESCA( RSRC_ ), DESCA( CSRC_ ), ISEED( 2 ), 0, MP,
     $               0, NQ, MYROW, MYCOL, NPROW, NPCOL )
*
*     Produce LQ decomposition of random matrix  AA2 -> L*VT.
*
      CALL PDGELQF( M, N, WORK( PTR2AA ), IA, JA, DESCA,
     $              WORK( PTR2TAU ), WORK( PTR2WORK ), SIZELQF, INFO )
*
*     Calculate A = A*VT.
*
      CALL PDORMLQ( 'R', 'N', M, N, SIZE, WORK( PTR2AA ), IA, JA, DESCA,
     $              WORK( PTR2TAU ), A, IA, JA, DESCA, WORK( PTR2WORK ),
     $              SIZEMLQRIGHT, INFO )
*
*     End of PDLAGGE
*
   20 CONTINUE
      RETURN
      END


module calc_module

use kind
use constants

implicit none

contains

subroutine printer(var, nx)
    integer (kind=ni) :: nx
    real    (kind=nr) :: var (nx)

    integer (kind=ni) :: i
    !f2py intent(in) var
    !f2py intent(hide) nx

    do i = 1, nx
        write(*, *) i, var(i), pi
    enddo
end subroutine printer

subroutine calc(res, var, factor, nx, ny, nz)
    integer(kind=ni) :: nx, ny, nz

    real   (kind=nr) :: var (nx, ny, nz)
    real   (kind=nr) :: res (nx, ny, nz)
    real   (kind=nr), allocatable :: arr (:, :, :)
    real   (kind=nr) :: factor

    integer(kind=ni) :: i, j, k

    allocate(arr(nx, ny, nz))

    !f2py intent(out) res
    !f2py intent(in) var
    !f2py intent(in) factor
    !f2py intent(hide) nx, ny, nz

    do k = 1, nz
      do j = 1, ny
        do i = 1, nx
          arr(i, j, k) = var(i, j, k) * factor
        enddo
      enddo
    enddo

    call other(res, arr, nz-1, ny-1, nx-1)

    deallocate(arr)

end subroutine calc

end module calc_module


!!# MODULE: FUNCTION  Interp1S_Linear
MODULE FUN_Interp1S_Linear

!!## PURPOSE
!! Interpolate 1D scattered data using linear interpolation.

!!## USAGE
!
!      y0 = Interp1S_Linear( x0 , y , x , dy0 )
!
!! where <x> is list of x-values, <y> is list of y-values,
!! and <(x0,y0)> are the interpolated <(x,y)> pair.

!!## METHOD
!! Simple linear interpolation of two values.  If the lists
!! y and x have more than 2 points, then a search is performed
!! to determine the correct interval.  IMPORTANT:  Extrapolation
!! is not performed if the value <x0> lies outside the
!! domain.  Instead, the value <y0> is assigned the value at the
!! nearest endpoint.

!!## EXTERNAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp              !!((01-A-KND_IntrinsicTypes.f90))

!!## DEPENDENCIES
USE FUN_IntervalBisection,ONLY: Interval=>IntervalBisection !!((03-A-FUN_IntervalBisection.f90))
USE FUN_Error            ,ONLY: Error                       !!((04-A-FUN_Error.f90))

!!## DEFAULT IMPLICIT
IMPLICIT NONE

!!## DEFAULT ACCESS
PRIVATE

!!## FUNCTION OVERLOAD
INTERFACE Interp1S_Linear
 MODULE PROCEDURE Interp1S_Linear_yRsp_xRsp
 MODULE PROCEDURE Interp1S_Linear_yRdp_xRsp
 MODULE PROCEDURE Interp1S_Linear_yRsp_xRdp
 MODULE PROCEDURE Interp1S_Linear_yRdp_xRdp
 MODULE PROCEDURE Interp1S_Linear_yRsp_xRsp_dy0
 MODULE PROCEDURE Interp1S_Linear_yRdp_xRsp_dy0
 MODULE PROCEDURE Interp1S_Linear_yRsp_xRdp_dy0
 MODULE PROCEDURE Interp1S_Linear_yRdp_xRdp_dy0
END INTERFACE

!!## PUBLIC ACCESS LIST
PUBLIC :: Interp1S_Linear

!!## MODULE PROCEDURES
CONTAINS

!!### PURE FUNCTION: <Interp1S_Linear_yRsp_xRsp>
PURE FUNCTION Interp1S_Linear_yRsp_xRsp( x0 , y , x  ) RESULT( y0 )

INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_y=KIND_Rsp
INCLUDE "05-B-FUN_Interp1S_Linear.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Interp1S_Linear_yRdp_xRsp>
PURE FUNCTION Interp1S_Linear_yRdp_xRsp( x0 , y , x  ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_y=KIND_Rdp
INCLUDE "05-B-FUN_Interp1S_Linear.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Interp1S_Linear_yRsp_xRdp>
PURE FUNCTION Interp1S_Linear_yRsp_xRdp( x0 , y , x  ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_y=KIND_Rsp
INCLUDE "05-B-FUN_Interp1S_Linear.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### PURE FUNCTION: <Interp1S_Linear_yRdp_xRdp>
PURE FUNCTION Interp1S_Linear_yRdp_xRdp( x0 , y , x  ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_y=KIND_Rdp
INCLUDE "05-B-FUN_Interp1S_Linear.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: <Interp1S_Linear_yRsp_xRsp_dy0>
FUNCTION Interp1S_Linear_yRsp_xRsp_dy0( x0 , y , x , dy0 ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_y=KIND_Rsp
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: <Interp1S_Linear_yRdp_xRsp_dy0>
FUNCTION Interp1S_Linear_yRdp_xRsp_dy0( x0 , y , x , dy0 ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rsp , KIND_y=KIND_Rdp
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: <Interp1S_Linear_yRsp_xRdp_dy0>
FUNCTION Interp1S_Linear_yRsp_xRdp_dy0( x0 , y , x , dy0 ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_y=KIND_Rsp
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

!!### FUNCTION: <Interp1S_Linear_yRdp_xRdp_dy0>
FUNCTION Interp1S_Linear_yRdp_xRdp_dy0( x0 , y , x , dy0 ) RESULT( y0 )
INTEGER,PARAMETER :: KIND_x=KIND_Rdp , KIND_y=KIND_Rdp
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.hdr"
!!--begin--
INCLUDE "05-B-FUN_Interp1S_Linear_dy0.f90.sup"
INCLUDE "05-B-FUN_Interp1S_Linear.f90.bdy"
!!--end--
END FUNCTION

END MODULE


      program t
      print '(f3.1)',sqrt(9.0)
      end program t


program ch0809
    ! Rank 1 Arrays and a Stride of 2
    implicit none

    integer :: i
    integer, dimension(1:10) :: x = [ (i, i=1,10) ]
    integer, dimension(1:5) :: odd = [ (i, i=1,10,2) ]
    integer, dimension(1:5) :: even

    even = x(2:10:2)
    print *, ' x'
    print *, x
    print *, ' odd'
    print *, odd
    print *, ' even'
    print *, even
end program


! GPROPT - Generalized PROgram for OPTimization
!
! The purpose of this program is to be general enough so that several
! optimization algorithms can be implemented
!
! Igor Lopes, February 2015
PROGRAM GPROPT
    IMPLICIT NONE
! Declaration
    INTEGER :: NALGO, NDIM
! Begin algorithm
01  WRITE(*,*)'Introduce number of design variables (0 - QUIT):'
    READ(*,*) NDIM
    IF(NDIM.LT.0)THEN
        WRITE(*,*)'Number of design variables must be larger or equal to 1'
        GOTO 01
    ELSEIF(NDIM.EQ.1)THEN
        WRITE(*,*)'Uni-dimensional problem'
        GOTO 11
    ELSEIF(NDIM.EQ.0)THEN
        GOTO 99
    ENDIF
10  WRITE(*,*)'Select Optimization algorithm:'
    WRITE(*,*)'1 - Powell Method'
    WRITE(*,*)'2 - Steepest Descent'
    WRITE(*,*)'3 - Fletcher-Reeves Conjugate Direction'
    WRITE(*,*)'4 - Polak-Ribiere Conjugate Direction'
    WRITE(*,*)'5 - Quasi-Newton Methods (Variable Metrics)'
    WRITE(*,*)'6 - Newton Method'
    WRITE(*,*)'7 - Genetic Algorithm'
    WRITE(*,*)'0 - QUIT'
    WRITE(*,*)'(Introduce corresponding number)'
    READ(*,*) NALGO

    SELECT CASE(NALGO)
    CASE (1)
        WRITE(*,*)'Powell s Method'
        CALL POWELL(NDIM)
    CASE(2)
        WRITE(*,*)'Steepest Descent'
        CALL STEEPDESC(NDIM)
    CASE(3)
        WRITE(*,*)'Fletcher-Reeves Conjugate Direction'
        CALL FLETCHERREEVES(NDIM)
    CASE(4)
        WRITE(*,*)'Polak-Ribiere Conjugate Direction'
        CALL POLAKRIBIERE(NDIM)
    CASE(5)
        WRITE(*,*)'Quasi-Newton Methods'
        CALL QUASINEWTON(NDIM)
    CASE(6)
        WRITE(*,*)'Newton Method'
        CALL NEWTON(NDIM)
    CASE(7)
        WRITE(*,*)'Genetic Algorithm'
        CALL GENETIC(NDIM)
    CASE DEFAULT
        WRITE(*,*)'Invalid option!'
        GOTO 10
    CASE(0)
        GOTO 99

    END SELECT
    GOTO 01
11  CONTINUE
    !1D
20  WRITE(*,*)'Select Optimization algorithm:'
    WRITE(*,*)'1 - Polynomial approximation'
    WRITE(*,*)'2 - Golden Section Method'
    WRITE(*,*)'3 - Genetic Algorithm'
    WRITE(*,*)'0 - QUIT'
    WRITE(*,*)'(Introduce corresponding number)'
    READ(*,*) NALGO

    SELECT CASE(NALGO)
    CASE (1)
        WRITE(*,*)'Polynomial approximation'
        CALL POLYINT
    CASE(2)
        WRITE(*,*)'Golden Section Method'
        CALL GOLDENINT
    CASE(3)
        WRITE(*,*)'Genetic Algorithm'
        CALL GENETIC(NDIM)
    CASE DEFAULT
        WRITE(*,*)'Invalid option!'
        GOTO 20
    CASE(0)
        GOTO 99
    END SELECT
    GOTO 01

99  CONTINUE
    WRITE(*,*)'CLOSING...'
END PROGRAM


! { dg-do run }
! Tests the fix for PR33499 in which the ENTRY cx_radc was not
! getting its TYPE.
!
! Contributed by Michael Richmond <michael.a.richmond@nasa.gov>
!
MODULE complex
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: cx, OPERATOR(+), OPERATOR(.eq.)
  TYPE cx
    integer :: re
    integer :: im
  END TYPE cx
  INTERFACE OPERATOR (+)
    MODULE PROCEDURE cx_cadr, cx_radc
  END INTERFACE
  INTERFACE OPERATOR (.eq.)
    MODULE PROCEDURE cx_eq
  END INTERFACE
  CONTAINS
  FUNCTION cx_cadr(z, r)
  ENTRY cx_radc(r, z)
    TYPE (cx) :: cx_cadr, cx_radc
    TYPE (cx), INTENT(IN) :: z
    integer, INTENT(IN) :: r
    cx_cadr%re = z%re + r
    cx_cadr%im = z%im
  END FUNCTION cx_cadr
  FUNCTION cx_eq(u, v)
    TYPE (cx), INTENT(IN) :: u, v
    logical :: cx_eq
    cx_eq = (u%re .eq. v%re) .and. (u%im .eq. v%im)
  END FUNCTION cx_eq
END MODULE complex

  use complex
  type(cx) :: a = cx (1, 2), c, d
  logical :: f
  integer :: b = 3
  if (.not.((a + b) .eq. (b + a))) call abort ()
  if (.not.((a + b) .eq. cx (4, 2))) call abort ()
end


module testmod
  implicit none

  contains

  subroutine foo(n)
    integer, intent(in) :: n
    real :: r(0:n,-n:n), a(0:n,-n:n), dj
    integer :: k, j

    ! initialize with some dummy values
    do j = -n, n
      a(:, j) = j
      r(:,j) = j + 1
    end do

    ! here be dragons
    do k = 0, n
      dj = r(k, k - 2) * a(k, k - 2)
      r(k,k) = a(k, k - 1) * dj
    enddo

    if (r(0,0) .ne. -2.) call abort

  end subroutine

end module

program test
  use testmod
  implicit none
  call foo(5)
end program


      PROGRAM xamebsa
C     driver for routine amebsa
      INTEGER NP,MP,MPNP
      REAL FTOL
      PARAMETER(NP=4,MP=5,MPNP=20,FTOL=1.0E-6)
      INTEGER i,idum,iiter,iter,j,jiter,ndim,nit
      REAL temptr,tt,yb,ybb
      COMMON /ambsa/ tt,idum
      REAL p(MP,NP),x(NP),y(MP),xoff(NP),pb(NP),tfunk
      EXTERNAL tfunk
      DATA xoff/4*10./
      DATA p/MPNP*0.0/
      idum=-64
1     continue
      ndim=NP
      do 11 j=2,MP
        p(j,j-1)=1.
11    continue
      do 13 i=1,MP
        do 12 j=1,NP
          p(i,j)=p(i,j)+xoff(j)
          x(j)=p(i,j)
12      continue
        y(i)=tfunk(x)
13    continue
      yb=1.e30
      write(*,*) 'Input T, IITER:'
      read(*,*,END=999) temptr,iiter
      ybb=1.e30
      nit=0
      do 14 jiter=1,100
        iter=iiter
        temptr=temptr*0.8
        call amebsa(p,y,MP,NP,ndim,pb,yb,FTOL,tfunk,iter,temptr)
        nit=nit+iiter-iter
        if (yb.lt.ybb) then
          ybb=yb
          write(*,'(1x,i6,e10.3,4f11.5,e15.7)')
     *         nit,temptr,(pb(j),j=1,NP),yb
        endif
        if (iter.gt.0) goto 80
14    continue
80    write(*,'(/1x,a)') 'Vertices of final 3-D simplex and'
      write(*,'(1x,a)') 'function values at the vertices:'
      write(*,'(/3x,a,t11,a,t23,a,t35,a,t45,a/)') 'I',
     *     'X(I)','Y(I)','Z(I)','FUNCTION'
      do 15 i=1,MP
        write(*,'(1x,i3,4f12.6,e15.7)') i,(p(i,j),j=1,NP),y(i)
15    continue
      write(*,'(1x,i3,4f12.6,e15.7)') 99,(pb(j),j=1,NP),yb
      goto 1
999   write(*,*) 'NORMAL COMPLETION'
      STOP
      END
      REAL FUNCTION tfunk(p)
      INTEGER N
      REAL RAD,AUG
      PARAMETER (N=4,RAD=0.3,AUG=2.0)
      INTEGER j
      REAL q,r,sumd,sumr,p(N),wid(N)
      DATA wid /1.,3.,10.,30./
      sumd=0.
      sumr=0.
      do 11 j=1,N
        q=p(j)*wid(j)
        r=nint(q)
        sumr=sumr+q**2
        sumd=sumd+(q-r)**2
11    continue
      if (sumd.gt.RAD**2) then
        tfunk=sumr*(1.+AUG)+1.
      else
        tfunk=sumr*(1.+AUG*sumd/RAD**2)+1.
      endif
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xamebsa.for


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE CROSS (X,XX,Y,YY,YYY,XXX)
      IMPLICIT NONE
C
C Purpose: Interpolates cross point between curve and shadow.
C
      REAL  X,XX,Y,YY,YYY,XXX
C
C X      : Abscissa value 1
C XX     : Abscissa value 2
C Y      : Ordinate value 1
C YY     : Ordinate value 2
C YYY    : Interpolated Ordinate
C XXX    : Interpolated abscissa
C
C Calls   0:
C
C-----------------------------------------------------------------------
      YYY=Y-YY+XX-X
      XXX=Y*(XX-X)+X*(Y-YY)
      IF (ABS(YYY).GE.1.E-6) THEN
         YYY=XXX/YYY
         XXX=XX-X
         IF (ABS(XXX).GE.1.E-6) THEN
            XXX=(YYY-X)/XXX
         ELSE
            XXX=Y-YY
            IF (ABS(XXX).GE.1.E-6) THEN
               XXX=(Y-YYY)/XXX
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcvol(n1,n2,n3,n4,cotet,volume)
!
!     calculates the volume of a tetrahedral element with nodes
!     n1, n2, n3 and n4
!
      implicit none
!
      integer n1,n2,n3,n4
!
      real*8 cotet(3,*),s(3),volume
!
      s(1)=(cotet(2,n2)-cotet(2,n1))*(cotet(3,n3)-cotet(3,n1))-
     &     (cotet(3,n2)-cotet(3,n1))*(cotet(2,n3)-cotet(2,n1))
      s(2)=(cotet(3,n2)-cotet(3,n1))*(cotet(1,n3)-cotet(1,n1))-
     &     (cotet(1,n2)-cotet(1,n1))*(cotet(3,n3)-cotet(3,n1))
      s(3)=(cotet(1,n2)-cotet(1,n1))*(cotet(2,n3)-cotet(2,n1))-
     &     (cotet(2,n2)-cotet(2,n1))*(cotet(1,n3)-cotet(1,n1))
      volume=((cotet(1,n4)-cotet(1,n1))*s(1)+
     &        (cotet(2,n4)-cotet(2,n1))*s(2)+
     &        (cotet(3,n4)-cotet(3,n1))*s(3))/6.d0
!
      return
      end


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

! Calling program for MVE/LMS subroutine. The input data has predictors first
! as columns, with target variable following, if this is an LMS problem.  The
! first column can be a case number if desired.   Current maximum dimensions
! are 200 observations and 20 variables, but these can be increased by
! changing the dimensions in lines 1-4.  The data are assumed to be in free
! format.

PROGRAM test_as282

USE robust_regression

IMPLICIT NONE
REAL (dp)          :: x(300,20), y(300), coeffs(20,100), eprmin(100),  &
                      resid(300,100), cvemin(100), robdsq(300,100), scalf
INTEGER            :: i, j, ncas, npre, ioptn, caseno,  &
                      int, nvar, maxtry, nclow, nchigh, ifault, ii
LOGICAL            :: mve, lms, exh, isint, case
CHARACTER (LEN=60) :: infile,outfile

WRITE(*,*) 'Input data file name?'
READ(*,10) infile
10 FORMAT(a)
WRITE(*,*) 'Does the data include a case number? Yes (T) or No',' (F)'
READ(*,*) case
OPEN (20,FILE=infile)
WRITE(*,*) 'Output file name?'
READ(*,10) outfile
OPEN(30,FILE=outfile)
WRITE(*,*) 'Sample size?'
READ(*,*) ncas
WRITE(*,*) '# predictors?'
READ(*,*) npre
WRITE(*,*) 'Enter scaling factor'
READ(*,*) scalf
ioptn = 0
WRITE(*,*) 'Do LMS? enter T or F'
READ(*,*) lms
IF (.NOT. lms) ioptn = ioptn + 1
WRITE(*,*) 'Do MVE? enter T or F'
READ(*,*) mve
IF (.NOT. mve) ioptn = ioptn + 2
WRITE(*,*) 'Intercept (constant) term? enter T or F'
READ(*,*) isint
IF (isint) THEN
  int=1
ELSE
  int=0
  ioptn = ioptn + 4
END IF
nvar=npre+int
WRITE(*,*) 'Exhaustive search? enter T or F'
READ(*,*) exh
IF (.NOT.exh) THEN
  ioptn = ioptn + 8
  WRITE(*,*) 'Max number of subsamples to check?'
  READ(*,*) maxtry
END IF
WRITE(*,*) 'Low, high coverages to check?'
READ(*,*) nclow,nchigh
DO i=1, ncas
  y(i) = 0
  IF (case) THEN
    IF (lms) THEN
      READ(20,*) caseno, (x(i,j),j=1,npre),y(i)
    ELSE
      READ(20,*) caseno, (x(i,j),j=1,npre)
    END IF
  ELSE
    IF (lms) THEN
      READ(20,*) (x(i,j),j=1,npre), y(i)
    ELSE
      READ(20,*) (x(i,j),j=1,npre)
    END IF
  END IF
  y(i) = y(i) * scalf
  x(i,1:npre) = scalf * x(i,1:npre)
END DO

IF (case) WRITE(*, *) 'Last case number was: ', caseno

CALL mvelms (x, y, ncas, npre, ioptn, maxtry, nclow, nchigh, coeffs,  &
             eprmin, resid, robdsq, cvemin, ifault)
WRITE(30,*) 'Fault parameter ', ifault
DO i=1, nchigh-nclow+1
  WRITE(30,*) 'Coverage level ', i+nclow-1
  IF (lms) THEN
    WRITE(30,*) 'LMS results'
    WRITE(30,*) 'Coefficients of LMS'
    WRITE(30,101) (coeffs(j,i),j=1,nvar)
    WRITE(30,*) 'Criterion ',eprmin(i)
    WRITE(30,*) 'Data, residuals'
    DO ii=1, ncas
      WRITE(30,103) ii, (x(ii,j),j=1,npre), y(ii), resid(ii,i)
    END DO
  END IF
  IF (mve) THEN
    WRITE(30,*) 'MVE results'
    WRITE(30,*) 'Criterion ', cvemin(i)
    WRITE(30,*) 'Data, robust d-squareds'
    DO ii=1, ncas
      WRITE(30,103) ii, (x(ii,j),j=1,npre), robdsq(ii,i)
    END DO
  END IF
END DO
101 FORMAT(5G15.6)
103 FORMAT(i3, (t5, 5G15.6))
STOP
END PROGRAM test_as282


c       this file contains the following user-callable routines:
c
c
c       routine idzr_rid computes the ID, to a specified rank,
c       of a matrix specified by a routine for applying its adjoint
c       to arbitrary vectors. This routine is randomized.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idzr_rid(m,n,matveca,p1,p2,p3,p4,krank,list,proj)
c
c       computes the ID of a matrix "a" specified by
c       the routine matveca -- matveca must apply the adjoint
c       of the matrix being ID'd to an arbitrary vector --
c       i.e., the present routine lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                       min(m,n,krank)
c       a(j,list(k))  =     Sigma      a(j,list(l)) * proj(l,k-krank)(*)
c                            l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c
c       input:
c       m -- number of rows in the matrix to be ID'd
c       n -- number of columns in the matrix to be ID'd
c       matveca -- routine which applies the adjoint
c                  of the matrix to be ID'd to an arbitrary vector;
c                  this routine must have a calling sequence
c                  of the form
c
c                  matveca(m,x,n,y,p1,p2,p3,p4),
c
c                  where m is the length of x,
c                  x is the vector to which the adjoint
c                  of the matrix is to be applied,
c                  n is the length of y,
c                  y is the product of the adjoint of the matrix and x,
c                  and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matveca
c       p2 -- parameter to be passed to routine matveca
c       p3 -- parameter to be passed to routine matveca
c       p4 -- parameter to be passed to routine matveca
c       krank -- rank of the ID to be constructed
c
c       output:
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns
c               in the original matrix being ID'd;
c               proj doubles as a work array in the present routine, so
c               proj must be at least m+(krank+3)*n complex*16 elements
c               long
c
c       _N.B._: The algorithm used by this routine is randomized.
c               proj must be at least m+(krank+3)*n complex*16 elements
c               long.
c
c       reference:
c       Halko, Martinsson, Tropp, "Finding structure with randomness:
c            probabilistic algorithms for constructing approximate
c            matrix decompositions," SIAM Review, 53 (2): 217-288,
c            2011.
c
        implicit none
        integer m,n,krank,list(n),lw,ix,lx,iy,ly,ir,lr
        complex*16 p1,p2,p3,p4,proj(m+(krank+3)*n)
        external matveca
c
c
c       Allocate memory in w.
c
        lw = 0
c
        ir = lw+1
        lr = (krank+2)*n
        lw = lw+lr
c
        ix = lw+1
        lx = m
        lw = lw+lx
c
        iy = lw+1
        ly = n
        lw = lw+ly
c
c
        call idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank,
     1                    list,proj(ir),proj(ix),proj(iy))
c
c
        return
        end
c
c
c
c
        subroutine idzr_ridall0(m,n,matveca,p1,p2,p3,p4,krank,
     1                          list,r,x,y)
c
c       routine idzr_ridall serves as a memory wrapper
c       for the present routine
c       (see idzr_ridall for further documentation).
c
        implicit none
        integer j,k,l,m,n,krank,list(n),m2
        complex*16 x(m),y(n),p1,p2,p3,p4,r(krank+2,n)
        external matveca
c
c
c       Set the number of random test vectors to 2 more than the rank.
c
        l = krank+2
c
c       Apply the adjoint of the original matrix to l random vectors.
c
        do j = 1,l
c
c         Generate a random vector.
c
          m2 = m*2
          call id_srand(m2,x)
c
c         Apply the adjoint of the matrix to x, obtaining y.
c
          call matveca(m,x,n,y,p1,p2,p3,p4)
c
c         Copy the conjugate of y into row j of r.
c
          do k = 1,n
            r(j,k) = conjg(y(k))
          enddo ! k
c
        enddo ! j
c
c
c       ID r.
c
        call idzr_id(l,n,r,krank,list,y)
c
c
        return
        end


c { dg-do run }
c============================================== test.f
      real x, y
      real(kind=8) x1, y1
      x=0.
      y = erfc(x)
      if (y .ne. 1.) STOP 1

      x=1.1
      y = erfc(x)
      if (abs(y - .1197949) .ge. 1.e-6) STOP 2

c modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas.
      x=8
      y = erfc(x)
      if (y .gt. 1.2e-28) STOP 3

      x1=0.
      y1 = erfc(x1)
      if (y1 .ne. 1.) STOP 4

      x1=1.1d0
      y1 = erfc(x1)
      if (abs(y1 - .1197949d0) .ge. 1.d-6) STOP 5

      x1=10
      y1 = erfc(x1)
      if (y1 .gt. 1.5d-44) STOP 6
      end
c=================================================
!output:
!  0.  1.875
!  1.10000002  1.48958981
!  10.  5.00220949E-06
!
!The values should be:
!erfc(0)=1
!erfc(1.1)= 0.1197949
!erfc(10)<1.543115467311259E-044


module sort_mod
implicit none

private

public  :: sort                 ! Sort an array (int or double)
public  :: sortinds             ! Get indices that sorts an array (int or double)
public  :: unique               ! Get the unique elements of an array (double)

interface sort
    procedure sort_int, sort_dbl
end interface sort

interface sortinds
    procedure sortinds_int, sortinds_dbl
end interface sortinds

interface unique
    procedure unique_dbl
end interface unique

contains

! Sort array
subroutine sort_int(array)
implicit none
    integer, intent(inout)          :: array(:)     ! Array to be sorted

    integer, allocatable            :: tmp_array(:) ! Temporary internal storage
    logical, allocatable            :: unused(:)    ! Logical array to remove assigned values in
                                                    ! minloc
    integer                         :: k1           ! Iterator
    integer                         :: min_ind(1)   ! Smallest index

    allocate(tmp_array, source=array)
    allocate(unused(size(array)))
    unused = .true.

    do k1=1,size(array)
        min_ind = minloc(tmp_array, mask=unused)
        array(k1) = tmp_array(min_ind(1))
        unused(min_ind) = .false.
    enddo

end subroutine sort_int

subroutine sort_dbl(array)
implicit none
    double precision, intent(inout) :: array(:)     ! Array to be sorted

    double precision, allocatable   :: tmp_array(:) ! Temporary internal storage
    logical, allocatable            :: unused(:)    ! Logical array to remove assigned values in
                                                    ! minloc
    integer                         :: k1           ! Iterator
    integer                         :: min_ind(1)   ! Smallest index

    allocate(tmp_array, source=array)
    allocate(unused(size(array)))
    unused = .true.

    do k1=1,size(array)
        min_ind = minloc(tmp_array, mask=unused)
        array(k1) = tmp_array(min_ind(1))
        unused(min_ind) = .false.
    enddo

end subroutine sort_dbl

! Get sorting indices of array
subroutine sortinds_dbl(array, sort_inds)
! Crude subroutine to determine sort_inds such that array(sort_inds) is sorted in ascending order
implicit none
    double precision        :: array(:)     ! Array with values to be sorted
    integer, allocatable    :: sort_inds(:) ! Index array to be created
    logical, allocatable    :: unused(:)    ! Logical array to remove assigned values in minloc
    integer                 :: k1           ! Iterator

    allocate(unused(size(array)))

    if (.not.allocated(sort_inds)) then
        allocate(sort_inds(size(array)))
    else
        if (size(sort_inds).ne.size(array)) then
            deallocate(sort_inds)
            allocate(sort_inds(size(array)))
            write(*,*) 'WARNING: array and sort_inds should have same size in sortinds subroutine'
            write(*,*) '         sort_inds reallocated to correct size'
        endif
    endif

    unused = .true.

    do k1=1,size(array)
        sort_inds(k1) = minloc(array, dim=1, mask=unused)
        unused(sort_inds(k1)) = .false.
    enddo

end subroutine

subroutine sortinds_int(array, sort_inds)
! Crude subroutine to determine sort_inds such that array(sort_inds) is sorted in ascending order
implicit none
    integer                 :: array(:)     ! Array with values to be sorted
    integer, allocatable    :: sort_inds(:) ! Index array to be created
    logical, allocatable    :: unused(:)    ! Logical array to remove assigned values in minloc
    integer                 :: k1           ! Iterator

    allocate(unused(size(array)))

    if (.not.allocated(sort_inds)) then
        allocate(sort_inds(size(array)))
    else
        if (size(sort_inds).ne.size(array)) then
            deallocate(sort_inds)
            allocate(sort_inds(size(array)))
            write(*,*) 'WARNING: array and sort_inds should have same size in sortinds subroutine'
            write(*,*) '         sort_inds reallocated to correct size'
        endif
    endif

    unused = .true.

    do k1=1,size(array)
        sort_inds(k1) = minloc(array, dim=1, mask=unused)
        unused(sort_inds(k1)) = .false.
    enddo

end subroutine

! Get unique values in array
subroutine unique_dbl(full_vector, unique_vector, tolerance)
implicit none
    ! Elements that are determined to be unique have maximum difference tolerance
    ! Default tolerance is 1.e-14*sum(abs(full_vector))/size(full_vector)
    double precision, intent(in)                :: full_vector(:)
    double precision, allocatable, intent(out)  :: unique_vector(:)
    double precision, intent(in), optional      :: tolerance

    double precision, allocatable               :: unique_vec_tmp(:)
    double precision, allocatable               :: full_vector_sort(:)
    double precision    :: tol  ! Internal variable for tolerance
    integer             :: kf   ! Iterator for full vector
    integer             :: kf0  ! Value of iterator for current unique set of values
    integer             :: ku   ! Iterator for unique vector

    if (present(tolerance)) then
        tol = tolerance
    else
        tol = 1.e-14*sum(abs(full_vector))/size(full_vector)
    endif

    allocate(unique_vec_tmp(size(full_vector)))
    allocate(full_vector_sort, source=full_vector)

    call sort(full_vector_sort)

    kf0 = 1
    ku = 1
    do kf=2,size(full_vector_sort)
        if (full_vector_sort(kf) > (full_vector_sort(kf0) + tol)) then
            unique_vec_tmp(ku) = sum(full_vector_sort(kf0:(kf-1)))/(kf-kf0)
            kf0 = kf
            ku = ku + 1
        endif
    enddo
    unique_vec_tmp(ku) = sum(full_vector_sort(kf0:size(full_vector_sort)))/(size(full_vector_sort)-kf0 + 1)

    allocate(unique_vector(ku))
    unique_vector = unique_vec_tmp(1:ku)

end subroutine unique_dbl

end module


! { dg do-run }
! PR 22144: eoshift1, eoshift3 and cshift1 used to lack memory
! allocation, which caused the writes to segfault.
program main
  implicit none
  integer, dimension (:,:),allocatable :: a
  integer, dimension (3) :: sh, bo
  character(len=80) line1, line2
  integer :: i

  allocate (a(3,3))
  a = reshape((/(i,i=1,9)/),shape(a))
  sh = (/ 2, -1, -2 /)
  bo = (/ -3, -2, -1 /)
  write(unit=line1,fmt='(10I5)') cshift(a, shift=sh)
  write(unit=line1,fmt='(10I5)') eoshift(a, shift=sh)
  write(unit=line1,fmt='(10I5)') eoshift(a, shift=sh, boundary=bo)
end program main


      function RP1(m_N, tau, taup, term, j_chi, coupling_Array)
      implicit none
      double precision :: RP1, m_N, j_chi
      double precision :: coupling_Array(14,2)
      integer :: tau,taup
      integer :: term
      integer :: c, q2
      double precision :: c12, c12p
      double precision :: c13, c13p
c
      c = 0
      q2 = 2
c
      c12 = coupling_Array(11,tau)
      c12p = coupling_Array(11,taup)
      c13 = coupling_Array(12,tau)
      c13p = coupling_Array(12,taup)
c
      if (term.eq.c) then
         RP1 = (j_chi*(j_chi+1))/12. * c12*c12p
      else if (term.eq.q2) then
         RP1 = 1/m_N**2 * (j_chi*(j_chi+1))/12. * c13*c13p
      else
         RP1 = 0.
      end if
c
      end function RP1


SUBROUTINE p612(input_file,output_file)
!-------------------------------------------------------------------------
! Program 6.12 Three-dimensional strain analysis of an elastic-plastic
!              (Mohr-Coulomb) slope using 20-node hexahedra. Viscoplastic
!              strain method.
!-------------------------------------------------------------------------
 USE main
 USE geom
  IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file

 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15),npri=1
 INTEGER::i,iel,ifix,iters,iy,limit,ndim=3,ndof=60,nels,neq,nip=8,nlen,nn,&
   nod=20,nodof=3,nprops=6,np_types,nsrf,nst=6,nx1,nx2,ny1,ny2,nze
 REAL(iwp)::cf,ddt,det,dq1,dq2,dq3,dsbar,dt=1.0e15_iwp,dtim=1.0_iwp,d1,   &
   d4=4.0_iwp,d180=180.0_iwp,e,f,fmax,h1,h2,lode_theta,one=1.0_iwp,phi,   &
   phif,pi,psi,psif,sigm,snph,start_dt=1.e15_iwp,s1,tnph,tnps,tol,        &
   two=2.0_iwp,v,w1,w2,zero=0.0_iwp
 CHARACTER(LEN=80)::argv,element='hexahedron'
 LOGICAL::converged,solid=.TRUE.
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   num(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),dee(:,:),  &
   der(:,:),deriv(:,:),devp(:),eld(:),eload(:),eps(:),erate(:),evp(:),    &
   evpt(:,:,:),flow(:,:),fun(:),gravlo(:),g_coord(:,:),jac(:,:),km(:,:),  &
   kv(:),loads(:),m1(:,:),m2(:,:),m3(:,:),oldis(:),points(:,:),prop(:,:), &
   sigma(:),srf(:),weights(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
!---(ifix=1) smooth-smooth(ifix=2) rough-smooth(ifix=3) rough-rough---
 READ(10,*)w1,s1,w2,h1,h2,d1,nx1,nx2,ny1,ny2,nze,ifix,np_types
 nels=(nx1*ny1+ny2*(nx1+nx2))*nze
 nn=((3*(ny1+ny2)+2)*nx1+2*(ny1+ny2)+1+(3*ny2+2)*nx2)*(1+nze)+            &
   ((ny1+ny2+1)*(nx1+1)+(ny2+1)*nx2)*nze
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   num(nod),dee(nst,nst),evpt(nst,nip,nels),coord(nod,ndim),fun(nod),     &
   g_g(ndof,nels),jac(ndim,ndim),der(ndim,nod),etype(nels),               &
   deriv(ndim,nod),g_num(nod,nels),bee(nst,ndof),km(ndof,ndof),eld(ndof), &
   eps(nst),sigma(nst),bload(ndof),eload(ndof),erate(nst),evp(nst),       &
   devp(nst),g(ndof),m1(nst,nst),m2(nst,nst),m3(nst,nst),flow(nst,nst),   &
   prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 CALL emb_3d_bc(ifix,nx1,nx2,ny1,ny2,nze,nf)
 neq=MAXVAL(nf)
 ALLOCATE(loads(0:neq),bdylds(0:neq),oldis(0:neq),gravlo(0:neq),kdiag(neq))
!-----------------------loop the elements to find global arrays sizes-----
 loads=zero
 kdiag=0
 pi=ACOS(-one)
 elements_1: DO iel=1,nels
   CALL emb_3d_geom(iel,nx1,nx2,ny1,ny2,nze,w1,s1,w2,h1,h2,d1,coord,num)
   g_num(:,iel)=num
   CALL num_to_g(num,nf,g)
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(A,I7,A,I8)')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 kv=zero
 oldis=zero
 gravlo=zero
 CALL sample(element,points,weights)
!-----------------------element stiffness integration and assembly--------
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(5,etype(iel)),prop(6,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   eld=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
     eld(2:ndof-1:3)=eld(2:ndof-1:3)+fun(:)*det*weights(i)
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
   gravlo(g)=gravlo(g)-eld*prop(4,etype(iel))
 END DO elements_2
!-----------------------factorise equations-------------------------------
 CALL sparin(kv,kdiag)
!-----------------------trial strength reduction factor loop--------------
 READ(10,*)tol,limit,nsrf
 ALLOCATE(srf(nsrf))
 READ(10,*)srf
 CALL mesh_ensi(argv,nlen,g_coord,g_num,element,etype,nf,loads(1:),      &
                nsrf,npri,dtim,solid)
 WRITE(11,'(/A)')"    srf   max disp  iters"
 srf_trials: DO iy=1,nsrf
   dt=start_dt
   DO i=1,np_types
     phi=prop(1,i)
     tnph=TAN(phi*pi/d180)
     phif=ATAN(tnph/srf(iy))
     snph=sin(phif)
     e=prop(5,i)
     v=prop(6,i)
     ddt=d4*(one+v)*(one-two*v)/(e*(one-two*v+snph**2))
     IF(ddt<dt)dt=ddt
   END DO
   iters=0
   bdylds=zero
   evpt=zero
!-----------------------plastic iteration loop----------------------------
   its: DO
     fmax=zero
     iters=iters+1
     loads=gravlo+bdylds
     CALL spabac(kv,loads,kdiag)
     loads(0)=zero
!-----------------------check plastic convergence-------------------------
     CALL checon(loads,oldis,tol,converged)
     IF(iters==1)converged=.FALSE.
     IF(converged.OR.iters==limit)bdylds=zero
!-----------------------go round the Gauss Points ------------------------
     elements_3: DO iel=1,nels
       phi=prop(1,etype(iel))
       tnph=TAN(phi*pi/d180)
       phif=ATAN(tnph/srf(iy))*d180/pi
       psi=prop(3,etype(iel))
       tnps=TAN(psi*pi/d180)
       psif=ATAN(tnps/srf(iy))*d180/pi
       cf=prop(2,etype(iel))/srf(iy)
       e=prop(5,etype(iel))
       v=prop(6,etype(iel))
       CALL deemat(dee,e,v)
       num=g_num(:,iel)
       coord=TRANSPOSE(g_coord(:,num))
       g=g_g(:,iel)
       eld=loads(g)
       bload=zero
       gauss_points_2: DO i=1,nip
         CALL shape_der(der,points,i)
         jac=MATMUL(der,coord)
         det=determinant(jac)
         CALL invert(jac)
         deriv=MATMUL(jac,der)
         CALL beemat(bee,deriv)
         eps=MATMUL(bee,eld)
         eps=eps-evpt(:,i,iel)
         sigma=MATMUL(dee,eps)
         CALL invar(sigma,sigm,dsbar,lode_theta)
!-----------------------check whether yield is violated-------------------
         CALL mocouf(phif,cf,sigm,dsbar,lode_theta,f)
         IF(f>fmax)fmax=f
         IF(converged.OR.iters==limit)THEN
           devp=sigma
         ELSE
           IF(f>=zero.OR.(converged.OR.iters==limit))THEN
             CALL mocouq(psif,dsbar,lode_theta,dq1,dq2,dq3)
             CALL formm(sigma,m1,m2,m3)
             flow=f*(m1*dq1+m2*dq2+m3*dq3)
             erate=MATMUL(flow,sigma)
             evp=erate*dt
             evpt(:,i,iel)=evpt(:,i,iel)+evp
             devp=MATMUL(dee,evp)
           END IF
         END IF
         IF(f>=zero.OR.(converged.OR.iters==limit))THEN
           eload=MATMUL(devp,bee)
           bload=bload+eload*det*weights(i)
         END IF
       END DO gauss_points_2
!-----------------------compute the total bodyloads vector----------------
       bdylds(g)=bdylds(g)+bload
       bdylds(0)=zero
     END DO elements_3
     WRITE(*,'(A,F7.2,A,I4,A,F8.3)')                                      &
       "  srf",srf(iy),"  iteration",iters,"  F_max",fmax
     IF(converged.OR.iters==limit)EXIT
   END DO its
   WRITE(11,'(F7.2,E12.4,I5)')srf(iy),MAXVAL(ABS(loads)),iters
   CALL dismsh_ensi(argv,nlen,iy,nf,oldis(1:))
   IF(iters==limit)EXIT
 END DO srf_trials

END SUBROUTINE p612


FUNCTION FDSTRSE(VOID,BMECH1,BMECH2,BMECH3)

  ! **  FDSTRSE IS COMPRESSION LENGTH SCALE
  !        STRESS WITH RESPECT TO VOID RATIO
  !

  IMPLICIT NONE

  REAL :: FDSTRSE,VOID,BMECH1,BMECH2,BMECH3,TMP,FSTRSEL,DFSTRSEL

  IF( BMECH1 > 0.0 )THEN
    TMP=-(VOID-BMECH2)/BMECH3
    TMP=-(VOID-BMECH2)/BMECH3
    FDSTRSE=(BMECH1/BMECH3)*EXP(TMP)
  ELSE
    FSTRSEL=-0.0147351*(VOID**3)+0.311854*(VOID**2)-2.96371*VOID+7.34698
    DFSTRSEL=-0.0442053*(VOID**2)+0.623708*VOID-2.96371
    FDSTRSE=DFSTRSEL*EXP(FSTRSEL)
  END IF

END FUNCTION


program main
    use,intrinsic :: iso_fortran_env
    use merge_sort_mod
    use random_mod
    implicit none
    if (.not. test_merge_sort_int32()) error stop
    if (.not. test_merge_sort_int64()) error stop
    if (.not. test_merge_sort_char()) error stop
contains
    function test_merge_sort_int32() result(ret)
        integer(int32):: n,i
        integer(int32), allocatable:: ar(:)
        logical:: ret

        n = 10000
        allocate(ar(n), source=[(randint(n), i=1,n)])
        call merge_sort(ar)
        ret = .true.
        do i=2,n
            ret = ret .and. ar(i) >= ar(i-1)
        end do
    end function

    function test_merge_sort_int64() result(ret)
        integer(int64):: n,i
        integer(int64), allocatable:: ar(:)
        logical:: ret

        n = 10000
        allocate(ar(n), source=[(randint(n), i=1,n)])
        call merge_sort(ar)
        ret = .true.
        do i=2,n
            ret = ret .and. ar(i) >= ar(i-1)
        end do
    end function

    function test_merge_sort_char() result(ret)
        integer(int32):: n,i
        character(:), allocatable:: ar(:)
        logical:: ret
        n=6
        allocate(character(100):: ar(n))
        ar(1) = 'banana'
        ar(2) = 'orange'
        ar(3) = 'apple'
        ar(4) = 'intel'
        ar(5) = 'amd'
        ar(6) = 'nvidia'
        call merge_sort(ar)
        print*, (trim(ar(i))//' : ', i=1,n)
        ret = .true.
        do i=2,n
            ret = ret .and. ar(i) >= ar(i-1)
        end do
    end function
end program main


program ch0514
    ! Binary Representation of a Real Number
    implicit none

    integer :: i, j
    character(32) :: i_in_bits = ' '
    real :: x = 1.

    print *, '         1         2         3'
    print *, '12345678901234567890123456789012'
    print *, i_in_bits
    i = transfer(x,i)
    do j = 0, 31
        if (btest(i,j)) then
            i_in_bits(32-j:32-j) = '1'
        else
            i_in_bits(32-j:32-j) = '0'
        end if
    end do
    print *, x
    print *, i_in_bits
end program


! assuming the unit of POSCAR is in angstrome

PROGRAM poscar2aa

  implicit none

  integer,parameter :: u1 = 5,  u2 = 970, u3 = 970 !u3 = 6
  real(8),parameter :: bohr = 0.529177d0
  real(8),allocatable :: asi(:,:),rsi(:,:)
  real(8) :: ax,aa(3,3),bb(3,3)
  character(30) :: cbuf, cbuf2, format_type
  integer :: i,j,k,l2,ne,ichk,natm_tot,natm(10)
  integer :: iconstr
  character(2) :: name_elem(10)

  read(u1,*)
  read(u1,*) ax
  read(u1,*) aa(1:3,1)
  read(u1,*) aa(1:3,2)
  read(u1,*) aa(1:3,3)

  read(u1,*)

  read(u1,'(a)') cbuf

  cbuf2 = adjustl(cbuf)
  l2    = len_trim(cbuf2)

  ne=0
  ichk=0
  do i=1,l2
     write(*,*) i,cbuf2(i:i)
     if ( cbuf2(i:i) == " " ) then
        ichk=0
     else
        if ( ichk == 1 ) cycle
        ichk=1
        ne=ne+1
     end if
  end do

  write(*,*) "ne =",ne

  backspace(u1)
  backspace(u1)

  read(u1,*) name_elem(1:ne)
  read(u1,*) natm(1:ne)

  read(u1,*) cbuf
  if ( cbuf(1:1) == "S" .or. cbuf(1:1) == "s" ) then
     iconstr=1
  else
     iconstr=0
     backspace(u1)
  end if

  read(u1,*) format_type

  natm_tot = sum( natm(1:ne) )

  allocate( rsi(3,natm_tot) ) ; rsi=0.0d0
  allocate( asi(3,natm_tot) ) ; asi=0.0d0

  i=0
  do k=1,ne
     do j=1,natm(k)
        i=i+1
        read(u1,*) rsi(1:3,i)
     end do
  end do

! convert

  ax = ax/bohr

  aa(:,:) = ax*aa(:,:)

  if ( format_type == "Cartesian" ) then
     rsi(:,:) = ax*rsi(:,:)
     call calc_aainv( aa, bb )
     asi(:,:) = matmul( bb(:,:), rsi(:,:) )
  else if ( format_type == "Direct" ) then
     asi(:,:) = rsi(:,:)
  else
     write(*,*) "format_type  ",format_type,"  is unknown"
     stop
  end if

! output

  write(u3,'("AX",f20.15)') ax
  write(u3,'("A1",3f20.15)') aa(1:3,1)/ax
  write(u3,'("A2",3f20.15)') aa(1:3,2)/ax
  write(u3,'("A3",3f20.15)') aa(1:3,3)/ax
  write(u3,'("AA")')

  write(u2,*) ne, natm_tot, "   /"

  i=0
  do k=1,ne
     do j=1,natm(k)
        i=i+1
        write(u2,'(1x,i4,3f20.15,i4," /")') k, asi(1:3,i), 1
     end do
  end do

CONTAINS

  SUBROUTINE calc_aainv( aa, bb )
    implicit none
    real(8),intent(IN)  :: aa(3,3)
    real(8),intent(OUT) :: bb(3,3)
    real(8) :: va
    va = aa(1,1)*aa(2,2)*aa(3,3)+aa(1,2)*aa(2,3)*aa(3,1) &
        +aa(1,3)*aa(2,1)*aa(3,2)-aa(1,3)*aa(2,2)*aa(3,1) &
        -aa(1,2)*aa(2,1)*aa(3,3)-aa(1,1)*aa(2,3)*aa(3,2)
    bb(1,1) = aa(2,2)*aa(3,3) - aa(3,2)*aa(2,3)
    bb(2,1) = aa(3,2)*aa(1,3) - aa(1,2)*aa(3,3)
    bb(3,1) = aa(1,2)*aa(2,3) - aa(2,2)*aa(1,3)
    bb(1,2) = aa(2,3)*aa(3,1) - aa(3,3)*aa(2,1)
    bb(2,2) = aa(3,3)*aa(1,1) - aa(1,3)*aa(3,1)
    bb(3,2) = aa(1,3)*aa(2,1) - aa(2,3)*aa(1,1)
    bb(1,3) = aa(2,1)*aa(3,2) - aa(3,1)*aa(2,2)
    bb(2,3) = aa(3,1)*aa(1,2) - aa(1,1)*aa(3,2)
    bb(3,3) = aa(1,1)*aa(2,2) - aa(2,1)*aa(1,2)
    bb(:,:) = bb(:,:)/va
    bb(:,:) = transpose( bb )
  END SUBROUTINE calc_aainv

END PROGRAM poscar2aa