C$Procedure  ZZBQUAD ( Solve quadratic equation with bounds )

      SUBROUTINE ZZBQUAD ( A, B, C, UB, N, NX, R1, R2 )

C$ Abstract
C
C     SPICE Private routine intended solely for the support of SPICE
C     routines. Users should not call this routine directly due to the
C     volatile nature of this routine.
C
C     Solve a quadratic equation using an upper bound for the absolute
C     value of the roots. Only real roots are computed.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     EQUATION
C     MATH
C     QUADRATIC
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      A
      DOUBLE PRECISION      B
      DOUBLE PRECISION      C
      DOUBLE PRECISION      UB
      INTEGER               N
      INTEGER               NX
      DOUBLE PRECISION      R1
      DOUBLE PRECISION      R2

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     A,
C     B,
C     C          I   Coefficients of quadratic equation.
C     UB         I   Upper bound on magnitude of roots.
C     N          O   Number of real roots within bound.
C     NX         O   Number of real roots exceeding bound.
C     R1         O   Root of smaller absolute value.
C     R2         O   Root of larger absolute value.
C     BIG        P   Limit on magnitude of coefficients and UB.
C
C$ Detailed_Input
C
C     A,
C     B,
C     C          are the real coefficients of a quadratic equation.
C                The equation is
C
C                      2
C                   A X   +  B X  +  C  =  0
C
C
C     UB         is an upper bound on the absolute value of real
C                roots to be found by this routine. Roots having
C                absolute value larger than UB are not returned.
C
C$ Detailed_Output
C
C
C     N          is the number of real roots found that satisfy the
C                magnitude bound constraint.
C
C                Degenerate cases: if A = B = 0, then
C
C                   If C  = 0, N is set to -1; NX is set to 0; R1 and
C                   R2 are set to zero.
C
C                   If C != 0, N is set to -2; NX is set to 0; R1 and
C                   R2 are set to zero.
C
C
C     NX        is the number of real roots having absolute values that
C               exceed the bound.
C
C               If the roots are complex, both N and NX are set to zero.
C
C     R1,
C     R2        are roots returned in increasing order of absolute
C               value. If there is one real root of multiplicity 2,
C               both R1 and R2 are set to that root, provided that
C               the absolute value of the root does not exceed UB.
C
C               If the absolute value of a root exceeds UB the
C               corresponding output argument is set to zero. If the
C               roots are complex, both R1 and R2 are set to zero.
C
C$ Parameters
C
C     BIG            is a limit on the absolute value of the input
C                    coefficients and on the magnitude limit for the
C                    roots. BIG is set to
C
C                       SQRT( DPMAX() ) / 100
C
C$ Exceptions
C
C     1)  If any of the input coefficients have absolute value larger
C         than the parameter BIG, the error SPICE(VALUEOUTOFRANGE) is
C         signaled.
C
C     2)  If UB is non-positive or larger than the parameter BIG, the
C         error SPICE(VALUEOUTOFRANGE) is signaled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     See ZZCNQUAD for a more robust implementation that makes use
C     of this one.
C
C$ Examples
C
C     See usage in ZZCNQUAD
C
C$ Restrictions
C
C     1)  This routine may suffer from loss of precision for coefficient
C         sets having small, non-zero leading coefficients. See ZZCNQUAD
C         for a more robust implementation.
C
C     2)  This is a private routine; it should not be called by
C         non-SPICELIB code.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 21-JUN-2016 (NJB)
C
C        Made minor updates to header comments.
C
C        24-SEP-2014 (NJB)
C
C           Original version.
C
C-&

C$ Index_Entries
C
C     solve quadratic equation with bounds on roots
C
C-&

C$ Revisions
C
C     None.
C
C-&

C
C     SPICELIB functions
C
      DOUBLE PRECISION      DPMAX
      DOUBLE PRECISION      TOUCHD

      LOGICAL               RETURN

C
C     Local variables
C
      DOUBLE PRECISION      BIG
      DOUBLE PRECISION      DENOM
      DOUBLE PRECISION      DSCRIM
      DOUBLE PRECISION      NUM1
      DOUBLE PRECISION      NUM2
      DOUBLE PRECISION      SQDISC

      LOGICAL               FIRST

C
C     Saved variables
C
      SAVE                  BIG
      SAVE                  FIRST

C
C     Initial values
C
      DATA                  BIG   / 0.D0   /
      DATA                  FIRST / .TRUE. /

C
C     Use discovery check-in.
C
      IF ( RETURN() ) THEN
         RETURN
      END IF

      IF ( FIRST ) THEN

         BIG   = SQRT( DPMAX() ) / 100
         FIRST = .FALSE.

      END IF

C
C     Set invalid counts to start out. Initialize R1 and R2.
C
      N   = -3
      NX  = -3
      R1  = 0.D0
      R2  = 0.D0

C
C     Reject all large magnitude coefficients.
C
      IF (     ( ABS(A) .GT. BIG )
     .    .OR. ( ABS(B) .GT. BIG )
     .    .OR. ( ABS(C) .GT. BIG ) ) THEN

         CALL CHKIN  ( 'ZZBQUAD'                                      )
         CALL SETMSG ( 'Coefficients must have magnitude less than '
     .   //            'or equal to #, but were A = #; B = #; C = #.' )
         CALL ERRDP  ( '#',  BIG                                      )
         CALL ERRDP  ( '#',  A                                        )
         CALL ERRDP  ( '#',  B                                        )
         CALL ERRDP  ( '#',  C                                        )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'                       )
         CALL CHKOUT ( 'ZZBQUAD'                                      )
         RETURN

      END IF

C
C     Reject large magnitude upper bounds as well.
C
      IF ( ABS(UB) .GT. BIG ) THEN

         CALL CHKIN  ( 'ZZBQUAD'                                      )
         CALL SETMSG ( 'Upper bounds must have magnitude less than '
     .   //            'or equal to #, but was #.'                    )
         CALL ERRDP  ( '#',  BIG                                      )
         CALL ERRDP  ( '#',  UB                                       )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'                       )
         CALL CHKOUT ( 'ZZBQUAD'                                      )
         RETURN

      END IF

C
C     The upper bound must be positive.
C
      IF ( UB .LE. 0.D0 ) THEN

         CALL CHKIN  ( 'ZZBQUAD'                                 )
         CALL SETMSG ( 'Upper bound must be positive but was #.' )
         CALL ERRDP  ( '#',  UB                                  )
         CALL SIGERR ( 'SPICE(VALUEOUTOFRANGE)'                  )
         CALL CHKOUT ( 'ZZBQUAD'                                 )
         RETURN

      END IF

C
C     Handle the degenerate cases first.
C
      IF ( A .EQ. 0.D0 ) THEN

         IF ( B .EQ. 0.D0 ) THEN
C
C           The equation is of the form
C
C              C = 0
C
            IF ( C .EQ. 0.D0 ) THEN
C
C              The equation is satisfied for all real numbers.
C
               N  = -1
               NX =  0

            ELSE
C
C              There are no solutions.
C
               N  = -2
               NX =  0

            END IF

         ELSE
C
C           The equation is first-order:
C
C              B*X + C = 0
C
C           In this branch, B is non-zero.
C
            IF ( ABS(C) .LE. ABS(UB * B) ) THEN

               N   =   1
               NX  =   0

               R1  =  -C / B
               R2  =   R1

            ELSE
C
C              The magnitude of the solution is too large.
C
               N   =  0
               NX  =  1

            END IF

         END IF

      ELSE
C
C        The leading coefficient of the equation is non-zero.
C
C        We can safely compute the discriminant now, due the
C        check we've already performed.
C
         DSCRIM = TOUCHD(  ( B*B ) - ( 4*A*C )  )

         IF ( DSCRIM .LT. 0.D0 ) THEN
C
C           We have complex roots, so we're done.
C
            N  = 0
            NX = 0

         ELSE IF ( DSCRIM .EQ. 0.D0 ) THEN
C
C           We have a single real root of multiplicity 2.
C
C           Compare the magnitude of the root to the upper bound.
C
            NUM1   =  -B
            DENOM  =   2 * A

            IF ( ABS(NUM1) .GE. ABS(DENOM * UB) ) THEN
C
C              The root is too large; we won't compute it.
C
               N   =  0
               NX  =  1

            ELSE
C
C              Set both roots to the same value. In this branch,
C              A is non-zero.
C
               N   =  1
               NX  =  0

               R1  =  ( NUM1 / A ) / 2
               R2  =  R1

            END IF

         ELSE
C
C           We have two nominally distinct real roots. Whether
C           they're distinct double precision numbers depends
C           on the relative magnitudes of A and DSCRIM.
C
            DENOM  = 2 * A
            SQDISC = SQRT( DSCRIM )

            IF ( B .GT. 0.D0 ) THEN

               NUM2 =  -B - SQDISC
               NUM1 =  -B + SQDISC
            ELSE
               NUM2 =  -B + SQDISC
               NUM1 =  -B - SQDISC
            END IF

C
C           See whether the root of larger magnitude is computable.
C
            IF ( ABS(NUM2) .LE. ABS(UB * DENOM) ) THEN
C
C              The root is computable.

               N  = 2
               NX = 0
C
C              In this branch, A is non-zero.
C
               R2 = ( NUM2 / A ) / 2

               IF ( ABS(R2) .GT. 0.D0 ) THEN
C
C                 Compute R1 using R2 and C; this avoids loss
C                 of precision that may occur when NUM1 is computed.
C
C                 We know R1 has smaller magnitude than R2 and R2
C                 is computable, and we know A is non-zero, so R1
C                 can be computed without a divide-by-zero error,
C                 and it is computable as long as no intermediate
C                 results overflow. The bounds on A and R2 ensure
C                 that A*R2 is computable.
C
                  R1 =  C / ( A * R2 )

               ELSE
C
C                 The root of larger magnitude has magnitude 0. This
C                 doesn't leave many possible values for the root of
C                 smaller magnitude.
C
                  R1 = 0.D0

               END IF

            ELSE
C
C              The root of larger magnitude is not computable.
C              Check the root of smaller magnitude.
C
               IF ( ABS(NUM1) .LE. ABS(UB * DENOM) ) THEN
C
C                 The root is computable.
C
                  N  = 1
                  NX = 1

                  R1 = ( NUM1 / A ) / 2

               ELSE
C
C                 Neither root is computable.
C
                  N  = 0
                  NX = 2

               END IF

            END IF

         END IF

      END IF

      RETURN
      END


SUBROUTINE p118(input_file,output_file)
!-------------------------------------------------------------------------
! Program 11.8 Forced vibration analysis of an elastic-plastic (Von Mises)
!              solid in plane strain using rectangular 8-node quadrilateral
!              elements. Lumped mass. Mesh numbered in x- or y-direction.
!              Explicit time integration.
!-------------------------------------------------------------------------
 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)
 INTEGER::i,j,iel,k,loaded_nodes,ndim=2,ndof=16,nels,neq,nip=4,nlen,nn,   &
   nod=8,nodof=2,npri,nprops=4,np_types,nr,nres,nst=4,nstep,nxe,nye
 REAL(iwp)::area,det,dsbar,dtim,f,fac,fmax,fnew,lode_theta,one=1.0_iwp,   &
   pt5=0.5_iwp,sigm,time,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),nf(:,:),node(:),  &
   num(:)
 REAL(iwp),ALLOCATABLE::bdylds(:),bee(:,:),bload(:),coord(:,:),dee(:,:),  &
   der(:,:),deriv(:,:),d1x1(:),d2x1(:),eld(:),eload(:),eps(:),            &
   etensor(:,:,:),diag(:),g_coord(:,:),jac(:,:),mm(:,:),pl(:,:),          &
   points(:,:),prop(:,:),sigma(:),stress(:),tensor(:,:,:),val(:,:),       &
   weights(:),x1(:),x_coords(:),y_coords(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),weights(nip),g_coord(ndim,nn),    &
   num(nod),dee(nst,nst),tensor(nst,nip,nels),coord(nod,ndim),pl(nst,nst),&
   etensor(nst,nip,nels),jac(ndim,ndim),der(ndim,nod),deriv(ndim,nod),    &
   g_num(nod,nels),bee(nst,ndof),eld(ndof),eps(nst),sigma(nst),           &
   mm(ndof,ndof),bload(ndof),eload(ndof),g(ndof),stress(nst),etype(nels), &
   g_g(ndof,nels),x_coords(nxe+1),y_coords(nye+1),prop(nprops,np_types))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(bdylds(0:neq),x1(0:neq),d1x1(0:neq),d2x1(0:neq),diag(0:neq))
 READ(10,*)loaded_nodes
 ALLOCATE(node(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(node(i),val(i,:),i=1,loaded_nodes)
!-----------------------loop the elements to set up global geometry ------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 WRITE(11,'(A,I5,A)')"There are",neq," equations"
!-----------------------initial conditions--------------------------------
 tensor=zero
 etensor=zero
 x1=zero
 d1x1=zero
 d2x1=zero
 diag=zero
 CALL sample(element,points,weights)
 time=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I5)')" Result at node",nres
 WRITE(11,'(A)')"    time        load        x-disp      y-disp"
 WRITE(11,'(4E12.4)')time,load(time),x1(nf(:,nres))
 time_steps: DO j=1,nstep
   fmax=zero
   time=time+dtim
   x1=x1+dtim*d1x1+pt5*dtim**2*d2x1
   bdylds=zero
!-----------------------go round the Gauss Points ------------------------
   elements_2: DO iel=1,nels
     num=g_num(:,iel)
     coord=TRANSPOSE(g_coord(:,num))
     g=g_g(:,iel)
     area=zero
     bload=zero
     eld=x1(g)
     gauss_pts_1: DO i=1,nip
       CALL shape_der(der,points,i)
       CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
       jac=MATMUL(der,coord)
       det=determinant(jac)
       area=area+det*weights(i)
       CALL invert(jac)
       deriv=MATMUL(jac,der)
       CALL beemat(bee,deriv)
       eps=MATMUL(bee,eld)
       eps=eps-etensor(:,i,iel)
       sigma=MATMUL(dee,eps)
       stress=sigma+tensor(:,i,iel)
       CALL invar(stress,sigm,dsbar,lode_theta)
       fnew=dsbar-prop(4,etype(iel))
!-----------------------check whether yield is violated-------------------
       IF(fnew>=zero)THEN
         stress=tensor(:,i,iel)
         CALL invar(stress,sigm,dsbar,lode_theta)
         f=dsbar-prop(4,etype(iel))
         fac=fnew/(fnew-f)
         stress=tensor(:,i,iel)+(one-fac)*sigma
         CALL vmdpl(dee,stress,pl)
         dee=dee-fac*pl
       END IF
       sigma=MATMUL(dee,eps)
       sigma=sigma+tensor(:,i,iel)
       CALL invar(sigma,sigm,dsbar,lode_theta)
       f=dsbar-prop(4,etype(iel))
       IF(f>fmax)fmax=f
       eload=MATMUL(sigma,bee)
       bload=bload+eload*det*weights(i)
!-----------------------update the Gauss Point stresses and strains-------
       tensor(:,i,iel)=sigma
       etensor(:,i,iel)=etensor(:,i,iel)+eps
     END DO gauss_pts_1
     bdylds(g)=bdylds(g)-bload
     IF(j==1)THEN
       CALL elmat(area,prop(3,etype(iel)),mm)
       CALL formlump(diag,mm,g)
     END IF
   END DO elements_2
   bdylds(0)=zero
   DO i=1,loaded_nodes
     bdylds(nf(:,node(i)))=bdylds(nf(:,node(i)))+val(i,:)*load(time)
   END DO
   bdylds(1:)=bdylds(1:)/diag(1:)
   d1x1=d1x1+(d2x1+bdylds)*pt5*dtim
   d2x1=bdylds
   WRITE(*,'(A,I6,A,F8.4)')"  time step",j,"    F_max",fmax
   IF(j/npri*npri==j)WRITE(11,'(4E12.4)')time,load(time),x1(nf(:,nres))
 END DO time_steps

CONTAINS
FUNCTION load(t) RESULT(load_result)
!-----------------------Load-time function--------------------------------
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::t
 REAL(iwp)::load_result
 load_result=-180.0_iwp
RETURN
END FUNCTION load
END SUBROUTINE p118


      SUBROUTINE IMPINT (DT,ALPH)
C--
C--   SUBROUTINE IMPINT (DT,ALPH)
C--
C--   Purpose : initialize constants for implicit computation of
C--             horizontal diffusion and gravity waves
C--   Input :   DT   = time step
C--             ALPH = stepping coefficient for gravity wave scheme
C--                    (0.0 = forward, 0.5 = centred, 1.0 = backward)
C--   Initialized common blocks : DYNC5, DYNC6, HDIFC2
C--

c     IMPINT initializes constants for the implicit gravity wave computation.
c     It is assumed that that all implicit steps are of length DELT2 and use
c     the forward/backward parameter ALPH.  IMPINT has to be re-called
c     whenever either of these two parameters is changed. IMPINT should
c     be called even if the explicit option is chosen for the gravity wave
c     terms (the reference state temperature TREF is subtracted from some
c     terms anyway to reduce roundoff error; also the constants needed for
c     the biharmonic diffusion, which is assumed always to be backwards
c     implicit, are defined in IMPINT)

      include "atparam.h"
      include "atparam1.h"

      include "com_dyncon0.h"
      include "com_dyncon1.h"
      include "com_dyncon2.h"
      include "com_hdifcon.h"

      DIMENSION DSUM(KX),INDX(KX),YA(KX,KX)

C--   1. Constants for backwards implicit biharmonic diffusion

      DO M=1,MX
        DO N=1,NX
          DMP1 (M,N)=1./(1.+DMP (M,N)*DT)
          DMP1D(M,N)=1./(1.+DMPD(M,N)*DT)
          DMP1S(M,N)=1./(1.+DMPS(M,N)*DT)
        ENDDO
      ENDDO

C--   1. Constants for implicit gravity wave computation

c     reference atmosphere, function of sigma only

      RGAM = RGAS*GAMMA/(1000.*GRAV)

      DO 101 K=1,KX
        TREF(K)=288.*MAX(0.2,FSG(K))**RGAM
        print *, '  Tref = ', TREF(K)
        TREF1(K)=RGAS*TREF(K)
        TREF2(K)=AKAP*TREF(K)
        TREF3(K)=FSGR(K)*TREF(K)
  101 CONTINUE

c     Other constants

      XI=DT*ALPH
      XXI = XI/(A*A)

      DO 201 K=1,KX
        DHSX(K)=XI*DHS(K)
  201 CONTINUE

      DO 60 N=1,NX
      DO 60 M=1,MX
        MM=ISC*(M-1)+1
        LL=MM+N-2
        ELZ(M,N)=FLOAT(LL)*FLOAT(LL+1)*XXI
   60 CONTINUE

c   T(K) = TEX(K)+YA(K,K')*D(K') + XA(K,K')*SIG(K')

      DO 1 K=1,KX
      DO 1 K1=1,KXM
        XA(K,K1)=0.
    1 CONTINUE

      DO 2 K=1,KX
      DO 2 K1=1,KX
        YA(K,K1)=-AKAP*TREF(K)*DHS(K1)
    2 CONTINUE

      DO 3 K=2,KX
        XA(K,K-1)=0.5*(AKAP*TREF(K)/FSG(K)
     *      -(TREF(K)-TREF(K-1))/DHS(K))
    3 CONTINUE

      DO 4 K=1,KXM
        XA(K,K)=0.5*(AKAP*TREF(K)/FSG(K)
     *    -(TREF(K+1)-TREF(K))/DHS(K))
    4 CONTINUE

c     SIG(K)=XB(K,K')*D(K')

      DSUM(1)=DHS(1)
      DO 6 K=2,KX
        DSUM(K)=DSUM(K-1)+DHS(K)
    6 CONTINUE

      DO 5 K=1,KXM
      DO 5 K1=1,KX
        XB(K,K1)=DHS(K1)*DSUM(K)
        IF(K1.LE.K) XB(K,K1)=XB(K,K1)-DHS(K1)
    5 CONTINUE

c     T(K)=TEX(K)+XC(K,K')*D(K')

      DO 7 K=1,KX
      DO 7 K1=1,KX
        XC(K,K1)=YA(K,K1)
        DO 77 K2=1,KXM
          XC(K,K1)=XC(K,K1)+XA(K,K2)*XB(K2,K1)
   77   CONTINUE
    7 CONTINUE

c      P(K)=XD(K,K')*T(K')

      DO 8 K=1,KX
      DO 8 K1=1,KX
        XD(K,K1)=0.
    8 CONTINUE

      DO 91 K=1,KX
      DO 91 K1=K+1,KX
        XD(K,K1)=RGAS*LOG(HSG(K1+1)/HSG(K1))
   91 CONTINUE
      DO 92 K=1,KX
        XD(K,K)=RGAS*LOG(HSG(K+1)/FSG(K))
   92 CONTINUE

c      P(K)=YE(K)+XE(K,K')*D(K')

      DO 10 K=1,KX
      DO 10 K1=1,KX
        XE(K,K1)=0.
      DO 10 K2=1,KX
        XE(K,K1)=XE(K,K1)+XD(K,K2)*XC(K2,K1)
   10 CONTINUE

      DO 11 L=1,LMAX
        XXX=(FLOAT(L)*FLOAT(L+1))/(A*A)
        DO 12 K=1,KX
        DO 12 K1=1,KX
          XF(K,K1,L)=XI*XI*XXX*(RGAS*TREF(K)*DHS(K1)-XE(K,K1))
   12   CONTINUE
        DO 13 K=1,KX
          XF(K,K,L)=XF(K,K,L)+1.
   13   CONTINUE
   11 CONTINUE

      DO 30 L=1,LMAX
        CALL INV(XF(1,1,L),XJ(1,1,L),INDX,KX)
   30 CONTINUE

      DO 50 K=1,KX
      DO 50 K1=1,KX
        XC(K,K1)=XC(K,K1)*XI
   50 CONTINUE

      RETURN
      END


C Copyright(C) 1999-2020 National Technology & Engineering Solutions
C of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C NTESS, the U.S. Government retains certain rights in this software.
C
C See packages/seacas/LICENSE for details

C=======================================================================
      SUBROUTINE WRPXYZ (XN, YN, XN3, YN3, ZN3, ATRIB)
C=======================================================================

C   --*** WRPXYZ *** (GEN3D) Calculate 3D coordinates
C   --   Written by Amy Gilkey - revised 05/09/88
C   --   Modified by Greg Sjaardema - 02/06/89
C   --       Added Warp Function
C   --       Added Gradient to Rotations (not for center blocks)
C   --
C   --WRPXYZ calculates the coordinate array for the 3D warp translations.
C   --
C   --Parameters:
C   --   XN, YN - IN - the 2D coordinates, destroyed
C   --   XN3, YN3, ZN3 - OUT - the 3D coordinates
C   --
C   --Common Variables:
C   --   Uses NDIM, NUMNP of /DBNUMS/
C   --   Uses NDIM3, NUMNP3 of /DBNUM3/
C   --   Uses DOTRAN, NNREPL, DIM3, NRTRAN, D3TRAN, ZGRAD,
C   --      CENTER, NUMCOL, NUMROW of /PARAMS/

      INCLUDE 'gs_dbnums.blk'
      INCLUDE 'gs_dbnum3.blk'
      INCLUDE 'gs_params.blk'

      REAL XN(NUMNP), YN(NUMNP),
     &   XN3(NUMNP3), YN3(NUMNP3), ZN3(NUMNP3)
      REAL ATRIB(NUMEL)

      IF (IWARP .EQ. 1) THEN

C ... Warp type 1: Point Centered

         DO 100 INP = 1, NUMNP
            XN3(INP) = XN(INP)
            YN3(INP) = YN(INP)
            ZN3(INP) = DWARP - SQRT(DWARP**2 - XN(INP)**2 - YN(INP)**2)
  100    CONTINUE

         CONTINUE
      ELSE IF (IWARP .EQ. -1) THEN

C ... Warp type -1: X Axis Centered

         DO 110 INP = 1, NUMNP
            THET = YN(INP) / DWARP
            XN3(INP) = XN(INP)
            YN3(INP) = SIN(THET) * DWARP
            ZN3(INP) = DWARP - COS(THET) * DWARP
  110    CONTINUE

      ELSE IF (IWARP .EQ. -2) THEN

C ... Warp type -2: Y Axis Centered

         DO 120 INP = 1, NUMNP
            THET = XN(INP) / DWARP
            XN3(INP) = SIN(THET) * DWARP
            YN3(INP) = YN(INP)
            ZN3(INP) = DWARP - COS(THET) * DWARP
  120    CONTINUE

      ELSE IF (IWARP .EQ. -3) THEN

C ... Warp type -3: X Axis Centered, Project straight up

         DO 130 INP = 1, NUMNP
            XN3(INP) = XN(INP)
            YN3(INP) = YN(INP)
            ZN3(INP) = DWARP - sqrt( dwarp**2 - yn(inp)**2 )
  130    CONTINUE

      ELSE IF (IWARP .EQ. -4) THEN

C ... Warp type -4: Y Axis Centered, Project straight up

         DO 140 INP = 1, NUMNP
            XN3(INP) = XN(INP)
            YN3(INP) = YN(INP)
            ZN3(INP) = DWARP - sqrt( dwarp**2 - xn(inp)**2 )
  140    CONTINUE

      ELSE IF (IWARP .EQ. 2) THEN

C ... Warp type 2: Point-Centered Ellipse

         DO 150 INP = 1, NUMNP
            DX = XN(INP)
            DY = YN(INP)
            ZT = DWARP * (1.0-SQRT(1.0-DX**2/XRAD**2-DY**2/YRAD**2))
            ZN3(INP) = ZT
            YN3(INP) = YN(INP)
            XN3(INP) = XN(INP)
  150    CONTINUE
      END IF

C ... Now do the attributes for all of the elements

      DO 160 IEL = 1, NUMEL
         ATRIB(IEL) = DIM3
  160 CONTINUE

      RETURN
      END


SUBROUTINE p94(input_file,output_file)
!-------------------------------------------------------------------------
! Program 9.4 Plane strain consolidation analysis of a Biot elastic solid
!             using 8-node rectangular quadrilaterals for displacements
!             coupled to 4-node rectangular quadrilaterals for pressures.
!             Freedoms numbered in order u-v-uw. Incremental load version.
!-------------------------------------------------------------------------
 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)
 INTEGER::i,iel,j,k,loaded_nodes,ndim=2,ndof=16,nels,neq,nip=4,nlen,nlfp, &
   nls,nn,nod=8,nodf=4,nodof=3,npri,nprops=4,np_types,nr,nres,nst=3,nstep,&
   ntot=20,nxe,nye
 CHARACTER(LEN=15)::argv,element='quadrilateral'
 REAL(iwp)::det,dtim,theta,time,tot_load,zero=0.0_iwp
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   no(:),num(:)
 REAL(iwp),ALLOCATABLE::al(:),ans(:),bee(:,:),c(:,:),coord(:,:),dee(:,:), &
   der(:,:),derf(:,:),deriv(:,:),derivf(:,:),eld(:),fun(:),funf(:),gc(:), &
   g_coord(:,:),jac(:,:),kay(:,:),ke(:,:),km(:,:),kc(:,:),kv(:),lf(:,:),  &
   loads(:),phi0(:),phi1(:),points(:,:),prop(:,:),sigma(:),               &
   store_kc(:,:,:),val(:,:),vol(:),volf(:,:),weights(:),x_coords(:),      &
   y_coords(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(dee(nst,nst),points(nip,ndim),coord(nod,ndim),derivf(ndim,nodf),&
   jac(ndim,ndim),kay(ndim,ndim),der(ndim,nod),deriv(ndim,nod),           &
   derf(ndim,nodf),funf(nodf),bee(nst,ndof),km(ndof,ndof),kc(nodf,nodf),  &
   g_g(ntot,nels),ke(ntot,ntot),c(ndof,nodf),x_coords(nxe+1),             &
   y_coords(nye+1),vol(ndof),nf(nodof,nn),g(ntot),volf(ndof,nodf),        &
   g_coord(ndim,nn),g_num(nod,nels),num(nod),weights(nip),                &
   store_kc(nodf,nodf,nels),phi0(nodf),phi1(nodf),prop(nprops,np_types),  &
   etype(nels),eld(ndof),gc(ndim),sigma(nst),fun(nod))
 READ(10,*)prop
 etype=1
 if(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords
 READ(10,*)dtim,nstep,theta,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq),ans(0:neq))
 READ(10,*)loaded_nodes
 ALLOCATE(no(loaded_nodes),val(loaded_nodes,ndim))
 READ(10,*)(no(i),val(i,:),i=1,loaded_nodes)
 READ(10,*)nlfp
 ALLOCATE(lf(2,nlfp))
 READ(10,*)lf
 nls=FLOOR(lf(1,nlfp)/dtim)
 IF(nstep>nls)nstep=nls
 ALLOCATE(al(nstep))
 CALL load_function(lf,dtim,al)
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'x')
   g(1:15:2)=nf(1,num(:))
   g(2:16:2)=nf(2,num(:))
   g(17:)=nf(3,num(1:7:2))
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
 CALL sample(element,points,weights)
 loads=zero
 kv=zero
!-----------------------global matrix assembly----------------------------
 elements_2: DO iel=1,nels
   kay=zero
   DO i=1,ndim
     kay(i,i)=prop(i,etype(iel))
   END DO
   CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   c=zero
   kc=zero
 gauss_points_1: DO i=1,nip
!-----------------------elastic solid contribution------------------------
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL beemat(bee,deriv)
     vol(:)=bee(1,:)+bee(2,:)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)
!-----------------------fluid contribution--------------------------------
     CALL shape_fun(funf,points,i)
     CALL shape_der(derf,points,i)
     derivf=MATMUL(jac,derf)
     kc=kc+MATMUL(MATMUL(TRANSPOSE(derivf),kay),derivf)*det*weights(i)*dtim
     CALL cross_product(vol,funf,volf)
     c=c+volf*det*weights(i)
   END DO gauss_points_1
   store_kc(:,:,iel)=kc
   CALL formke(km,kc,c,ke,theta)
   CALL fsparv(kv,ke,g,kdiag)
 END DO elements_2
 CALL sparin_gauss(kv,kdiag) !---factorise equations----
 !-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I5)')" Results at node",nres
 WRITE(11,'(A)')                                                          &
   "    time        load        x-disp      y-disp   porepressure"
 WRITE(11,'(5E12.4)')0.0,0.0,loads(nf(:,nres))
 time_steps: DO j=1,nstep
   tot_load=SUM(al(1:j))
   time=j*dtim
   ans=zero
   elements_3: DO iel=1,nels
     g=g_g(:,iel)
     kc=store_kc(:,:,iel)
     phi0=loads(g(ndof+1:))
     phi1=MATMUL(kc,phi0)
     ans(g(ndof+1:))=ans(g(ndof+1:))+phi1
   END DO elements_3
!-----------------------apply loading increment---------------------------
   DO i=1,loaded_nodes
     ans(nf(1:2,no(i)))=val(i,:)*al(j)
   END DO
!-----------------------equation solution---------------------------------
   CALL spabac_gauss(kv,ans,kdiag)
   loads=loads+ans
   loads(0)=zero
   IF(j/npri*npri==j)WRITE(11,'(5E12.4)')time,tot_load,loads(nf(:,nres))
!-----------------------recover stresses at nip integrating points--------
!   nip=1DEALLOCATE(points,weights)
!   ALLOCATE(points(nip,ndim),weights(nip))
!   CALL sample(element,points,weights)
!   WRITE(11,'(A,I2,A)')" The integration point (nip=",nip,") stresses are:"
!   WRITE(11,'(A,A)')" Element x-coord     y-coord",                       &
!                    "     sig_x       sig_y       tau_xy"
!   elements_4: DO iel=1,nelsnum=g_num(:,iel)
!     coord=TRANSPOSE(g_coord(:,num))g=g_g(:,iel)eld=loads(g(:ndof))
!     CALL deemat(dee,prop(3,etype(iel)),prop(4,etype(iel)))
!     gauss_pts_2: DO i=1,nip
!       CALL shape_fun(fun,points,i)CALL shape_der(der,points,i)
!       gc=MATMUL(fun,coord)jac=MATMUL(der,coord)CALL invert(jac)
!       deriv=MATMUL(jac,der)CALL beemat(bee,deriv)
!       sigma=MATMUL(dee,MATMUL(bee,eld))
!       IF(j/npri*npri==j)WRITE(11,'(I5,6E12.4)')iel,gc,sigma
!     END DO gauss_pts_2
!   END DO elements_4
 END DO time_steps
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p94


      double precision function DCSPXX (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-07-16 DCSPXX Krogh  -1.0 changed to -1.D0.
C>> 1998-10-29 DCSPXX Krogh  Moved external statement up for mangle.
c>> 1996-01-08 DCSPXX WV Snyder Original code
c--D replaces "?": ?CSPXX, ?COSPX, ?SINPX

c COS(PI * X * X / 2) carefully to avoid loss of precision for large X

      double precision X

c DCOSPX is used to compute COS(PI * X)

      external D1MACH, DCOSPX, DSINPX
      double precision D1MACH, DCOSPX, DSINPX

c BIGX = 1 / round-off = biggest integer exactly representable by F.P.
c    If X > BIGX then to the working precision x**2 is an integer (which
c    we assume to be a multiple of four), so cos(pi/2 * x**2) = 1.
c N = [X], and later [K F]
c F = X - N = fractional part of X
c K = [ N / 2 ]
c J = N mod 2
c M = [K F]
c G = K F - M = fractional part of K F

      integer J, K, N
      double precision BIGX, F, G
      save BIGX
      data BIGX /-1.0d0/

      if (bigx .lt. 0.0d0) bigx = 1.0d0 / d1mach(4)
      f = abs(x)
      if (f .gt. bigx) then
c       Assume x is an even integer.
        dcspxx = 1.0d0
        return
      endif
      n = f
      f = f - n
      k = n / 2
      j = mod(n,2)
      g = k * f
      n = g
      g = g - n
      if (j .eq. 0) then
        dcspxx = dcospx(0.5d0*f*f + g + g)
      else
        dcspxx = -dsinpx(0.5d0*f*f + f + g + g)
      endif
      return
      end


      SUBROUTINE lpbut3p( corner, sample, number, data )
c     lpbut3p is a recursive three-pole Butterworth low-pass filter.
c    Taken from Gold and Rader, "Digital Processing of Signals", pg57
c
c  ARGUMENTS:
c  corner - the corner frequency in hertz
c  sample - the sampling frequency in hertz
c  number - the number of data points in the time series
c  data   - the input and output data array
c
c  Variables:
c  delay  - unfiltered data for the previous point
c  twc    - corner / sample
c
      REAL data(111)

      twc = corner / sample
      expon = EXP(-twc)
      expon2 = EXP(-twc / 2. )
      term = twc * SQRT(3.) / 2.
      beta = 2. * expon2 * COS(term)
      eta = expon2 * (COS(term) + SIN(term) / SQRT(3.))
      delay = data(2)
      delayd = 0.
      delay1 = 0.
      delay2 = 0.

      DO 510 i = 3, number
         out1 = twc * data(i) + expon * delay
         out2 = twc * (eta*delayd-data(i)) + beta*delay1 - expon*delay2
         delayd = data(i)
         delay = out1
         delay2 = delay1
         delay1 = out2
         data(i) = -(out1 + out2)
  510 CONTINUE

      RETURN
      END


      SUBROUTINE MB04OX( N, A, LDA, X, INCX )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To perform the QR factorization
C
C        (U ) = Q*(R),
C        (x')     (0)
C
C     where U and R are n-by-n upper triangular matrices, x is an
C     n element vector and Q is an (n+1)-by-(n+1) orthogonal matrix.
C
C     U must be supplied in the n-by-n upper triangular part of the
C     array A and this is overwritten by R.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N      (input) INTEGER
C            The number of elements of X and the order of the square
C            matrix A.  N >= 0.
C
C     A      (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C            On entry, the leading N-by-N upper triangular part of this
C            array must contain the upper triangular matrix U.
C            On exit, the leading N-by-N upper triangular part of this
C            array contains the upper triangular matrix R.
C            The strict lower triangle of A is not referenced.
C
C     LDA    INTEGER
C            The leading dimension of the array A.  LDA >= max(1,N).
C
C     X      (input/output) DOUBLE PRECISION array, dimension
C            (1+(N-1)*INCX)
C            On entry, the incremented array X must contain the
C            vector x. On exit, the content of X is changed.
C
C     INCX   (input) INTEGER.
C            Specifies the increment for the elements of X.  INCX > 0.
C
C     METHOD
C
C     The matrix Q is formed as a sequence of plane rotations in planes
C     (1, n+1), (2, n+1), ..., (n, n+1), the rotation in the (j, n+1)th
C     plane, Q(j), being chosen to annihilate the jth element of x.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 1998.
C     Based on the RASP routine DUTUPD.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      INTEGER            INCX, LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*), X(*)
C     .. Local Scalars ..
      DOUBLE PRECISION   CI, SI, TEMP
      INTEGER            I, IX
C     .. External Subroutines ..
      EXTERNAL           DLARTG, DROT
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked.
C
      IX = 1
C
      DO 20 I = 1, N - 1
         CALL DLARTG( A(I,I), X(IX), CI, SI, TEMP )
         A(I,I) = TEMP
         IX = IX + INCX
         CALL DROT( N-I, A(I,I+1), LDA, X(IX), INCX, CI, SI )
   20 CONTINUE
C
      CALL DLARTG( A(N,N), X(IX), CI, SI, TEMP )
      A(N,N) = TEMP
C
      RETURN
C *** Last line of MB04OX ***
      END


!##############################################################################
!# Tutorial 022a: Calculate an L2 and H1 norm with standard integration
!##############################################################################

module tutorial022a

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

  use triangulation
  use meshgeneration

  use element
  use cubature
  use spatialdiscretisation
  use linearsystemscalar
  use linearsystemblock
  use bilinearformevaluation

  use derivatives
  use domainintegration
  use collection
  use pprocerror

  implicit none
  private

  public :: start_tutorial022a

contains

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

  subroutine start_tutorial022a

    ! Declare some variables.
    type(t_triangulation) :: rtriangulation
    type(t_spatialDiscretisation) :: rspatialDiscr
    type(t_blockDiscretisation) :: rblockDiscr
    type(t_scalarCubatureInfo), target :: rcubatureInfo
    type(t_vectorBlock) :: rx

    integer :: ivt
    real(DP) :: dx, dintvalue
    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 022a")
    call output_separator (OU_SEP_MINUS)

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

    ! The mesh must always be in "standard" format.
    ! First create a 9x9-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, 8, 8)
    call tria_initStandardMeshFromRaw (rtriangulation)

    ! =================================
    ! Discretise with Q1.
    !
    ! Create a structure rspatialDiscr
    ! which describes the discretisation.
    ! We generate a 1x1 system with Q1.
    ! =================================

    ! Create a spatial discretisation with Q1
    call spdiscr_initDiscr_simple (rspatialDiscr,EL_Q1_2D,rtriangulation)

    ! Create a block discretisation with 1 block Q1.
    call spdiscr_initBlockDiscr (rblockDiscr,rtriangulation)
    call spdiscr_appendBlockComponent (rblockDiscr,rspatialDiscr)
    call spdiscr_commitBlockDiscr (rblockDiscr)

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

    ! Create a vector.
    call lsysbl_createVector (rblockDiscr,rx)

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

    ! Get a pointer to the data.
    call lsyssc_getbase_double (rx%RvectorBlock(1),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) = 1/exp(x)
    do ivt=1,rx%NEQ
      dx = p_DvertexCoords(1,ivt)
      p_Ddata(ivt) = 1.0_DP / exp(dx)
    end do

    ! =================================
    ! Define cubature formula
    ! =================================

    ! Use a Gauss 3x3 formula for the discretisation.
    call spdiscr_createDefCubStructure (rspatialDiscr,rcubatureInfo,CUB_GEN_AUTO_G3)

    ! =================================
    ! Calculate the L2-norm of u
    ! =================================

    ! Calculate the "error" between the FE function and the zero function.
    ! This gives the L2 norm.
    call pperr_scalar (PPERR_L2ERROR, dintvalue, rx%RvectorBlock(1),&
        rcubatureInfo=rcubatureInfo)

    call output_line ("L2-norm = "//trim(sys_sdL(dintvalue,10)))

    ! =================================
    ! Calculate the H1-(semi)norm of u
    ! =================================

    ! Calculate the "error" between the FE function and the zero function.
    ! This gives the H1 (semi-)norm.
    call pperr_scalar (PPERR_H1ERROR, dintvalue, rx%RvectorBlock(1),&
        rcubatureInfo=rcubatureInfo)

    call output_line ("H1-norm = "//trim(sys_sdL(dintvalue,10)))

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

    ! Release the vector
    call lsysbl_releaseVector (rx)

    ! Cubature done.
    call spdiscr_releaseCubStructure (rcubatureInfo)

    ! Release the discretisation
    call spdiscr_releaseBlockDiscr (rblockDiscr)
    call spdiscr_releaseDiscr (rspatialDiscr)

    ! Release the triangulation
    call tria_done (rtriangulation)

  end subroutine

end module


       implicit none
       double complex qlI1,qlI2,qlI3,qlI4,Ival(-2:0)
       double precision p1sq,p2sq,p3sq,p4sq,s12,s23
       double precision m1sq,m2sq,m3sq,m4sq,musq
       integer ep
       call qlinit
       musq=1.e6
       open(unit=301,file="scalar.tmp")
       m1sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=30625.
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=159734.90989225
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=263235.89945104
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=295638.72429289005
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=297274.1172122501
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=323125.28416921
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       m1sq=343145.00348164
       do ep=0,-2,-1
          Ival(ep)=qlI1(m1sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-449282.61956417596
       m1sq=0.
       m2sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-449282.61956417596
       m1sq=0.
       m2sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-449282.61956417596
       m1sq=0.
       m2sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-218256.45810044397
       m1sq=0.
       m2sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-218256.45810044397
       m1sq=0.
       m2sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=-218256.45810044397
       m1sq=0.
       m2sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       m1sq=166230.46116769002
       m2sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=263235.89945104
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=295638.72429289005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=297274.1172122501
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=0.
       m2sq=323125.28416921
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=30625.
       m2sq=159734.90989225
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       m1sq=30625.
       m2sq=343145.00348164
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=0.
       m2sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=30625.
       m2sq=30625.
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=159734.90989225
       m2sq=159734.90989225
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=166230.46116769002
       m2sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=263235.89945104
       m2sq=263235.89945104
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=295638.72429289005
       m2sq=295638.72429289005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=297274.1172122501
       m2sq=297274.1172122501
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=301685.77863649005
       m2sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=314854.532161
       m2sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=323125.28416921
       m2sq=323125.28416921
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=1.e6
       m1sq=343145.00348164
       m2sq=343145.00348164
       do ep=0,-2,-1
          Ival(ep)=qlI2(p1sq,m1sq,m2sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=1.e6
       m1sq=0.
       m2sq=0.
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=1.e6
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       m3sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=1.e6
       m1sq=166230.46116769002
       m2sq=314854.532161
       m3sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=1.e6
       m1sq=301685.77863649005
       m2sq=166230.46116769002
       m3sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=1.e6
       m1sq=314854.532161
       m2sq=166230.46116769002
       m3sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=166230.46116769002
       m2sq=314854.532161
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=301685.77863649005
       m2sq=166230.46116769002
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-449282.61956417596
       m1sq=314854.532161
       m2sq=166230.46116769002
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=166230.46116769002
       m2sq=314854.532161
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=301685.77863649005
       m2sq=166230.46116769002
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=-218256.45810044397
       m1sq=314854.532161
       m2sq=166230.46116769002
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=166230.46116769002
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=263235.89945104
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=295638.72429289005
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=297274.1172122501
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=301685.77863649005
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=314854.532161
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=0.
       m2sq=323125.28416921
       m3sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=30625.
       m2sq=159734.90989225
       m3sq=30625.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=30625.
       m2sq=343145.00348164
       m3sq=30625.
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=159734.90989225
       m2sq=30625.
       m3sq=159734.90989225
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=166230.46116769002
       m2sq=0.
       m3sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=263235.89945104
       m2sq=0.
       m3sq=263235.89945104
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=295638.72429289005
       m2sq=0.
       m3sq=295638.72429289005
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=297274.1172122501
       m2sq=0.
       m3sq=297274.1172122501
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=301685.77863649005
       m2sq=0.
       m3sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=314854.532161
       m2sq=0.
       m3sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=323125.28416921
       m2sq=0.
       m3sq=323125.28416921
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=166230.46116769002
       p2sq=166230.46116769002
       p3sq=1.e6
       m1sq=343145.00348164
       m2sq=30625.
       m3sq=343145.00348164
       do ep=0,-2,-1
          Ival(ep)=qlI3(p1sq,p2sq,p3sq,m1sq,m2sq,m3sq,musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       m3sq=166230.46116769002
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=166230.46116769002
       m2sq=314854.532161
       m3sq=166230.46116769002
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=301685.77863649005
       m2sq=166230.46116769002
       m3sq=301685.77863649005
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-449282.61956417596
       m1sq=314854.532161
       m2sq=166230.46116769002
       m3sq=314854.532161
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=0.
       m2sq=0.
       m3sq=0.
       m4sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=166230.46116769002
       m2sq=301685.77863649005
       m3sq=166230.46116769002
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=166230.46116769002
       m2sq=314854.532161
       m3sq=166230.46116769002
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=301685.77863649005
       m2sq=166230.46116769002
       m3sq=301685.77863649005
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=0.
       p3sq=166230.46116769002
       p4sq=166230.46116769002
       s12=1.e6
       s23=-218256.45810044397
       m1sq=314854.532161
       m2sq=166230.46116769002
       m3sq=314854.532161
       m4sq=0.
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=0.
       p4sq=166230.46116769002
       s12=-218256.45810044397
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=166230.46116769002
       m4sq=301685.77863649005
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=0.
       p4sq=166230.46116769002
       s12=-218256.45810044397
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=166230.46116769002
       m4sq=314854.532161
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=0.
       p4sq=166230.46116769002
       s12=-218256.45810044397
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=301685.77863649005
       m4sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       p1sq=0.
       p2sq=166230.46116769002
       p3sq=0.
       p4sq=166230.46116769002
       s12=-218256.45810044397
       s23=-449282.61956417596
       m1sq=0.
       m2sq=0.
       m3sq=314854.532161
       m4sq=166230.46116769002
       do ep=0,-2,-1
          Ival(ep)=qlI4(p1sq,p2sq,p3sq,p4sq,s12,s23,m1sq,m2sq,m3sq,m4sq,
     $          musq,ep)
          write(301,*)dreal(Ival(ep))
          write(301,*)dimag(Ival(ep))
       enddo
       close(unit=301,status="KEEP")
       end


C-----------------------------------------------------------------------
C
C     COPYRIGHT (C) 1992  MASSACHUSETTS INSTITUTE OF TECHNOLOGY
C
C-----------------------------------------------------------------------
C
C     Main program 'sphere'
C
C-----------------------------------------------------------------------
C
C This program generates a geometric data file for a sphere for
C input to the FastLap driver: driver.c.  To modify the output
C for the FastLap driver: driver.f, use c2fdata.
C
C
C Boundary conditions are for a sphere translating in an
C infinite fluid for which the solution is known in closed form.
C
C     Written by T. Korsmeyer, March 1992
C
C-------------------------------------------------------------------------
      PROGRAM SPHERE
      IMPLICIT NONE
      INTEGER MAX_NODE, MAX_PANEL, NODE_TOTAL, PANEL_TOTAL
      PARAMETER (MAX_NODE = 16384)
      PARAMETER (MAX_PANEL = 16384)
      CHARACTER*72 HEAD
      INTEGER NUM_SPHERES
      DOUBLE PRECISION X(3,MAX_NODE)
      DOUBLE PRECISION XC(3,4)
      DOUBLE PRECISION XVER(4,3), XVP(4),YVP(4),XCT(3),DIR(3,3),
     $     SS(15),SID(4),VEL(3),VROT(4,3),DIAG(2)
      INTEGER IDIAG
      DOUBLE PRECISION POTENTIAL, DBYDNPOTEN
      INTEGER FSCON(4,MAX_PANEL), MSCON(4,MAX_PANEL), FSPAN, MSPAN
      INTEGER NFS, NMS, NWL
      INTEGER LFS(MAX_NODE), LMS(MAX_NODE), LWL(MAX_NODE)
      INTEGER INDEX_FS, INDEX_MS, M_FIRST, COUNT_FS, COUNT_MS,
     $     COUNT_WL, NA, NM, OFFSET, I, J, K, N
      DOUBLE PRECISION THETA, PHI, D_THETA, D_PHI, R, D_R, PI, RAD,
     $     CLOSENESS
      DOUBLE PRECISION  PHI_NORM, PHIN_NORM, MAX_PHI, MAX_PHIN
      INTEGER TYPE
      DOUBLE PRECISION DUM
      DATA DUM / 1.0D00 /
      PARAMETER(RAD = 1.0)
      DATA PI / 3.1415927 /
C
C Define output device number and name.
C
      CHARACTER*20 FASTIN
      DATA FASTIN /'fastlap.in'/
C
C Output heading, and query on output files.
C
      WRITE (6,935)
 935  FORMAT(1X,/,
     &' A new panelization will be generated for a sphere.'///)
 1    CONTINUE
C
C Query on panelization.
C
 2    CONTINUE
      WRITE (6,941)
 941  FORMAT(1X,//5X,71(1H-),//
     &  8X,' The number of panels is specified by two inputs:'//
     &  8X,' Number from pole to pole:   ',$)
      READ (5,*) NA
      NA = NA / 2
      WRITE (6,942)
 942  FORMAT(1X,/
     &  8X,' Number around any parallel of latitude:   ',$)
      READ (5,*) NM
      OPEN (UNIT=14,FILE=FASTIN,STATUS='UNKNOWN')
C
C Generate nodes on the upper and lower surfaces.  We do them both
C at once because they have common x,y coordinates, only their elevation
C is different. Bottom dead center and top dead center are common to
C every meridian,  so don't repeat them.
C
      NFS = (NA-1) * NM + 1
      NMS = NFS
      NWL = NM
      FSPAN = NM * NA
      MSPAN = NM * NA
      NODE_TOTAL = NFS + NWL + NMS
      PANEL_TOTAL = FSPAN + MSPAN
      IF (NODE_TOTAL .GT. MAX_NODE) THEN
         WRITE(6,'('' Node dimension of '',I5,
     $        '' is exceeded, try again.'')') MAX_NODE
         GO TO 2
      END IF
      IF (PANEL_TOTAL .GT. MAX_PANEL) THEN
         WRITE(6,'('' Panel dimension of '',I5,
     $        '' is exceeded, try again.'')') MAX_PANEL
         GO TO 2
      END IF
      D_R = RAD / NA
      D_THETA = PI / (2. * NA)
      D_PHI = (2.0 * PI) / NM
      M_FIRST = NFS + NWL + 1
      INDEX_FS = 1
      INDEX_MS = M_FIRST
      COUNT_FS = 1
      COUNT_MS = 1
      COUNT_WL = 1
      X(1,INDEX_FS) = 0.0
      X(2,INDEX_FS) = 0.0
      X(3,INDEX_FS) = RAD
      X(1,INDEX_MS) =  0.0
      X(2,INDEX_MS) =  0.0
      X(3,INDEX_MS) = -RAD
      LFS(COUNT_FS) = INDEX_FS
      LMS(COUNT_MS) = INDEX_MS
      COUNT_FS = COUNT_FS + 1
      COUNT_MS = COUNT_MS + 1
C
C Add these nodes to the node lists
C
C
C Loop along the parallels.
C
      DO J = 0, NM-1
         PHI = J * D_PHI
C
C Loop along the meridians, but don't do the equator.
C
         DO I = 1, NA-1
            R = I * D_R
            THETA = PI - (I * D_THETA)
            INDEX_FS = INDEX_FS + 1
            INDEX_MS = INDEX_MS + 1
            X(1,INDEX_MS) = RAD * SIN(THETA) * COS(PHI)
            X(2,INDEX_MS) = RAD * SIN(THETA) * SIN(PHI)
            X(3,INDEX_MS) = RAD * COS(THETA)
            X(1,INDEX_FS) =  X(1,INDEX_MS)
            X(2,INDEX_FS) =  X(2,INDEX_MS)
            X(3,INDEX_FS) = -X(3,INDEX_MS)
            LFS(COUNT_FS) = INDEX_FS
            LMS(COUNT_MS) = INDEX_MS
            COUNT_FS = COUNT_FS + 1
            COUNT_MS = COUNT_MS + 1
         END DO
C
C Now do the waterline.
C
         THETA = PI - (I * D_THETA)
         INDEX_FS = INDEX_FS + 1
         X(1,INDEX_FS) = RAD * SIN(THETA) * COS(PHI)
         X(2,INDEX_FS) = RAD * SIN(THETA) * SIN(PHI)
         X(3,INDEX_FS) = 0.0
         LWL(COUNT_WL) = INDEX_FS
         COUNT_WL = COUNT_WL + 1
      END DO
C
C Generate the connectivity of the panels.  Vertex numbering is
C clockwise from inside the fluid domain.
C
      INDEX_FS = 0
      INDEX_MS = 0
      DO J = 1, NM
C
C First do the top and bottom dead center panels which are special.
C
         INDEX_FS = INDEX_FS + 1
         INDEX_MS = INDEX_MS + 1
         FSCON(4,INDEX_FS) = 1
         FSCON(3,INDEX_FS) = 2 + NA * (J-1)
         FSCON(2,INDEX_FS) = 2 + NA * J
         FSCON(1,INDEX_FS) = 1
         MSCON(1,INDEX_MS) = M_FIRST
         MSCON(2,INDEX_MS) = M_FIRST + 1 + (NA-1) * (J-1)
         MSCON(3,INDEX_MS) = M_FIRST + 1 + (NA-1) * J
         MSCON(4,INDEX_MS) = M_FIRST
C
C Now do the rest EXCEPT for the panels sharing the equator.
C
         DO I = 2, NA-1
            INDEX_FS = INDEX_FS + 1
            INDEX_MS = INDEX_MS + 1
            FSCON(4,INDEX_FS) = NA * (J-1) + I
            FSCON(1,INDEX_FS) = NA * J + I
            FSCON(3,INDEX_FS) = FSCON(4,INDEX_MS) + 1
            FSCON(2,INDEX_FS) = FSCON(1,INDEX_MS) + 1
            MSCON(1,INDEX_MS) = (NA-1) * (J-1) + (M_FIRST-1) + I
            MSCON(4,INDEX_MS) = (NA-1) * J + (M_FIRST-1) + I
            MSCON(3,INDEX_MS) = MSCON(4,INDEX_MS) + 1
            MSCON(2,INDEX_MS) = MSCON(1,INDEX_MS) + 1
         END DO
C
C Now do the equator panels.
C
         INDEX_FS = INDEX_FS + 1
         INDEX_MS = INDEX_MS + 1
         FSCON(4,INDEX_FS) = NA * (J-1) + NA
         FSCON(1,INDEX_FS) = NA * J + NA
         FSCON(3,INDEX_FS) = FSCON(4,INDEX_MS) + 1
         FSCON(2,INDEX_FS) = FSCON(1,INDEX_MS) + 1
         MSCON(1,INDEX_MS) = (NA-1) * (J-1) + (M_FIRST-1) + NA
         MSCON(4,INDEX_MS) = (NA-1) * J + (M_FIRST-1) + NA
         MSCON(2,INDEX_MS) = 1 + J * NA
         MSCON(3,INDEX_MS) = 1 + (J+1) * NA
      END DO
C
C Now correct the last strip of panels on which the node numbers will exceed
C the max node number unless they are wrapped into the first strip of nodes.
C
      OFFSET = NM*NA-NA
      DO I = 1,NA
         FSCON(2,OFFSET+I) = FSCON(3,I)
         FSCON(1,OFFSET+I) = FSCON(4,I)
         MSCON(4,OFFSET+I) = MSCON(1,I)
         MSCON(3,OFFSET+I) = MSCON(2,I)
      END DO
      WRITE (6,903)
 903  FORMAT (1X,/,' Enter header line for gdf file: ',$)
      READ (5,902) HEAD
 902  FORMAT (A72)
      WRITE (14,905) HEAD
 905  FORMAT ('0  ',A72)
      WRITE(*,'('' What type on trailing half? 0=Dirichlet''
     $     '' 1=Neumann.'')')
      READ(5,*) type
      MAX_PHI = 0.0
      MAX_PHIN = 0.0
      PHI_NORM = 0.0
      PHIN_NORM = 0.0
      DO I = 1, FSPAN
         DO J = 1,4
            XC(1,J) = X(1,FSCON(J,I))
            XC(2,J) = X(2,FSCON(J,I))
            XC(3,J) = X(3,FSCON(J,I))
         END DO
c
c Find the centroid of the panel.
c
         CALL PANEL(XC,XCT,DIR,XVP,YVP,SS,SID)
         POTENTIAL = -0.5 * XCT(3)
         DBYDNPOTEN = -XCT(3)
         IF (type .eq. 1) THEN
C
C This is a panel on which PHI is the unknown.
C
            PHI_NORM = PHI_NORM + ABS(POTENTIAL)
            MAX_PHI = MAX(ABS(POTENTIAL),MAX_PHI)
         ELSE
C
C This is a panel on which PHIN is the unknown.
C
            PHIN_NORM = PHIN_NORM + ABS(DBYDNPOTEN)
            MAX_PHIN = MAX(ABS(DBYDNPOTEN),MAX_PHIN)
         END IF
         IF (FSCON(1,I) .EQ. FSCON(4,I)) THEN
            WRITE(14,951) ((XC(K,J),K=1,3),J=1,3),
     $           POTENTIAL,DBYDNPOTEN,TYPE
         ELSE
            WRITE(14,950) ((XC(K,J),K=1,3),J=1,4),
     $           POTENTIAL,DBYDNPOTEN,TYPE
         END IF
      END DO
      write(*,'('' What type on leading half? 0=Dirichlet''
     $     '' 1=Neumann.'')')
      read(5,*) type
      DO I = 1, MSPAN
         DO J = 1,4
            XC(1,J) = X(1,MSCON(J,I))
            XC(2,J) = X(2,MSCON(J,I))
            XC(3,J) = X(3,MSCON(J,I))
         END DO
c
c Find the centroid of the panel.
c
         CALL PANEL(XC,XCT,DIR,XVP,YVP,SS,SID)
         POTENTIAL = -0.5 * XCT(3)
         DBYDNPOTEN = -XCT(3)
         IF (MSCON(1,I) .EQ. MSCON(4,I)) THEN
            WRITE(14,951) ((XC(K,J),K=1,3),J=1,3),
     $           POTENTIAL,DBYDNPOTEN,TYPE
         ELSE
            WRITE(14,950) ((XC(K,J),K=1,3),J=1,4),
     $           POTENTIAL,DBYDNPOTEN,TYPE
         END IF
      END DO
      WRITE(*,'(''Number of panels in fastlap.in:'',I5)')
     $     FSPAN + MSPAN
 950  FORMAT('Q  ',14f18.14,i3)
 951  FORMAT('T  ',11f18.14,i3)
 952  FORMAT(12E12.4)
      STOP
      END
C
C
C
      SUBROUTINE PANEL(V,XCTP,DIRP,XVP,YVP,S,SIDE)
C-----------------------------------------------------------------------
C
C     COPYRIGHT (C) 1988,1991 MASSACHUSETTS INSTITUTE OF TECHNOLOGY
C
C-----------------------------------------------------------------------
C
C     DESCRIPTION : Subroutine PANEL evaluates geometrical data for a
C     plane quadrilateral approximating in a mean sense the curvilinear
C     surface defined by four input vertices (not lying on a plane).
C     Adjacent vertices are connected by straight segments. The plane of
C     the quadrilateral is defined by the segment midpoints and its
C     vertices by the projection of the original vetrices on that plane.
C
C-----------------------------------------------------------------------
C
C     Input arguments (in alphabetical order) :
C
C     Name              Description
C     ------------------------------------------------------------------
C     V(I,J)            Body-system coordinates (x,y,z)<=>J=1,2,3
C                       of I-th vertex, I=1,..,4 of current panel
C
C     Output Arguments (in alphabetical order) :
C
C     Symbolic       Description
C     name
C     ------------------------------------------------------------------
C     DIRP(I,J)      Direction cosines of axes of panel coordinate
C                      system for current panel, relative to axes of
C                      body coordinate system
C                      I=1,2,3 <=> (x,y,z) axes of panel system,
C                      J=1,2,3 <=> (x,y,z) axes of body system
C     S(K)           Moments of inertia of current quadrilateral
C                      surface w.r.t. panel coordinate system, K=1,..,15
C                      Defined as in subroutine GEOM
C     XVP(I),YVP(I)    Panel coordinates of I-th vertex of current
C                      quadrilateral, I=1,..,4
C     SIDE(I)        Length of four sides (I=1,..,4) of current
C                      quadrilateral numbered couter-clockwise and
C                      defined so that SIDE(1) connects vertex 1 to
C                      vertex 2
C     XCTP(I)        Body-system coordinates of centroid of N-th
C                      quadrilateral, (x,y,z) <=> I=1,2,3
C
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION V(3,4),XCTP(*),XVP(*),YVP(*),DIRP(3,*),S(*),SIDE(*)
C-----------------------------------------------------------------------
C     Allocate space for local arrays
C-----------------------------------------------------------------------
      DIMENSION XORP(3),UL(3),VL(3),N1(4),DX(4),DY(4),
     &          IX(4),IY(4),XP(6,4),YP(6,4),CS(15),K1(5)
      DATA  ONE /1.E+00/, HALF / 0.5E+00/, QUART / 0.25E+00/,
     &      ZERO/ 0.0E+0/, GND/ 0.5773503E+00 /,
     &      TOLS / 1.E-10/, TOLT / 1.E-12 /, THIRD / 0.3333333E+00/,
     &      CS / 1., 1., 1.5, 1.5, 3.75, 1., 3.0, 1.5, 7.5, 1.5, 1.5,
     &           3.75, 1.5, 7.5, 3.75 /,
     &      IX / 1, 1, -1, -1/, IY / 1, -1, -1, 1/,
     &      K1 / 1, 6, 10, 13, 15 /,  N1 / 2, 3, 4, 1 /
      DO 10 J=1,3
        XORP(J)=((V(J,1)+V(J,2))+(V(J,3)+V(J,4)))*QUART
        UL(J)=(V(J,1)+V(J,2))-(V(J,3)+V(J,4))
        VL(J)=(V(J,1)+V(J,4))-(V(J,2)+V(J,3))
10    CONTINUE
C-----------------------------------------------------------------------
C     Evaluation of direction cosines DIRP(3,3) of local coordinate
C     system
C-----------------------------------------------------------------------
      ULSQ=SQRT(UL(1)*UL(1)+UL(2)*UL(2)+UL(3)*UL(3))
      DIRP(1,1)=UL(1)/ULSQ
      DIRP(1,2)=UL(2)/ULSQ
      DIRP(1,3)=UL(3)/ULSQ
      UL(1)=( DIRP(1,2)*VL(3)-DIRP(1,3)*VL(2))
      UL(2)=(-DIRP(1,1)*VL(3)+DIRP(1,3)*VL(1))
      UL(3)=( DIRP(1,1)*VL(2)-DIRP(1,2)*VL(1))
      ULSQ=SQRT(UL(1)*UL(1)+UL(2)*UL(2)+UL(3)*UL(3))
      DIRP(3,1)=UL(1)/ULSQ
      DIRP(3,2)=UL(2)/ULSQ
      DIRP(3,3)=UL(3)/ULSQ
      DIRP(2,1)= DIRP(3,2)*DIRP(1,3)-DIRP(3,3)*DIRP(1,2)
      DIRP(2,2)=-DIRP(3,1)*DIRP(1,3)+DIRP(3,3)*DIRP(1,1)
      DIRP(2,3)= DIRP(3,1)*DIRP(1,2)-DIRP(3,2)*DIRP(1,1)
C-----------------------------------------------------------------------
C     Evaluation of vertex coordinates relative to local coordinate
C     system.
C-----------------------------------------------------------------------
      DO 30 I=1,4
        XVP(I)=DIRP(1,1)*(V(1,I)-XORP(1))+
     &          DIRP(1,2)*(V(2,I)-XORP(2)) + DIRP(1,3)*(V(3,I)-XORP(3))
        YVP(I)=DIRP(2,1)*(V(1,I)-XORP(1))+
     &          DIRP(2,2)*(V(2,I)-XORP(2)) + DIRP(2,3)*(V(3,I)-XORP(3))
30    CONTINUE
C-----------------------------------------------------------------------
C     Calculation of local coordinates of Gaussian integration
C     nodes and corresponding weights. Evaluation of quadrilateral
C     centroid. Transfer of local system origin at centroid
C-----------------------------------------------------------------------
      A1 = (XVP(1)+XVP(2))*HALF
      A2 = (XVP(1)+XVP(4))*HALF
      A3 = (XVP(1)+XVP(3))*HALF
      B1 = (YVP(1)+YVP(2))*HALF
      B2 = (YVP(1)+YVP(4))*HALF
      B3 = (YVP(1)+YVP(3))*HALF
      D0 = A1*B2-A2*B1
      D1 = A1*B3-A3*B1
      D2 = A3*B2-A2*B3
      D0I = THIRD / D0
      UL(1) = (D1*A1+D2*A2)*D0I
      UL(2) = (D1*B1+D2*B2)*D0I
      DO 40 J = 1,4
        XVP(J) = XVP(J) - UL(1)
        YVP(J) = YVP(J) - UL(2)
40    CONTINUE
C-----------------------------------------------------------------------
C    Evaluation of coordinates of centroid and Gaussian nodes relative
C    to reference system
C-----------------------------------------------------------------------
      DO 60 J=1,3
        DSUM = DIRP(1,J) * UL(1) + DIRP(2,J) * UL(2)
        XCTP(J) = DSUM + XORP(J)
60    CONTINUE
C-----------------------------------------------------------------------
C     Evaluation of moments of quadrilateral surface relative to
C     local system, array S(15).  First initialize array
C     Note that S(2)=S(6)=0 due to transfer above
C-----------------------------------------------------------------------
      DO 70 N=1,15
        S(N)=ZERO
70    CONTINUE
C-----------------------------------------------------------------------
C     Evaluation of higher powers of vertex coordinates.
C-----------------------------------------------------------------------
      DO 80 N=1,4
        XP(1,N)=XVP(N)
        YP(1,N)=YVP(N)
        DO 75 M=2,6
          XP(M,N)=XP(1,N)*XP(M-1,N)
          YP(M,N)=YP(1,N)*YP(M-1,N)
75      CONTINUE
80    CONTINUE
      DO 120 N=1,4
        NXT=N1(N)
        DX(N)=XVP(N1(N))-XVP(N)
        DY(N)=YVP(N1(N))-YVP(N)
C-----------------------------------------------------------------------
C   Evaluate length of each side and accumulate area of panel
C-----------------------------------------------------------------------
        S(1)=S(1)+HALF*DX(N)*(YVP(N)+YVP(N1(N)))
        DDX=DX(N)*DX(N)
        DDY=DY(N)*DY(N)
        DDS=DDX+DDY
        IF (DDS.LT.TOLT) THEN
          SIDE(N)=ZERO
          GO TO 120
        ENDIF
        SIDE(N)=SQRT(DDS)
        IF (DDY.GT.DDX) GOTO 100
        DYDX=DY(N)/DX(N)
        DO 90 I=2,4
          I1=I+1
          I2=I+2
          SI=(XP(I1,NXT)*YP(1,NXT)-XP(I1,N)*YP(1,N))/(I1)
     &          +DYDX*(XP(I2,N)-XP(I2,NXT))/(I1*I2)
          K=K1(I1)
          S(K)=S(K)+SI
          DO 85 J=1,I
            J1=J+1
            IJ1=I-J+1
            SI=(XP(IJ1,NXT)*YP(J1,NXT)-XP(IJ1,N)*YP(J1,N))/(IJ1*J1)-
     &                                          DYDX*J*SI/IJ1
            K=J+K1(IJ1)
            S(K)=S(K)+SI
85        CONTINUE
90      CONTINUE
        GO TO 120
100     DXDY=DX(N)/DY(N)
        DO 110 I=2,4
          I1=I+1
          I2=I+2
          SI=DXDY/(I1*I2)*(YP(I2,NXT)-YP(I2,N))
          S(I1)=S(I1)+SI
          DO 105 J=1,I
            IJ=I-J
            IJ1=IJ+1
            IJ2=IJ+2
            SI=DXDY*((XP(J,NXT)*YP(IJ2,NXT)-XP(J,N)*YP(IJ2,N))/
     &                                  (IJ1*IJ2)-J*SI/IJ1)
            K=IJ+K1(J+1)
            S(K)=S(K)+SI
105       CONTINUE
110     CONTINUE
120   CONTINUE
      DO 130 N=3,15
        S(N)=S(N)*CS(N)
130   CONTINUE
      RETURN
      END


      PROGRAM LA_SSYGVX_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_SYGVX
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, M, N
!  .. "Local Arrays" ..
      INTEGER, ALLOCATABLE :: IFAIL(:)
      REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:), W(:), Z(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_SYEVX Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), B(N,N), BB(N,N), W(N), IFAIL(N), Z(N,N) )

      OPEN(UNIT=21,FILE='sygv.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A:'
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(A(I,:));
      ENDDO

      OPEN(UNIT=21,FILE='sygv.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      BB=B

      WRITE(*,*)'Matrix B:'
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(B(I,:));
      ENDDO

      WRITE(*,*) 'CALL LA_SYGVX( A, B, W, 3, VL=-10.0_WP, VU=10.0_WP, M=M, IFAIL=IFAIL )'
      CALL LA_SYGVX(  A, B, W, 3, VL=-10.0_WP, VU=10.0_WP, M=M, IFAIL=IFAIL )

      WRITE(*,*)'Matrix B on exit:'
      DO I=1,N;
         WRITE(*,"(5(F12.7,1X))") B(I,:);
      ENDDO

      WRITE(*,*) 'W on exit : '
      DO I=1,N
      WRITE(*,"(5(F12.7,1X))") W(I)
      ENDDO

      WRITE(*,*) 'M=',M

      WRITE(*,*)'IFAIL = ', IFAIL

      WRITE(*,*) 'Z on exit : '
      DO J=1,M
      WRITE(*,"(5(F12.6,1X))") (A(I,J), I = 1,N)
      ENDDO

      END PROGRAM LA_SSYGVX_EXAMPLE


C****
      SUBROUTINE GEOMO
!@sum  GEOMO Calculates the spherical geometry for the C grid
!@auth Gary Russell
!@ver  1.0
      USE CONSTANT, only : twopi,radius,omega
      USE GEOM, only : dxyp,bydxyp
      USE OCEAN
      IMPLICIT NONE
      INTEGER I,J
      REAL*8 FJEQ,DLON,DLAT,VLATS,SINVS,VLATN,SINVN

      DLON   = TWOPI/IM
      DLAT   = NINT(180./(JM-1))*TWOPI/360.
C**** Geometric parameters defined at secondary latitudes
      FJEQ    = .5*(1+JM)
      RLAT(1) = -TWOPI/4.
      SINPO(1) = SIN(RLAT(1))
      DO 110 J=1,JM-1
      RLAT(J+1) = DLAT*(J+1.-FJEQ)
      IF(J.GE.JM-1)  RLAT(J+1) = TWOPI/4.
      SINPO(J+1) = SIN(RLAT(J+1))
      COSVO(J) = (SINPO(J+1)-SINPO(J))/(RLAT(J+1)-RLAT(J))
      DXVO(J)  = DLON*RADIUS*COSVO(J)
      DYVO(J)  = (RLAT(J+1)-RLAT(J))*RADIUS
  110 DXYVO(J) = DLON*RADIUS*RADIUS*(SINPO(J+1)-SINPO(J))
      DXVO(JM) = 0.
      DYVO(JM) = 0.
      DXYVO(JM)= 0.
      COSVO(0) = 0.
      COSVO(JM)= 0.
C**** Geometric parameters defined at primary latitudes
      VLATS = -TWOPI/4.
      SINVS = SIN(VLATS)
      DO 120 J=1,JM
      VLATN = DLAT*(J+.5-FJEQ)
      IF(J.EQ.JM)  VLATN = TWOPI/4.
      SINVN   = SIN(VLATN)
      DXYPO(J) = DLON*RADIUS*RADIUS*(SINVN-SINVS)
      BYDXYPO(J) = 1d0/DXYPO(J)
      IF (J.gt.1) DXPO(J)  = .5*(DXVO(J-1)+DXVO(J))
      DYPO(J)  = (VLATN-VLATS)*RADIUS
      COSPO(J) = .5*(COSVO(J-1)+COSVO(J))
      DXYSO(J) = .5*DXYPO(J)
      DXYNO(J) = .5*DXYPO(J)
      VLATS   = VLATN
  120 SINVS   = SINVN
      DXPO(1)  = .5*DXVO(1)
      DXPO(JM) = .5*DXVO(JM-1)
      DXYSO(1) = 0.
      DXYSO(JM)= DXYPO(JM)
      DXYNO(1) = DXYPO(1)
      DXYNO(JM)= 0.
C**** Calculate area ratios for applying source terms to V winds
      DO 130 J=1,JM-1
      RAMVN(J  ) = DXYNO(J  )/(DXYNO(J)+DXYSO(J+1))
  130 RAMVS(J+1) = DXYSO(J+1)/(DXYNO(J)+DXYSO(J+1))
      RAMVS(1  ) = 0.
      RAMVN(JM ) = 0.
C**** Calculate area ratios for converting atmospheric grid to ocean
      DO J=1,JM
        RATOC(J)=DXYP(J)*BYDXYPO(J)
        ROCAT(J)=DXYPO(J)*BYDXYP(J)
      END DO
C**** calculate SINI/COSI terms for C grid
      DO I=1,IM
        SINIC(I) = SIN((I-.5)*TWOPI/IM)
        COSIC(I) = COS((I-.5)*TWOPI/IM)
      END DO
C**** calculate the grid box at 40S (for use with OPFIL)
      DO J=1,JM/2
        IF (RLAT(J).gt.-40.*TWOPI/360.) THEN
          J40S=J-1
          EXIT
        END IF
      END DO
C****
      RETURN
      END


!> SPDX-Identifier: MIT
module test_math_arange

    use stdlib_error, only: check
    use stdlib_math, only: arange
    implicit none

    logical, private :: warn = .false.

contains

    subroutine test_math_arange_real
        !> Normal
        call check(all(arange(3.0) == [1.0, 2.0, 3.0]),        msg="all(arange(3.0) == [1.0,2.0,3.0]) failed.",           warn=warn)
        call check(all(arange(-1.0) == [1.0, 0.0, -1.0]),      msg="all(arange(-1.0) == [1.0,0.0,-1.0]) failed.",         warn=warn)
        call check(all(arange(0.0, 2.0) == [0.0, 1.0, 2.0]),   msg="all(arange(0.0,2.0) == [0.0,1.0,2.0]) failed.",       warn=warn)
        call check(all(arange(1.0, -1.0) == [1.0, 0.0, -1.0]), msg="all(arange(1.0,-1.0) == [1.0,0.0,-1.0]) failed.",     warn=warn)
        call check(all(arange(1.0, 1.0) == [1.0]),             msg="all(arange(1.0,1.0) == [1.0]) failed.",               warn=warn)
        call check(all(arange(0.0, 2.0, 2.0) == [0.0, 2.0]),   msg="all(arange(0.0,2.0,2.0) == [0.0,2.0]) failed.",       warn=warn)
        call check(all(arange(1.0, -1.0, 2.0) == [1.0, -1.0]), msg="all(arange(1.0,-1.0,2.0) == [1.0,-1.0]) failed.",     warn=warn)
        !> Not recommended
        call check(all(arange(0.0, 2.0, -2.0) == [0.0, 2.0]),  msg="all(arange(0.0,2.0,-2.0) == [0.0,2.0]) failed.",      warn=warn)
        call check(all(arange(1.0, -1.0, -2.0) == [1.0, -1.0]),msg="all(arange(1.0,-1.0,-2.0) == [1.0,-1.0]) failed.",    warn=warn)
        call check(all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]),msg="all(arange(0.0, 2.0, 0.0) == [0.0,1.0,2.0]) failed.", warn=warn)
    end subroutine test_math_arange_real

    subroutine test_math_arange_integer
        !> Normal
        call check(all(arange(3) == [1, 2, 3]),        msg="all(arange(3) == [1,2,3]) failed.",       warn=warn)
        call check(all(arange(-1) == [1, 0, -1]),      msg="all(arange(-1) == [1,0,-1]) failed.",     warn=warn)
        call check(all(arange(0, 2) == [0, 1, 2]),     msg="all(arange(0,2) == [0,1,2]) failed.",     warn=warn)
        call check(all(arange(1, -1) == [1, 0, -1]),   msg="all(arange(1,-1) == [1,0,-1]) failed.",   warn=warn)
        call check(all(arange(1, 1) == [1]),           msg="all(arange(1,1) == [1]) failed.",         warn=warn)
        call check(all(arange(0, 2, 2) == [0, 2]),     msg="all(arange(0,2,2) == [0,2]) failed.",     warn=warn)
        call check(all(arange(1, -1, 2) == [1, -1]),   msg="all(arange(1,-1,2) == [1,-1]) failed.",   warn=warn)
        !> Not recommended
        call check(all(arange(0, 2, -2) == [0, 2]),    msg="all(arange(0,2,-2) == [0,2]) failed.",    warn=warn)
        call check(all(arange(1, -1, -2) == [1, -1]),  msg="all(arange(1,-1,-2) == [1,-1]) failed.",  warn=warn)
        call check(all(arange(0, 2, 0) == [0,1,2]),    msg="all(arange(0, 2, 0) == [0,1,2]) failed.", warn=warn)
    end subroutine test_math_arange_integer

end module test_math_arange

program tester

    use test_math_arange

    call test_math_arange_real
    call test_math_arange_integer

    print *, "All tests in `test_math_arange` passed."

end program tester


! input and output in FORTRAN
program Format_I_O
    implicit none

    REAL :: value = 13.32342
    REAL :: f_format = 56.243591034
    INTEGER :: i_format = 455
    logical :: l_format = .true.
    CHARACTER(len=20) :: a_format = "PULCHOWK CAMPUS"

    CHARACTER(len=10) :: my_format = '(f5.2)'

    print *, "Non-Formatted ", value

    print *, "Formatted "

    !Method One
    write (*, '(f5.2)') value
    print'(f5.2)', value

    !Method Two
100 format(f5.2)

    print 100, value !100 here will be redirect to label 100 defined in line 100 and do formatting as given in that label

    !Method Three
    write (*, my_format) value  !i have create a character array in line number 7 which is replced here

    print *, ""

    print *, "F format"

    print'(f5.1)', f_format
    print'(f5.2)', f_format
    print'(f4.0)', f_format
    print'(f7.3)', f_format
    print'(f5.3)', f_format

    print *, ""

    print *, "E format"

    print'(e12.1)', f_format
    print'(e13.2)', f_format
    print'(e15.4)', f_format
    print'(e14.3)', f_format
    print'(e8.3)', f_format
    print'(e5.3)', f_format

    print *, ""

    print *, "ES format"

    print'(es12.1)', f_format
    print'(es13.2)', f_format
    print'(es15.4)', f_format
    print'(es14.3)', f_format
    print'(es8.3)', f_format
    print'(es5.3)', f_format

    print *, ""

    print *, "I Format"

    print'(i3)', i_format
    print'(i4)', i_format
    print'(i5)', i_format
    print'(i6.4)', i_format
    print'(i7.5)', i_format
    print'(i8.8)', i_format

    print *, ""

    print *, "Logical Format"

    print'(l4)', l_format
    print'(l3)', l_format
    print'(l2)', l_format
    print'(l1)', l_format

    print *, ""

    print *, "A Format"

    print'(A8)', a_format
    print'(A10)', a_format
    print'(A17)', a_format
    print'(A5)', a_format

    print *, ""

    print *, "RF Format"
    print'(2f5.2)', f_format, value !Result seen by this will have no space in between

    print *, ""

    print *, "I and F Combined Format with X format"
    print'(i4,6x,f5.2)', i_format, f_format

    print *, ""

    print *, "I and F Combined Format with / format"
    print'(i4,//,f5.2)', i_format, f_format

    print *, ""

    print *, "I and F Combined Format with T format"
    print'(i4,/,T10,f5.2)', i_format, f_format

    print *, ""

    print *, "******** --> Mean error in FORTRAN"

end program Format_I_O


program main
  != unit(m) :: y
  integer :: x = 5, y = 2, z
  z = recur(x,y)
  print *, y
contains
  real recursive function recur(n, b) result(r)
    integer :: n, b
    if (n .EQ. 0) then
       r = b
    else
       r = b + recur(n - 1, b)
    end if
  end function recur
end program main


submodule(euler_interface_m) euler_prob_0029_m
    implicit none

contains

    module character(len=20) function euler0029()
        write (euler0029, "(i20)") ans(99)
    end function euler0029

    integer function ans(n)
        integer, intent(in) :: n
        integer, dimension(2, n, n) :: arr_of_nums
        integer, dimension(2, n*n) :: res, arr
        integer :: i, j, k

        do i = 2, n + 1
            do j = 2, n + 1
                arr_of_nums(1, j - 1, i - 1) = j
                arr_of_nums(2, j - 1, i - 1) = i
                call simplify_powers(arr_of_nums(:, j - 1, i - 1))
            end do
        end do

        call reshape_to_2_by_99_x_99(arr_of_nums, arr)
        res(1:2, 1) = arr(1:2, 1); k = 1

        outer: do i = 2, n*n
            inner: do j = 1, k
                if (res(1, j) == arr(1, i) .and. &
                    res(2, j) == arr(2, i)) cycle outer
            end do inner
            k = k + 1
            res(1:2, k) = arr(1:2, i)
        end do outer

        ans = k
    end function ans

    subroutine simplify_powers(arr1)
        integer, intent(inout) :: arr1(2)

        select case (arr1(1))
        case (4, 9, 25, 36, 49, 100)
            arr1(1) = int(sqrt(real(arr1(1), sp)))
            arr1(2) = arr1(2)*2
        case (8)
            arr1(1) = 2
            arr1(2) = arr1(2)*3
        case (27)
            arr1(1) = 3
            arr1(2) = arr1(2)*3
        case (16)
            arr1(1) = 2
            arr1(2) = arr1(2)*4
        case (81)
            arr1(1) = 3
            arr1(2) = arr1(2)*4
        case (32)
            arr1(1) = 2
            arr1(2) = arr1(2)*5
        case (64)
            arr1(1) = 2
            arr1(2) = arr1(2)*6
        case default
            arr1(1:2) = arr1(1:2)
        end select
    end subroutine simplify_powers

    subroutine reshape_to_2_by_99_x_99(arr_in, arr_out)
        integer, intent(in) :: arr_in(:, :, :)
        integer, intent(out) :: arr_out(:, :)

        arr_out = reshape(arr_in, [2, 99*99])
    end subroutine reshape_to_2_by_99_x_99

end submodule euler_prob_0029_m