      PROGRAM EIGN4Q
C=======================================================================
C           2-DIM FEM PROGRAM FOR SOLVING EIGENVALUE PROBLEM IN
C                                        HELMHOLZ EQUATION
C                        MATRICES: UPPER HALF BANDED MATRIX
C                      EQUATION: DP/DX + DP/DY + ALPHA**2 * P = 0.
C                             ELEMENT : 4-NODED ISO-PARAMETERIC
C                       NUMBERING ORDER: (-1,-1),(+1,-1),(+1,+1),(-1,+1)
C                                          UNKNOWN: ALPHA**2
C            BOUNDARY CONDITION: NEUMANN/VALUE=0 I.E., NATURAL B. C.
C                                  ORIGINAL:1984 EIJI FUKUMORI
C     START = STARTING VALUE OF ALPHA**2
C     RINCRE = INCREMENTAL VALUE OF  ALPHA**2
C     MXNEIGEN = DESIRED NUMBERS OF EIGENVALUES
C=======================================================================
      IMPLICIT REAL*8 ( A-H , O-Z )
      PARAMETER ( ND=4,MXE=30000,MXN=30000,INTEPT=2,MXW=150 )
      PARAMETER ( ND3=(ND*ND-ND)/2+ND )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),RK(MXN,MXW),
     * RHS(MXN),SK(ND,ND), X(ND), Y(ND),BX(2,ND),SS(ND,ND),
     * SAI(INTEPT), W(INTEPT),
     * BPP(2,ND,INTEPT,INTEPT), SF(ND,INTEPT,INTEPT),
     * GSTIFF(MXE,ND3), SOURCE(MXE,ND3)
      CHARACTER INPFILE*12, OUTFILE*12, EXFILE*3
      LOGICAL YES
      WRITE (*,*)' EIGN4Q.FOR SOLVER'
C=======================================================================
      CALL GRULE ( INTEPT, SAI, W   )
      CALL DERIV ( ND, INTEPT, X, Y, SAI, BPP )
      CALL SHAPEF( ND, INTEPT, X, SAI, SF )
C=======================================================================
      INPFILE = 'EIGN4DAT.QQQ'
      WRITE(*,*)' INPUT FILE NAME =', INPFILE
      CALL INPUT  ( ND,MXE,MXN,NE,NNODE,START,RINCRE ,MXNEIGEN,
     * NODEX, XCOORD,YCOORD, INPFILE )
C=======================================================================
      IF ( MXNEIGEN .GT. NNODE ) THEN
      MXNEIGEN = NNODE
      END IF
C=======================================================================
      CALL BANDWID ( MXE, ND, NE,NODEX, NBW )
      IF ( NBW .GT. MXW ) STOP 'Error ... NBW > MXW'
C=======================================================================
      OUTFILE ='SOLUTION.FEM'
      EXFILE ='NEW'
      IW = 1
      INQUIRE ( FILE=OUTFILE, EXIST=YES )
      IF ( YES ) EXFILE='OLD'
      OPEN ( IW, FILE=OUTFILE, STATUS=EXFILE,FORM='FORMATTED' )
C=======================================================================
      CALL GSM ( INTEPT,ND,ND3,MXE,MXN,NE,BPP,W,BX,SK,NODEX,
     * XCOORD,YCOORD,GSTIFF )
      CALL GDM ( MXE,MXN,INTEPT,ND,ND3,BPP,W,NE,SF,
     * XCOORD,YCOORD,NODEX,SS, SOURCE )
C=======================================================================
      WRITE(IW,*) 'ALPHA-SQUARE SIGN-OF-DET LOG10(DET)'
      WRITE(*,*) 'ALPHA-SQUARE SIGN-OF-DET LOG10(DET)'
C=======================================================================
      NEIGEN = 1
      ALFA0 = 0.
      ISIGNDET = 1
      RLOGDET = 1.E-100
      WRITE (*,'(E20.11, I3, E20.11,I5)') ALFA0,ISIGNDET,RLOGDET,NEIGEN
      WRITE (IW,'(E20.11, I3, E20.11,I5)')ALFA0,ISIGNDET,RLOGDET,NEIGEN
C=======================================================================
      ALPHA = START
      CALL SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNST,RLOGDET )
C
      DO WHILE ( NEIGEN .LT. MXNEIGEN .AND. NEIGEN.LT. NNODE*0.9 )
      ALPHA = ALPHA + RINCRE
      CALL SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDET,RLOGDET )
      IF ( ISIGNST .NE. ISIGNDET ) THEN
      ISIGNST = ISIGNDET
      CALL NEWTON  (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * ALFA0,NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDET,RLOGDET,RINCRE  )
      NEIGEN = NEIGEN + 1
      WRITE (*,'(E20.11, I3, E20.11,I5)') ALFA0,ISIGNDET,RLOGDET,NEIGEN
      WRITE (IW,'(E20.11, I3, E20.11,I5)')ALFA0,ISIGNDET,RLOGDET,NEIGEN
      END IF
      END DO
C=======================================================================
      CLOSE (IW)
      STOP
      END
C
C
      SUBROUTINE GSM ( INTEPT,ND,ND3,MXE,MXN,NE,BPP,W,BX,SS,NODEX,
     * XCOORD,YCOORD,GSTIFF )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),GSTIFF(MXE,ND3),
     * SS(ND,ND), BX(2,ND),W(INTEPT), BPP(2,ND,INTEPT,INTEPT)
C
      DO  IEL = 1 ,NE
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = 0.
      END DO
      END DO
      DO  K = 1 , INTEPT
      DO  L = 1 , INTEPT
      WEIGHT = W(K) * W(L)
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      Y11 =   YAC22 / DETJ
      Y12 = - YAC12 / DETJ
      Y21 = - YAC21 / DETJ
      Y22 =   YAC11 / DETJ
      DO J = 1 , ND
      BX(1,J) = Y11 * BPP(1,J,K,L) + Y12 * BPP(2,J,K,L)
      BX(2,J) = Y21 * BPP(1,J,K,L) + Y22 * BPP(2,J,K,L)
      END DO
      BETA = WEIGHT * DETJ
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = SS(I,J) + ( BX(1,I)*BX(1,J)+BX(2,I)*BX(2,J) )*BETA
      END DO
      END DO
      END DO
      END DO
      M = 0
      DO K = 1 , ND
      DO L = K , ND
      M = M + 1
      GSTIFF(IEL,M) = SS(K,L)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE INPUT ( ND,MXE,MXN,NE,NNODE,START,RINCRE ,MXNEIGEN,
     * NODEX, XCOORD,YCOORD, INPFILE )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN)
      LOGICAL YES
      CHARACTER INPFILE*12
      IR = 1
      INQUIRE ( FILE=INPFILE, EXIST=YES )
      IF ( YES ) OPEN ( IR, FILE=INPFILE, STATUS='OLD' )
      IF ( .NOT. YES ) STOP' NO INPUT FILE'
C========> PARAMETER
C--- APPROPRIATE VALUES: START=0.1, RINCRE=0.01, MXNEIGEN=40
      READ (1,*) START, RINCRE , MXNEIGEN 
C========> ELEMENT
      READ (1,*) NE
      DO I = 1 , NE
      READ (1,*) IEL, ( NODEX(IEL,J), J = 1 , ND )
      END DO
C========> COORDINATES
      READ (1,*) NNODE
      DO I = 1 , NNODE
      READ (1,*) NODE, XCOORD(NODE) , YCOORD(NODE)
      END DO
      CLOSE (1)
      RETURN
      END
C
C
      SUBROUTINE BANDWID ( MXE, ND, NE, NODEX , NBW  )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND)
      NBW = 0
      DO  I = 1 , NE
      DO  J = 1 , ND-1
      DO  K = J+1 , ND
      NBW = MAX0(NBW,IABS(NODEX(I,J)-NODEX(I,K)))
      END DO
      END DO
      END DO
      NBW = NBW + 1
      write(6,*) ' bandwidth =', nbw
      RETURN
      END

C
C
      SUBROUTINE DETERMIN ( MXN,MXW,NNODE,NBW,A, ISIGNDET,RLOGDET )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION A(MXN,MXW)
C---------- GAUSS ELIMINATION --------------
      DO N = 1 , NNODE-1
      DO L = 2 , MIN((NNODE-N+1),NBW)
      C = A(N,L) / A(N,1)
      IF ( C .NE. 0. ) THEN
      I = N + L - 1 
      DO K = L , NBW
      J = K-L+1
      A(I,J) = A(I,J) - C * A(N,K)
      END DO
      A(N,L) = C
      END IF
      END DO
      END DO
C---------- BACK SUBSTITUTION -------------
      ISIGNDET = 1
      RLOGDET = DLOG10(1.D0)
      DO I = 1 , NNODE
      RLOGDET = RLOGDET + DLOG10(DABS(A(I,1)))
      IF ( A(I,1) .LT. 0.D0 ) THEN
      ISIGNDET = -1 * ISIGNDET
      END IF
      END DO
      RETURN
      END 
C
C
      SUBROUTINE GRULE ( N , SAI , W )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SAI(N) , W(N)
      IF ( N .LT. 2 ) STOP'N<2'
      IF ( N .GT. 6 ) STOP'N>6'
      IF ( N .EQ. 1 ) THEN
      SAI(1) = 0.
      W(1) = 2.
      RETURN
      END IF
C
      IF ( N .EQ. 2 ) THEN
      SAI(1) = 0.5773502692
      W(1) = 1.
      END IF
C
      IF ( N .EQ. 3 ) THEN
      SAI(1) = 0.7745966692
      SAI(2) = 0.
      W(1) = 5./ 9.
      W(2) = 8./ 9.
      END IF
C
      IF ( N .EQ. 4 ) THEN
      SAI(1) = 0.3399810436
      SAI(2) = 0.8611363116
        W(1) = 0.6521451549
        W(2) = 0.3478548451
      END IF
C
      IF ( N .EQ. 5 ) THEN
      SAI(1) = 0.9061798459
      SAI(2) = 0.5384693101
      SAI(3) = 0.
        W(1) = 0.2369268850
        W(2) = 0.4786286705
        W(3) = 5.12 / 9.
      END IF
C
      IF ( N .EQ. 6 ) THEN
      SAI(1) = 0.2386191861
      SAI(2) = 0.6612093865
      SAI(3) = 0.9324695142
        W(1) = 0.4679139346
        W(2) = 0.3607615730
        W(3) = 0.1713244924
      END IF
C
      NN = N / 2
      DO  I = 1 , NN
      J = N - I + 1
      SAI(J) = - SAI(I)
      W(J) = W(I)
      END DO
      RETURN
      END
C
C
      SUBROUTINE DERIV ( ND, INTEPT, F0, F1, SAI, BPP )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SAI(INTEPT),BPP(2,ND,INTEPT,INTEPT),F0(ND),F1(ND)
      DO  K = 1 , INTEPT
      E1 = SAI (K)
      DO  L = 1 , INTEPT
      E2 = SAI (L)
COMPUTATION OF BP(J) = DN(J) / DETA1
      CALL ISOPARA ( ND, E1+0.5 , E2 , F1 )
      CALL ISOPARA ( ND, E1-0.5 , E2 , F0 )
      DO I = 1 , ND
      BPP(1,I,K,L) = F1(I) - F0(I)
      END DO
COMPUTATION OF BP(J)= DN(J)/DETA2
      CALL ISOPARA ( ND, E1 , E2+0.5 , F1 )
      CALL ISOPARA ( ND, E1 , E2-0.5 , F0 )
      DO I = 1 , ND
      BPP(2,I,K,L) = F1(I) - F0(I)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE ISOPARA ( ND, E1 , E2 , F )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION F(ND)
      F(1) = 0.25*(1.- E1)*(1.- E2)
      F(2) = 0.25*(1.+ E1)*(1.- E2)
      F(3) = 0.25*(1.+ E1)*(1.+ E2)
      F(4) = 0.25*(1.- E1)*(1.+ E2)
      RETURN
      END
C
C
      SUBROUTINE SHAPEF ( ND, INTEPT, F, SAI, SF )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION F(ND) , SAI(INTEPT) , SF(ND,INTEPT,INTEPT)
      DO  K = 1 , INTEPT
      E1 = SAI (K)
      DO  L = 1 , INTEPT
      E2 = SAI( L )
      CALL ISOPARA ( ND, E1 , E2 , F )
      DO  I = 1 , ND
      SF(I,K,L) = F(I)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE GDM ( MXE,MXN,INTEPT,ND,ND3,BPP,W,NE,SF,
     * XCOORD,YCOORD,NODEX,SS, SOURCE )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION NODEX(MXE,ND),XCOORD(MXN),YCOORD(MXN),SOURCE(MXE,ND3),
     * SS(ND,ND),BPP(2,ND,INTEPT,INTEPT),W(INTEPT),SF(ND,INTEPT,INTEPT)
C
      DO  IEL = 1 ,NE
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = 0.
      END DO
      END DO
C
      DO  K = 1 , INTEPT
      DO  L = 1 , INTEPT
      WEIGHT = W(K) * W(L)
      YAC11 = 0.
      YAC12 = 0.
      YAC21 = 0.
      YAC22 = 0.
      DO I = 1 , ND
      YAC11 = YAC11 + BPP(1,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC12 = YAC12 + BPP(1,I,K,L) * YCOORD(NODEX(IEL,I))
      YAC21 = YAC21 + BPP(2,I,K,L) * XCOORD(NODEX(IEL,I))
      YAC22 = YAC22 + BPP(2,I,K,L) * YCOORD(NODEX(IEL,I))
      END DO
      DETJ = YAC11 * YAC22 - YAC12 * YAC21
      BETA = WEIGHT * DETJ
C
      DO I = 1 , ND
      DO J = I , ND
      SS(I,J) = SS(I,J) + SF(I,K,L) * SF(J,K,L) * BETA
      END DO
      END DO
C
      END DO
      END DO
C
      M = 0
      DO K = 1 , ND
      DO L = K , ND
      M = M + 1
      SOURCE(IEL,M) = SS(K,L)
      END DO
      END DO
C
      END DO
      RETURN
      END
C
C
      SUBROUTINE SUMUP (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * NODEX,GSTIFF,SOURCE,SS,RK )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SS(ND,ND),RK(MXN,MXW),GSTIFF(MXE,ND3),SOURCE(MXE,ND3),
     * NODEX(MXE,ND)
C
      DO I = 1 , NNODE
      DO J = 1 , NBW
      RK(I,J) = 0.
      END DO
      END DO
C
      DO  IEL = 1 , NE
      DO K = 1 , ND
      DO L = 1 , ND
      SS(K,L) = 0.
      END DO
      END DO
      M = 0
      DO K = 1 , ND
      DO L = K , ND
      M = M + 1
      SS(K,L) = - GSTIFF(IEL,M) + ALPHA*SOURCE(IEL,M)
      SS(L,K) = SS(K,L)
      END DO
      END DO
C----ASSEMBLY
      DO K = 1 , ND
      I = NODEX(IEL,K)
      DO L = 1 , ND
      J = NODEX(IEL,L) - I + 1
      IF ( J .GT. 0 ) RK(I,J) = RK(I,J) + SS(K,L)
      END DO
      END DO
      END DO
      RETURN
      END
C
C
      SUBROUTINE SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDET,RLOGDET )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SS(ND,ND),RK(MXN,MXW),GSTIFF(MXE,ND3),SOURCE(MXE,ND3),
     * NODEX(MXE,ND)
C------------------------------------------------------------
      CALL SUMUP (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * NODEX,GSTIFF,SOURCE,SS,RK )
      CALL DETERMIN ( MXN,MXW,NNODE,NBW,RK,ISIGNDET,RLOGDET )
      RETURN
      END
C
C
      SUBROUTINE NEWTON (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALPHA,
     * ALFA0,NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDET,RLOGDET,RINCRE  )
      IMPLICIT REAL*8 ( A-H , O-Z )
      DIMENSION SS(ND,ND),RK(MXN,MXW),GSTIFF(MXE,ND3),SOURCE(MXE,ND3),
     * NODEX(MXE,ND)
C
      ILOGDET = RLOGDET
      DALFA = RINCRE/10.
      ALFA0 = ALPHA-RINCRE/2.
      DA = DALFA
C
      DO WHILE ( DABS(DA) .GT. RINCRE/100. )
      CALL SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALFA0,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDT0,RLOGDT0 )
      RLOGDT0 = RLOGDT0-ILOGDET
      DET0 = ISIGNDT0*10**RLOGDT0
C
      ALFA1 = ALFA0 + DALFA
      CALL SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALFA1,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDT1,RLOGDT1 )
      RLOGDT1 = RLOGDT1-ILOGDET
      DET1 = ISIGNDT1*10**RLOGDT1
      SLOPE = ( DET1 - DET0 ) / DALFA
      DA = - DET0/SLOPE
      ALFA0 = ALFA0 + DA
      END DO
      CALL SUMUPDET (ND,ND3,MXE,MXN,MXW,NE,NBW,NNODE,ALFA0,
     * NODEX,GSTIFF,SOURCE,SS,RK,ISIGNDT0,RLOGDT0 )
      RETURN
      END
