SUBROUTINE ANGLE7(BE,NA,IN)
INTEGER NA
REAL BE(*)
LOGICAL IN
C
C**** BE=JACIN,NA=NARCS,IN=INTER
C
C**** TO COMPUTE THE ARRAY OF JACOBI INDECES CORRESPONDING TO THE
C**** CORNER ANGLES ON THE BOUNDARY
C
C**** LOCAL VARIABLES
INTEGER K,B0,B1,B2
REAL X,Y,ANG,PI,R1MACH,EPS,XI,APP
COMPLEX U,V,DPARFN
EXTERNAL DPARFN,R1MACH
C
PI=4E+0*ATAN(1E+0)
EPS=SQRT(R1MACH(4))
DO 1 K=1,NA
U=DPARFN(K,(1.0,0.0))
U=-U/ABS(U)
IF (K.EQ.NA) THEN
V=DPARFN(1,(-1.0,0.0))
ELSE
V=DPARFN(K+1,(-1.0,0.0))
ENDIF
V=V/ABS(V)
V=U/V
X=REAL(V)
Y=AIMAG(V)
ANG=ATAN2(Y,X)
IF (ANG.LT.0) THEN
ANG=ANG+2E+0*PI
ENDIF
ANG=ANG/PI
IF (.NOT.IN) THEN
ANG=2E+0-ANG
ENDIF
ANG=-1E+0+1E+0/ANG
C
C**** TRY TO DETECT SIMPLE RATIONAL INDECES AND FORCE BEST REAL
C**** APPROXIMATIONS
C
IF (ABS(ANG) .LT. EPS) THEN
ANG=0E+0
ELSE
XI=ABS(ANG)
B0=INT(XI)
XI=XI-REAL(B0)
IF (ABS(XI) .LT. EPS) THEN
APP=REAL(B0)
ELSE
XI=1E+0/XI
B1=INT(XI)
XI=XI-REAL(B1)
IF (ABS(XI) .LT. EPS) THEN
APP=REAL(1+B0*B1)/REAL(B1)
ELSE
XI=1E+0/XI
B2=INT(XI)
APP=REAL(B0*(1+B1*B2)+B2)/REAL(1+B1*B2)
ENDIF
ENDIF
APP=SIGN(1E+0,ANG)*APP
IF (ABS(ANG-APP) .LT. EPS) ANG=APP
ENDIF
C
IF (K.EQ.NA) THEN
BE(1)=ANG
ELSE
BE(K+1)=ANG
ENDIF
1 CONTINUE
END
REAL FUNCTION ARGIN1(RT1,RT2,PT,DIFF1,DIFF2,ZZ,LIMIT)
INTEGER PT
REAL RT1,RT2,LIMIT
COMPLEX DIFF1,DIFF2,ZZ
C
C ZZ IS A GIVEN FIELD POINT AND DIFF1, DIFF2 ARE THE DIFFERENCES
C BETWEEN ZZ AND CONSECUTIVE POINTS ON THE BOUNDARY
C (DIFF1=PARFUN(PT,RT1)-ZZ, ZET2=PARFUN(PT,RT2)-ZZ). THE
C PURPOSE OF THIS ROUTINE IS TO CALCULATE THE INCREASE IN THE
C ARGUMENT ARG(ZZ-Z) AS Z MOVES ALONG THE BOUNDARY FROM THE POINT
C WITH PARAMETER VALUE RT1 TO THE POINT WITH PARAMETER VALUE RT2.
C
C LOCAL VARIABLES
C
INTEGER NANGS,NINTS
REAL ANGLE,T1,T2
COMPLEX D1,D2,PARFUN,V
EXTERNAL PARFUN
C
C LIMIT IS CURRENTLY SET TO 3*PI/4, APPROXIMATELY
C
T1=RT1
T2=(RT1+RT2)*5E-1
D1=DIFF1
D2=PARFUN(PT,CMPLX(T2))-ZZ
NANGS=0
NINTS=2
ARGIN1=0E+0
C
10 CONTINUE
V=D2*CONJG(D1)
ANGLE=ATAN2(AIMAG(V),REAL(V))
IF (ABS(ANGLE) .GE. LIMIT) THEN
T2=(T1+T2)*5E-1
D2=PARFUN(PT,CMPLX(T2))-ZZ
NINTS=NINTS+1
GOTO 10
ELSE
ARGIN1=ARGIN1+ANGLE
NANGS=NANGS+1
IF (NANGS .NE. NINTS) THEN
T1=T2
T2=RT2
D1=D2
D2=DIFF2
GOTO 10
ENDIF
ENDIF
C
END
SUBROUTINE ASONJ7(ALFA,BETA,A,B,H,N)
INTEGER N
REAL A(*),B(*),H,ALFA,BETA
C ..TO ASSIGN THE COEFFICIENTS A(K) AND B(K) , K=1(1)N, IN THE
C ..3-TERM RECURRENCE FORMULA FOR THE ORTHONORMAL JACOBI POLYNOMIALS
C ..WHERE
C ..
C .. A(K)P (X) = (X - B(K))P (X) - A(K-1)P (X) , K=1,2,..,N,
C .. K K-1 K-2
C ..
C .. P (X) = 0 , P (X) = 1/SQRT(H)
C .. -1 0
C ..
C ..AND H IS THE ZEROTH MOMENT OF THE JACOBI WEIGHT FUNCTION
C ..(1-X)**ALFA*(1+X)**BETA ON [-1,1].
C**** AUTHOR: DAVID HOUGH
C**** LAST UPDATE: 15.09.89
C**** ..LOCAL VARIABLES..
REAL SUM,DIFF,PROD,TC,T,SC,S,GAMMA,C
INTEGER K
EXTERNAL GAMMA
SUM=ALFA+BETA
DIFF=BETA-ALFA
PROD=SUM*DIFF
C ..CALCULATE H.
TC=SUM+1.0
SC=2.0**TC
S=GAMMA(ALFA+1.0)
T=GAMMA(BETA+1.0)
C=GAMMA(TC+1.0)
H=SC*S*T/C
C ..START ON A,B ARRAYS.
IF (N.GT.0) THEN
T=2.0+SUM
S=T*T
C=4.0*(ALFA+1.0)*(BETA+1.0)/S/(T+1.0)
A(1)=SQRT(C)
B(1)=DIFF/T
DO 10 K=2,N
B(K)=PROD/T/(T+2.0)
T=2.0*K+SUM
S=T*T
C=4.0*K*(ALFA+K)*(BETA+K)*(SUM+K)/S/(S-1.0)
A(K)=SQRT(C)
10 CONTINUE
ENDIF
END
SUBROUTINE ASQUC7(AQCOF,BQCOF,CQCOF,JACIN,NJIND,NQPTS)
INTEGER NJIND,NQPTS
REAL AQCOF(*),BQCOF(*),CQCOF(*),JACIN(*)
C
C ..TO ASSIGN THE COEFFICIENTS A(J), B(J) AND C(J) ,J=1,MN IN THE
C ..3-TERM RECURRENCE FORMULA
C ..
C .. Q (Z) = (A(J)Z - B(J))Q (Z) - C(J)Q (Z) , J=2,...,MN
C .. J+1 J J-1
C ..
C .. Q (Z) = (A(1)Z - B(1))Q (Z) - C(1)
C .. 2 1
C ..
C ..WHERE Q (Z):=
, P IS THE ORTHONORMAL JACOBI POLY
C .. J J J
C ..OF DEGREE J AND THE INNER PRODUCT IS WITH RESPECT TO THE JACOBI
C ..DISTRIBUTION OVER (-1,1). HERE A(J,I) STORES "A(J)" FOR THE ITH
C ..ARC ON THE BOUNDARY (WITH SIMILAR ROLE FOR ARRAYS B AND C) AND
C ..THE JACOBI WEIGHT FUNCTION FOR THE ITH ARC IS
C ..(1-X)**AB(I,1)*(1+X)**AB(I,2), J=1,MN, I=1,NA.
C
C**** AUTHOR: DAVID HOUGH
C**** LAST UPDATE: 15.09.89
C
C**** LOCAL VARIABLES
INTEGER I,J,K,LOSUB
REAL BE,H,D,N,N1,N2,F
EXTERNAL ASONJ7
DO 10 I=1,NJIND
LOSUB=(I-1)*NQPTS+1
BE=JACIN(I)
CALL ASONJ7(1E+0,BE+1E+0,AQCOF(LOSUB),BQCOF(LOSUB),H,NQPTS)
DO 20 K=1,NQPTS
J=LOSUB+K-1
N=REAL(K)
D=(N+1E+0)*(N+BE+2E+0)
N1=N*(N+BE+1E+0)
N2=(N-1E+0)*(N+BE)
F=SQRT(N1/D)
AQCOF(J)=F/AQCOF(J)
BQCOF(J)=BQCOF(J)*AQCOF(J)
IF (K.GT.1) THEN
CQCOF(J)=AQCOF(J)*N2/AQCOF(J-1)/N1
ELSE
CQCOF(J)=-AQCOF(J)*SQRT(H/N1)
ENDIF
20 CONTINUE
10 CONTINUE
C
END
SUBROUTINE AXION1(AXION,NEWDG,SOLUN,MDGPO,TNSUA,DGPOL,LOSUB,HISUB,
+RIGLL,LGTOL,ACCPT,JACIN,JATYP,NJIND,NEWHL,ESTOL,IER)
INTEGER AXION(*),NEWDG(*),MDGPO,TNSUA,DGPOL(*),LOSUB(*),HISUB(*),
+JATYP(*),NJIND,IER
REAL SOLUN(*),RIGLL(*),LGTOL,JACIN(*),NEWHL(*),ESTOL
LOGICAL ACCPT
C
C TO DETERMINE THE ARRAY "AXION" WHICH SPECIFIES THE ACTIONS THAT
C ARE TO TAKEN ON EACH SUBARC, AS FOLLOWS:
C AXION(I)=-1 - REDUCE THE DEGREE ON ARC I
C AXION(I)=0 - LEAVE THE DEGREE ON ARC I UNCHANGED
C AXION(I)=1 - INCREASE THE DEGREE ON ARC I
C AXION(I)=2 - SUBDIVIDE ARC I.
C
C IN CASE ABS(AXION(I))=1, NEWDG(I) RECORDS THE NEW DEGREE TO BE
C USED ON ARC I.
C
C IN CASE AXION(I)<=0 FOR ALL I=1,TNSUA, THE SOLUTION IS DEEMED TO
C BE ACCEPTABLE TO THE REQUIRED ACCURACY AND WE SET ACCPT=.TRUE.;
C ACCPT=.FALSE. OTHERWISE.
C
C ALSO TO DETERMINE THE EFFECTIVE STOPPING TOLERANCE ESTOL; IF THE
C USER HAD INPUT ESTOL AS THE VALUE FOR THE ARGUMENT MAXER IN
C JAPHYC, THEN THE CURRENT SOLUTION WOULD BE ACCEPTED.
C
C IER=0 - NORMAL EXIT
C IER=54 - LOCAL PARAMETER MXCO MUST BE INCREASED
C
C LOCAL VARIABLES
C
INTEGER AJT,CI,CRITCO,DG,I,IA,IFL,J,LOD,LOM,MINDG,MXCO,PNDG
REAL AA,BETA,CONF,EXA,LAM,POW,SAFEF,TERM,THSLN,XX,VAR
REAL COVAR(2,2)
LOGICAL CONSV
EXTERNAL CRITCO,STATS1
PARAMETER (SAFEF=5E+0,MINDG=0,MXCO=32,CONSV=.FALSE.)
REAL POSCO(MXCO)
C
ESTOL=0E+0
DO 60 IA=1,TNSUA
DG=DGPOL(IA)
IF (DG+1 .GT. MXCO) THEN
IER=54
RETURN
ENDIF
LOM=LOSUB(IA)
AJT=ABS(JATYP(IA))
LOD=(AJT-1)*(MDGPO+1)+1
DO 10 I=0,DG
J=LOM+I
POSCO(I+1)=ABS(SOLUN(J))*RIGLL(LOD+I)/LGTOL
10 CONTINUE
CI=CRITCO(DG+1,POSCO)-1
PNDG=CI+1+MINDG
IF (CI .EQ. -1) THEN
C
C**** ALL COEFFICIENTS ARE ACCEPTABLE.
C
IF (DG .EQ. MINDG) THEN
AXION(IA)=0
NEWDG(IA)=DG
ELSE
C
C**** PROBABLY DECREASE THE DEGREE, BUT ONLY IGNORE THOSE
C**** COEFFICIENTS WHICH ARE 'SAFELY' BELOW THE TOLERANCE
C**** LIMIT.
C
DO 20 I=0,DG
POSCO(I+1)=POSCO(I+1)*SAFEF
20 CONTINUE
PNDG=CRITCO(DG+1,POSCO)+MINDG
IF (PNDG .GE. DG) THEN
AXION(IA)=0
NEWDG(IA)=DG
ELSE IF (PNDG .LE. MINDG) THEN
AXION(IA)=-1
NEWDG(IA)=MINDG
ELSE
AXION(IA)=-1
NEWDG(IA)=PNDG
ENDIF
ENDIF
ELSE IF (PNDG .EQ. DG) THEN
AXION(IA)=0
NEWDG(IA)=DG
ELSE IF (PNDG .LT. DG) THEN
C
C**** PROBABLY DECREASE THE DEGREE, BUT ONLY IGNORE THOSE
C**** COEFFICIENTS WHICH ARE 'SAFELY' BELOW THE TOLERANCE
C**** LIMIT.
DO 30 I=0,DG
POSCO(I+1)=POSCO(I+1)*SAFEF
30 CONTINUE
PNDG=CRITCO(DG+1,POSCO)+MINDG
IF (PNDG .GE. DG) THEN
AXION(IA)=0
NEWDG(IA)=DG
ELSE IF (PNDG .LE. MINDG) THEN
AXION(IA)=-1
NEWDG(IA)=MINDG
ELSE
AXION(IA)=-1
NEWDG(IA)=PNDG
ENDIF
ELSE IF (DG .EQ. MDGPO) THEN
C
C**** ARC SUBDIVISION IS REQUIRED AND ASSIGN NEW HALF-LENGTH.
C
AXION(IA)=2
BETA=JACIN(AJT)
LAM=MIN(1E+0,1E+0+BETA)
IF (AJT .NE. NJIND) THEN
NEWHL(IA)=(1E+0/POSCO(CI+1))**(1E+0/(1E+0+LAM+BETA))
ELSE
NEWHL(IA)=5E-1
ENDIF
ELSE
C
C**** MUST DECIDE BETWEEN ARC SUBDIVISION ARC DEGREE INCREASE.
C**** FIRST MAKE CONSERVATIVE ESTIMATES FOR THE COEFFICIENTS
C**** FOR DEGREES DG+1 TO MDGPO.
C
CALL STATS1(SOLUN(LOM),DG+1,AA,POW,EXA,COVAR,CONF,IFL)
IF (IFL .EQ. 1) THEN
C
C**** NOT ENOUGH DATA TO MAKE ESTIMATES, WHICH PRESUMES DG
C**** IS RATHER SMALL; THEREFORE INCREASE THE DEGREE.
C
AXION(IA)=1
NEWDG(IA)=MIN(DG+2,MDGPO)
ELSE
DO 40 I=DG+1,MDGPO
IF (CONSV) THEN
XX=LOG(1E+0+I)
VAR=COVAR(1,1)+XX*XX*COVAR(2,2)+2E+0*XX*COVAR(1,2)
THSLN=EXA*(I+1)**POW*EXP(CONF*SQRT(VAR))
ELSE
THSLN=EXA*(I+1)**POW
ENDIF
POSCO(I+1)=ABS(THSLN)*RIGLL(LOD+I)/LGTOL
40 CONTINUE
PNDG=CRITCO(MDGPO+1,POSCO)+MINDG
IF (PNDG .LE. MDGPO) THEN
C
C**** INCREASE DEGREE
C
AXION(IA)=1
NEWDG(IA)=PNDG
ELSE
C
C**** SUBDIVIDE ARC AND ASSIGN NEW HALF-LENGTH.
C
AXION(IA)=2
BETA=JACIN(AJT)
LAM=MIN(1E+0,1E+0+BETA)
IF (AJT .NE. NJIND) THEN
NEWHL(IA)=(1E+0/POSCO(CI+1))**
+ (1E+0/(1E+0+LAM+BETA))
ELSE
NEWHL(IA)=5E-1
ENDIF
ENDIF
ENDIF
ENDIF
C
C**** NOW UPDATE THE EFFECTIVE STOPPING TOLERANCE
C
J=HISUB(IA)-MINDG
DO 50 I=J,HISUB(IA)
TERM=ABS(SOLUN(I))*RIGLL(LOD+I-LOM)
ESTOL=MAX(ESTOL,EXP(TERM)-1E+0)
50 CONTINUE
60 CONTINUE
C
ACCPT=.TRUE.
DO 70 I=1,TNSUA
IF (AXION(I) .GT. 0) THEN
ACCPT=.FALSE.
GOTO 80
ENDIF
70 CONTINUE
C
80 CONTINUE
C
IER=0
C
END
SUBROUTINE BCFSNG(TNSUC,DGPOC,JTYPC,LSUBC,H0VLC,JAINC,BFSNC,SOLNC)
INTEGER TNSUC
INTEGER DGPOC(*),JTYPC(*),LSUBC(*)
REAL H0VLC(*),JAINC(*)
COMPLEX BFSNC(*),SOLNC(*)
C
C PERFORMS VARIOUS PRELIMINARY TASKS TO PREPARE FOR THE POST-
C PROCESSING QUADRATURE CALCULATIONS.
C
C SETS UP THE ARRAY OF COEFFICIENTS BFSNC NEEDED FOR THE CALCULATION
C OF THE COMPLEX BOUNDARY CORRESPONDENCE FUNCTIONS FOR THE MAP
C CANONICAL --> PHYSICAL; THESE ARE SIMPLY RELATED TO THE SOLUTION
C COEFFICIENT ARRAY SOLNC.
C
C LOCAL VARIABLES
C
INTEGER AJTC,DEG,I,J,J1,JTC,LO
REAL B1,RTH0,TUPI
C
TUPI=8E+0*ATAN(1E+0)
C
DO 30 I=1,TNSUC
JTC=JTYPC(I)
AJTC=ABS(JTC)
RTH0=SQRT(H0VLC(AJTC))
B1=JAINC(AJTC)+1E+0
DEG=DGPOC(I)
LO=LSUBC(I)
C
BFSNC(LO)=TUPI*SOLNC(LO)/(B1*RTH0)
DO 10 J=1,DEG
J1=LO+J
BFSNC(J1)=TUPI*SOLNC(J1)/SQRT(J*(J+B1))
10 CONTINUE
C
IF (JTC .LT. 0) THEN
DO 20 J=1,DEG,2
J1=LO+J
BFSNC(J1)=-BFSNC(J1)
20 CONTINUE
ENDIF
C
30 CONTINUE
C
END
SUBROUTINE BCFVTF(BCFSN,VTARG,DGPOL,JATYP,LOSUB,PARNT,RFARC,TNSUA,
+H0VAL,JACIN,RFARG,SOLUN)
INTEGER RFARC,TNSUA
INTEGER DGPOL(*),JATYP(*),LOSUB(*),PARNT(*)
REAL RFARG
REAL BCFSN(*),H0VAL(*),JACIN(*),SOLUN(*),VTARG(*)
C
C PERFORMS VARIOUS PRELIMINARY TASKS TO PREPARE FOR THE POST-
C PROCESSING QUADRATURE CALCULATIONS.
C
C SETS UP THE ARRAY OF COEFFICIENTS BCFSN NEEDED FOR THE
C CALCULATION OF THE BOUNDARY CORRESPONDENCE FUNCTIONS FOR THE MAP
C PHYSICAL --> CANONICAL; THESE ARE SIMPLY RELATED TO THE SOLUTION
C COEFFICIENT ARRAY SOLUN.
C
C CALCULATES THE ARGUMENTS VTARG OF THE IMAGES ON THE UNIT CIRCLE
C OF THE END POINTS OF ALL SUBARCS, ENFORCING THE USER'S ROTATION
C CONDITION THAT PARFUN(RFARC,(-1.0,0.0)) BE MAPPED TO THE POINT
C WITH ARGUMENT RFARG.
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,I,J,J1,JT,LO
REAL B1,RTH0,THET0,TUPI
C
TUPI=8E+0*ATAN(1E+0)
VTARG(1)=0E+0
C
DO 30 I=1,TNSUA
JT=JATYP(I)
AJT=ABS(JT)
RTH0=SQRT(H0VAL(AJT))
B1=JACIN(AJT)+1E+0
DEG=DGPOL(I)
LO=LOSUB(I)
VTARG(I+1)=VTARG(I)+SOLUN(LO)*TUPI*RTH0
C
BCFSN(LO)=TUPI*SOLUN(LO)/(B1*RTH0)
DO 10 J=1,DEG
J1=LO+J
BCFSN(J1)=TUPI*SOLUN(J1)/SQRT(J*(J+B1))
10 CONTINUE
C
IF (JT .LT. 0) THEN
DO 20 J=1,DEG,2
J1=LO+J
BCFSN(J1)=-BCFSN(J1)
20 CONTINUE
ENDIF
C
30 CONTINUE
C
I=1
40 IF (PARNT(I) .EQ. RFARC) THEN
THET0=RFARG-VTARG(I)
ELSE
I=I+1
GOTO 40
ENDIF
C
DO 50 I=1,TNSUA
VTARG(I)=VTARG(I)+THET0
50 CONTINUE
VTARG(TNSUA+1)=VTARG(1)+TUPI
C
END
SUBROUTINE BISNEW(IER,LL,TT,UU,A1COF,ACOEF,B1COF,BCFSN,BCOEF,BETA,
+DEG,H0VAL,H1VAL,JACOF,NEWTL,SJT,RRHS,TOLIW)
INTEGER DEG,IER
REAL A1COF(*),ACOEF(*),B1COF(*),BCFSN(*),BCOEF(*),BETA,H0VAL,
+H1VAL,JACOF,LL,NEWTL,TT,UU,SJT,RRHS,TOLIW
C
C A MIXTURE OF BISECTION AND NEWTON'S METHOD TO SOLVE THE NON-LINEAR
C BOUNDARY CORRESPONDENCE EQUATION
C
C THETA(TT) = CONST
C
C FOR REAL PARAMETER TT GIVEN REAL CONST; SEE RB#50 P134. THE
C INTERVAL (LL,UU) SHOULD BRACKET TT.
C
C IER=0 - NORMAL EXIT
C IER=34 - FUNCTION HAS SAME SIGN AT LL AND UU
C IER=35 - ZERO FUNCTION DERIVATIVE DETECTED
C
C LOCAL VARIABLES
C
INTEGER MNITS,NBSCT,NITS,STEPS
REAL DFT,EPS,FL,FT,FU,JACSUM,RDIFF,TUPI
PARAMETER (MNITS=10,NBSCT=3)
EXTERNAL JACSUM
C
TUPI=8E+0*ATAN(1E+0)
C
FL=JACSUM(SJT*LL,DEG-1,A1COF,B1COF,H1VAL,BCFSN(2))
FL=BCFSN(1)-(1E+0-SJT*LL)*FL
FL=(1E+0+SJT*LL)**(1E+0+BETA)*FL-RRHS
C
FU=JACSUM(SJT*UU,DEG-1,A1COF,B1COF,H1VAL,BCFSN(2))
FU=BCFSN(1)-(1E+0-SJT*UU)*FU
FU=(1E+0+SJT*UU)**(1E+0+BETA)*FU-RRHS
C
IF (FL*FU .GT. 0E+0) THEN
IER=34
RETURN
ENDIF
C
C ENTER NEWTON ITERATION MODE
C
10 CONTINUE
TT=(UU+LL)*5E-1
NITS=0
20 CONTINUE
FT=JACSUM(SJT*TT,DEG-1,A1COF,B1COF,H1VAL,BCFSN(2))
FT=BCFSN(1)-(1E+0-SJT*TT)*FT
FT=(1E+0+SJT*TT)**(1E+0+BETA)*FT-RRHS
DFT=JACSUM(SJT*TT,DEG,ACOEF,BCOEF,H0VAL,JACOF)
DFT=TUPI*(1E+0+SJT*TT)**BETA*DFT*SJT
IF (DFT.EQ.0E+0) THEN
IER=35
RETURN
ENDIF
RDIFF=FT/DFT
TT=TT-RDIFF
NITS=NITS+1
IF (ABS(RDIFF) .LT. NEWTL) THEN
C
C NEWTON ITERATIONS HAVE CONVERGED FOR TT
C
IER=0
RETURN
ELSE IF (TT.LE.LL .OR. TT.GE.UU .OR. NITS.EQ.MNITS) THEN
C
C PERFORM NBSCT BISECTION STEPS
C
STEPS=0
30 CONTINUE
EPS=(UU-LL)*5E-1
IF (EPS.LT.TOLIW) THEN
C
C BISECTION ITERATIONS HAVE CONVERGED FOR TT
C
IER=0
RETURN
ENDIF
TT=(UU+LL)*5E-1
FT=JACSUM(SJT*TT,DEG-1,A1COF,B1COF,H1VAL,BCFSN(2))
FT=BCFSN(1)-(1E+0-SJT*TT)*FT
FT=(1E+0+SJT*TT)**(1E+0+BETA)*FT-RRHS
C
IF (FT*FL.LT.0E+0) THEN
UU=TT
FU=FT
ELSE
LL=TT
FL=FT
ENDIF
STEPS=STEPS+1
IF (STEPS .EQ. NBSCT) THEN
C
C RE-START NEWTON MODE
C
GOTO 10
ELSE
C
C CONTINUE WITH BISECTION
C
GOTO 30
ENDIF
ELSE
C
C CONTINUE WITH NEWTON MODE
C
GOTO 20
ENDIF
C
END
SUBROUTINE BMCANP(THETA,PHYPT,DERIV,WANTD,INTER,CENTR,IGEOM,RGEOM,
+ISNCA,RSNCA,ZSNCA,WANTM,IER)
C
INTEGER IER
INTEGER IGEOM(*),ISNCA(*)
REAL THETA
REAL RGEOM(*),RSNCA(*)
COMPLEX PHYPT,DERIV,CENTR
COMPLEX ZSNCA(*)
LOGICAL WANTD,INTER,WANTM
C
C ......................................................................
C
C 1. BMCANP
C BOUNDARY MAPPING FOR THE CANONICAL --> PHYSICAL MAP.
C
C 2. PURPOSE
C GIVEN A POINT ON THE UNIT CIRCLE, THIS ROUTINE COMPUTES THE
C CORRESPONDING APPROXIMATE IMAGE POINT ON THE BOUNDARY OF THE
C PHYSICAL DOMAIN AND, IF REQUESTED, ALSO COMPUTES THE
C DERIVATIVE OF THE MAP : CANONICAL --> PHYSICAL AT THE GIVEN
C POINT ON THE UNIT CIRCLE.
C
C 3. CALLING SEQUENCE
C CALL BMCANP(THETA,PHYPT,DERIV,WANTD,INTER,CENTR,IGEOM,RGEOM,
C ISNCA,RSNCA,ZSNCA,WANTM,IER)
C
C PARAMETERS
C ON ENTRY
C THETA - REAL
C THE ARGUMENT OF THE GIVEN POINT ON THE UNIT
C CIRCLE.
C
C WANTD - LOGICAL
C IF WANTD IS TRUE THEN DERIV IS COMPUTED OTHERWISE
C DERIV ISN'T COMPUTED.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE. (AS PREVIOUSLY USED IN JAPHYC, GQPHYC)
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY JACANP.
C
C RSNCA - REAL ARRAY
C THE REAL VECTOR PREVIOUSLY SET UP BY JACANP.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY JACANP.
C
C WANTM - LOGICAL
C IF WANTM IS TRUE THEN, ON AN ABNORMAL EXIT, AN
C ERROR MESSAGE IS WRITTEN ON THE STANDARD OUTPUT
C CHANNEL. IF WANTM IS FALSE THEN NO MESSAGE IS
C WRITTEN.
C
C ON EXIT
C PHYPT - COMPLEX
C THE COMPUTED POINT ON THE PHYSICAL BOUNDARY CORR-
C ESPONDING TO THE POINT WITH ARGUMENT THETA ON THE
C UNIT CIRCLE.
C
C DERIV - COMPLEX
C THE COMPUTED DERIVATIVE OF THE MAP : CANONICAL -->
C PHYSICAL AT THE GIVEN POINT ON THE UNIT CIRCLE.
C THIS IS COMPUTED ONLY IF WANTD IS TRUE.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINE JACANP HAS SUCCESSFULLY EXECUTED, AND THAT SOME
C INPUT ARGUMENTS FOR BMCANP ARE OUTPUT VALUES FROM JACANP.
C
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOFC,AICOC,BCOFC,BFSNC,BICOC,DGPOC,H0VLC,HALEN,HIVLC,
+JAINC,JTYPC,LSUBC,NARCS,NJIND,NQPTS,MIDPT,MNCOF,MNSUA,MNSUC,PARNT,
+PHPAS,PRNSA,SOLNC,TNGQP,TNSUC,VARGC,VTARG
CHARACTER IERTXT*6
C
EXTERNAL BMCAP1,IERTXT
C
NARCS=ISNCA(1)
NQPTS=ISNCA(2)
TNSUC=ISNCA(3)
MNSUC=ISNCA(5)
MNCOF=ISNCA(6)
MNSUA=IGEOM(4)
C
NJIND=NARCS+1
TNGQP=NQPTS*NJIND
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP POINTERS TO ISNCA, RSNCA AND ZSNCA, AS IN JACANP
C
DGPOC=7
JTYPC=MNSUC+7
LSUBC=2*MNSUC+7
PRNSA=3*MNSUC+7
ACOFC=2
BCOFC=TNGQP+2
AICOC=2*TNGQP+2
BICOC=3*TNGQP+2
H0VLC=6*TNGQP+2
HIVLC=NJIND+6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
PHPAS=4*NJIND+6*TNGQP+2
VARGC=MNSUC+4*NJIND+6*TNGQP+2
BFSNC=2
SOLNC=MNCOF+2
C
C**** GET REQUIRED MAP AND DERIVATIVE
C
CALL BMCAP1(PHYPT,DERIV,THETA,NQPTS,TNSUC,ISNCA(DGPOC),
+ISNCA(JTYPC),ISNCA(LSUBC),IGEOM(PARNT),ISNCA(PRNSA),RSNCA(AICOC),
+RSNCA(ACOFC),RSNCA(BICOC),RSNCA(BCOFC),RSNCA(H0VLC),RSNCA(HIVLC),
+RGEOM(HALEN),RSNCA(JAINC),RGEOM(MIDPT),RSNCA(PHPAS),RGEOM(VTARG),
+RSNCA(VARGC),ZSNCA(BFSNC),CENTR,ZSNCA(SOLNC),INTER,WANTD,IER)
C
C**** SEND ERROR MESSAGE TO STANDARD OUTPUT OF NECESSARY
C
IF (IER.GT.0 .AND. WANTM) WRITE(*,*) IERTXT(IER)
C
END
SUBROUTINE BMCAP1(PHYPT,DERIV,THETA,NQPTS,TNSUC,DGPOC,JTYPC,LSUBC,
+PARNT,PRNSA,A1COC,ACOFC,B1COC,BCOFC,H0VLC,H1VLC,HALEN,JAINC,MIDPT,
+PHPAS,THET0,VARGC,BFSNC,CENTR,SOLNC,INTER,WANTD,IER)
INTEGER IER,NQPTS,TNSUC
INTEGER DGPOC(*),JTYPC(*),LSUBC(*),PARNT(*),PRNSA(*)
REAL THET0,THETA
REAL A1COC(*),ACOFC(*),B1COC(*),BCOFC(*),H0VLC(*),H1VLC(*),
+HALEN(*),JAINC(*),MIDPT(*),PHPAS(*),VARGC(*)
COMPLEX CENTR,DERIV,PHYPT
COMPLEX BFSNC(*),SOLNC(*)
LOGICAL INTER,WANTD
C
C GIVEN A POINT ON THE UNIT CIRCLE DEFINED BY ITS ARGUMENT THETA
C TO COMPUTE ITS IMAGE POINT PHYPT ON THE BOUNDARY OF THE
C PHYSICAL DOMAIN. IN CASE WANTD=.TRUE. THEN ALSO COMPUTE THE
C DERIVATIVE DERIV OF THE MAP ONTO THE PHYSICAL DOMAIN AT THE GIVEN
C BOUNDARY POINT ON THE UNIT DISC.
C
C IER=0 - NORMAL TERMINATION
C IER=46 - LOCAL PARAMETER MNCOF NEEDS INCREASING
C
C LOCAL VARIABLES
C
INTEGER AJTC,DGC,I,I1,IA,JTC,LODC,LOMC,MNCOF,PSA
REAL AA,ARGW,BB,BETAC,HA,MD,R1MACH,SJTC,TT,TUPI
COMPLEX CT0,FP,JACSUC,PARFUN,PHI
PARAMETER (MNCOF=32)
COMPLEX JACOF(MNCOF)
EXTERNAL JACSUC,PARFUN,R1MACH
C
TUPI=8E+0*ATAN(1E+0)
ARGW=THETA
C
10 CONTINUE
IF (ARGW .GT. THET0+TUPI) THEN
ARGW=ARGW-TUPI
GOTO 10
ENDIF
20 CONTINUE
IF (ARGW .LT. THET0) THEN
ARGW=ARGW+TUPI
GOTO 20
ENDIF
C
IA=1
30 CONTINUE
IF (VARGC(IA).LE.ARGW .AND. ARGW.LE.VARGC(IA+1)) THEN
C
C WW IS ON ARC IA AND WE USE THE CONTINUATION OF THE BOUNDARY
C CORRESPONDENCE FUNCTION TO ESTIMATE PHYPT AND (IF WANTED) THE
C DERIVATIVE.
C
HA=(VARGC(IA+1)-VARGC(IA))*5E-1
MD=(VARGC(IA+1)+VARGC(IA))*5E-1
TT=(ARGW-MD)/HA
IF (TT .GT. 1E+0) THEN
TT=1E+0
ELSE IF (TT .LT. -1E+0) THEN
TT=-1E+0
ENDIF
C
DGC=DGPOC(IA)
IF (DGC+1 .GT. MNCOF) THEN
IER=46
RETURN
ENDIF
JTC=JTYPC(IA)
AJTC=ABS(JTC)
BETAC=JAINC(AJTC)
LOMC=LSUBC(IA)
LODC=(AJTC-1)*NQPTS+1
SJTC=SIGN(1E+0,REAL(JTC))
PSA=PRNSA(IA)
C
IF (PHPAS(IA+1) .LE. PHPAS(IA)) THEN
BB=1E+0
ELSE
BB=PHPAS(IA+1)
ENDIF
AA=PHPAS(IA)
C
IF (SJTC.GT.0) THEN
CT0=CMPLX(MIDPT(PSA)+AA*HALEN(PSA))
ELSE
CT0=CMPLX(MIDPT(PSA)+BB*HALEN(PSA))
ENDIF
C
TT=SJTC*TT
FP=(1E+0+TT)**(BETAC+1E+0)
IF (INTER) THEN
FP=-FP
ENDIF
PHI=JACSUC(TT,DGC-1,A1COC(LODC),B1COC(LODC),
+ H1VLC(AJTC),BFSNC(LOMC+1))
PHI=(BFSNC(LOMC)-(1E+0-TT)*PHI)*SJTC*CMPLX(0E+0,1E+0)
PHYPT=CENTR+(PARFUN(PARNT(PSA),CT0)-CENTR)*EXP(FP*PHI)
C
IF (WANTD) THEN
IF (BETAC.LT.0E+0 .AND. (1E+0+TT).LE.0E+0) THEN
C
C WE ARE AT A CORNER WITH INFINITE DERIVATIVE.
C
DERIV=CMPLX(R1MACH(2),R1MACH(2))
ELSE IF (BETAC.GT.0E+0 .AND. (1E+0+TT).LE.0E+0) THEN
C
C WE ARE AT A CORNER WITH ZERO DERIVATIVE
C
DERIV=(0E+0,0E+0)
ELSE
DO 40 I=1,DGC+1
I1=I+LOMC-1
JACOF(I)=SOLNC(I1)
40 CONTINUE
DO 50 I=2,DGC+1,2
JACOF(I)=SJTC*JACOF(I)
50 CONTINUE
PHI=JACSUC(TT,DGC,ACOFC(LODC),BCOFC(LODC),H0VLC(AJTC),
+ JACOF)
DERIV=TUPI*FP*PHI*(PHYPT-CENTR)*
+ CMPLX(COS(THETA),-SIN(THETA))/HA/(1E+0+TT)
ENDIF
ENDIF
ELSE
IA=IA+1
GOTO 30
ENDIF
C
C NORMAL EXIT
C
IER=0
END
SUBROUTINE BMPHC1(IARC,PHYPT,CANPT,DERIV,NQPTS,TNSUA,DGPOL,JATYP,
+LOSUB,LPQSB,NPPQF,PARNT,A1COF,ACOEF,B1COF,BCFSN,BCOEF,H0VAL,H1VAL,
+HALEN,JACIN,MIDPT,SOLUN,TPPQF,TRRAD,VTARG,ZPPQF,INTER,WANTD,
+IER)
INTEGER IARC,IER,NQPTS,TNSUA
INTEGER DGPOL(*),JATYP(*),LOSUB(*),LPQSB(*),NPPQF(*),PARNT(*)
REAL A1COF(*),ACOEF(*),B1COF(*),BCFSN(*),BCOEF(*),H0VAL(*),
+H1VAL(*),HALEN(*),JACIN(*),MIDPT(*),SOLUN(*),TPPQF(*),TRRAD(*),
+VTARG(*)
COMPLEX CANPT,DERIV,PHYPT,ZPPQF(*)
LOGICAL INTER,WANTD
C
C GIVEN A POINT (DEFINED BY IARC AND PHYPT AS EXPLAINED NEXT) ON
C THE BOUNDARY OF THE PHYSICAL DOMAIN, TO COMPUTE ITS IMAGE CANPT
C ON THE UNIT DISC. IN CASE WANTD=.TRUE. THEN ALSO COMPUTE THE
C DERIVATIVE DERIV OF THE MAP ONTO THE DISC AT THE GIVEN BOUNDARY
C POINT.
C
C IF IARC > 0 THEN PHYPT IS THE PARAMETER VALUE OF THE
C PHYSICAL POINT ON THE PARENT ANALYTIC ARC NUMBER IARC OTHERWISE
C PHYPT DEFINES THE COORDINATES OF A PHYSICAL POINT SOMEWHERE ON
C THE BOUNDARY.
C
C IER=0 - NORMAL EXIT.
C IER=44 - LOCAL PARAMETER MNCOF NEEDS INCREASING.
C IER=45 - THE PHYSICAL POINT DEFINED BY PHYPT (WITH IARC<0) HAS NOT
C BEEN DETECTED AS LYING ON THE BOUNDARY; ACTUALLY, IT HAS
C NOT BEEN DETECTED AS LYING PATHOLOGICALY CLOSE TO THE
C BOUNDARY. CHECK THAT PHYPT IS CORRECT AND IF IT IS THEN
C CONSIDER INCREASING THE PATHOLOGICAL TOLERANCE PARAMETER
C PTHTL IN THE FIRST LINE BELOW.
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,I,I1,IA,K,J1,JQ,JT,LOD,LOM,MNCOF,NQ,PT
REAL BETA,DIST,HL,JACSUM,MD,MINDS,NEWTL,PHI,PTHTL,R1MACH,RBCF,
+SJT,SUM,TOLSM,TT,TUPI,TXI
COMPLEX BCF,CJACSU,CT,DIFF2,DPARFN,PARFUN,PSI,WGHT,XI,ZXI,
+ZTOB1,ZZ
C
PARAMETER (MNCOF=32)
REAL JACOF(MNCOF)
C
EXTERNAL CJACSU,DPARFN,JACSUM,PARFUN,R1MACH,ZTOB1
C
NEWTL=SQRT(R1MACH(4))
PTHTL=NEWTL
TOLSM=1E+1*R1MACH(4)
TUPI=8E+0*ATAN(1E+0)
C
IF (IARC .GT. 0) THEN
C
C *PHYPT* IS THE PARAMETER VALUE OF THE PHYSICAL POINT ON THE
C PARENT ANALYTIC ARC NUMBER *IARC*.
C
C FIRST FIND THE CORRESPONDING SUBARC NUMBER AND LOCAL PARAMETER.
C
TT=REAL(PHYPT)
IF (TT .LT. -1E+0) THEN
TT=-1E+0
ENDIF
IF (TT .GT. 1E+0) THEN
TT=1E+0
ENDIF
I=1
10 CONTINUE
PT=PARNT(I)
HL=HALEN(I)
MD=MIDPT(I)
SUM=MD+HL
C
IF (ABS(SUM-1E+0) .LT. TOLSM) THEN
SUM=1E+0
ENDIF
C
IF (PT.EQ.IARC .AND. TT.LE.SUM) THEN
IA=I
TT=(TT-MD)/HL
ELSE
I=I+1
GOTO 10
ENDIF
C
IF (TT .LT. -1E+0) THEN
TT=-1E+0
ENDIF
IF (TT .GT. 1E+0) THEN
TT=1E+0
ENDIF
C
JT=JATYP(IA)
SJT=SIGN(1E+0,REAL(JT))
AJT=ABS(JT)
BETA=JACIN(AJT)
DEG=DGPOL(IA)
IF (DEG+1 .GT. MNCOF) THEN
IER=44
RETURN
ENDIF
LOM=LOSUB(IA)
LOD=(AJT-1)*NQPTS+1
C
TT=SJT*TT
PHI=JACSUM(TT,DEG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=(1E+0+TT)**(BETA+1E+0)*(BCFSN(LOM)-(1E+0-TT)*PHI)
IF (JT .GT. 0) THEN
RBCF=VTARG(IA)
ELSE
RBCF=VTARG(IA+1)
ENDIF
RBCF=RBCF+SJT*PHI
CANPT=CEXP((0E+0,1E+0)*RBCF)
IF (WANTD) THEN
IF (BETA.LT.0E+0 .AND. (1E+0+TT).LE.0E+0) THEN
C
C WE ARE AT A CORNER WITH INFINITE DERIVATIVE.
C
DERIV=CMPLX(R1MACH(2),R1MACH(2))
ELSE IF (BETA.GT.0E+0 .AND. (1E+0+TT).LE.0E+0) THEN
C
C WE ARE AT A CORNER WITH ZERO DERIVATIVE
C
DERIV=(0E+0,0E+0)
ELSE
DO 15 I=1,DEG+1
I1=I+LOM-1
JACOF(I)=SOLUN(I1)
15 CONTINUE
DO 20 I=2,DEG+1,2
JACOF(I)=SJT*JACOF(I)
20 CONTINUE
PHI=JACSUM(TT,DEG,ACOEF(LOD),BCOEF(LOD),H0VAL(AJT),JACOF)
DERIV=TUPI*(1E+0+TT)**BETA*PHI*(0E+0,1E+0)*CANPT/
+ DPARFN(IARC,PHYPT)/HL
ENDIF
ENDIF
ELSE
C
C *PHYPT* IS A POINT SOMEWHERE ON THE PHYSICAL BOUNDARY.
C
ZZ=PHYPT
DO 200 IA=1,TNSUA
PT=PARNT(IA)
JT=JATYP(IA)
NQ=NPPQF(IA)
K=LPQSB(IA)-1
HL=HALEN(IA)
MD=MIDPT(IA)
DO 100 JQ=1,NQ
K=K+1
DIFF2=ZZ-ZPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .LT. TRRAD(K)) THEN
C
C ZZ IS CLOSE TO ARC IA.
C
J1=JQ
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
40 CONTINUE
J1=J1+1
IF (J1 .LE. NQ) THEN
K=K+1
DIFF2=ZZ-ZPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .LT. MINDS) THEN
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
GOTO 40
ENDIF
ENDIF
C
C PRELIMINARIES
C
SJT=SIGN(1E+0,REAL(JT))
AJT=ABS(JT)
BETA=JACIN(AJT)
DEG=DGPOL(IA)
IF (DEG+1 .GT. MNCOF) THEN
IER=44
RETURN
ENDIF
LOM=LOSUB(IA)
LOD=(AJT-1)*NQPTS+1
C
C NOW USE NEWTON'S METHOD TO ESTIMATE THE PARAMETRIC
C PRE-IMAGE XI OF ZZ.
C
XI=CMPLX(TXI)
CT=MD+HL*XI
DIFF2=(ZXI-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
50 CONTINUE
IF (ABS(DIFF2) .GT. NEWTL) THEN
CT=MD+HL*XI
DIFF2=(PARFUN(PT,CT)-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
GOTO 50
ELSE
C
C LAST ITERATION
C
CT=MD+HL*XI
DIFF2=(PARFUN(PT,CT)-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
ENDIF
XI=SJT*XI
C
IF (ABS(AIMAG(XI)) .LT. PTHTL .AND. ABS(REAL(XI)) .LT. 1E+
+ 0+PTHTL) THEN
C
C ZZ IS PATHOLOGICALLY CLOSE TO ARC IA AND WE USE THE
C CONTINUATION OF THE BOUNDARY CORRESPONDENCE FUNCTION
C TO ESTIMATE CANPT AND THE DERIVATIVE
C
PSI=CJACSU(XI,DEG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
WGHT=ZTOB1(XI+1E+0,BETA+1E+0,JT,INTER)
PSI=WGHT*(BCFSN(LOM)-(1E+0-XI)*PSI)
IF (JT .GT. 0) THEN
BCF=VTARG(IA)
ELSE
BCF=VTARG(IA+1)
ENDIF
BCF=BCF+SJT*PSI
CANPT=CEXP((0E+0,1E+0)*BCF)
IF (WANTD) THEN
IF ((1E+0+XI).EQ.(0E+0,0E+0) .AND. BETA.LT.0E+0) THEN
C
C WE ARE AT A CORNER WITH INFINITE DERIVATIVE.
C
DERIV=CMPLX(R1MACH(2),R1MACH(2))
ELSE IF ((1E+0+XI).EQ.(0E+0,0E+0) .AND. BETA.GT.0E+0)
+ THEN
C
C WE ARE AT A CORNER WITH ZERO DERIVATIVE.
C
DERIV=(0E+0,0E+0)
ELSE
DO 55 I=1,DEG+1
I1=I+LOM-1
JACOF(I)=SOLUN(I1)
55 CONTINUE
DO 60 I=2,DEG+1,2
JACOF(I)=SJT*JACOF(I)
60 CONTINUE
PSI=CJACSU(XI,DEG,ACOEF(LOD),BCOEF(LOD),H0VAL(AJT),
+ JACOF)
CT=MD+HL*SJT*XI
WGHT=WGHT/(1E+0+XI)
DERIV=TUPI*WGHT*PSI*(0E+0,1E+0)*CANPT
+ /DPARFN(PT,CT)/HL
ENDIF
ENDIF
GOTO 300
ENDIF
C
C END OF *IF (DIST .LT. TRRAD(K)) THEN* FOLLOWS
C
ENDIF
100 CONTINUE
200 CONTINUE
IER=45
RETURN
ENDIF
C
300 CONTINUE
C
C NORMAL EXIT
C
IER=0
END
SUBROUTINE BMPHYC(IARC,PHYPT,CANPT,DERIV,WANTD,INTER,IGEOM,RGEOM,
+ISNPH,RSNPH,IQUPH,RQUPH,ZQUPH,WANTM,IER)
C
INTEGER IARC,IER
INTEGER IGEOM(*),ISNPH(*),IQUPH(*)
REAL RGEOM(*),RSNPH(*),RQUPH(*)
COMPLEX PHYPT,CANPT,DERIV
COMPLEX ZQUPH(*)
LOGICAL WANTD,INTER,WANTM
C
C ......................................................................
C
C 1. BMPHYC
C BOUNDARY MAPPING FOR THE PHYSICAL --> CANONICAL MAP.
C
C 2. PURPOSE
C GIVEN A POINT ON THE BOUNDARY OF THE PHYSICAL DOMAIN, THIS
C ROUTINE COMPUTES THE CORRESPONDING APPROXIMATE IMAGE POINT
C ON THE UNIT DISC AND, IF REQUESTED, ALSO COMPUTES THE
C DERIVATIVE OF THE MAP : PHYSICAL --> CANONICAL AT THE GIVEN
C POINT ON THE PHYSICAL BOUNDARY.
C
C 3. CALLING SEQUENCE
C CALL BMPHYC(IARC,PHYPT,CANPT,DERIV,WANTD,INTER,IGEOM,RGEOM,
C ISNPH,RSNPH,IQUPH,RQUPH,ZQUPH,WANTM,IER)
C
C PARAMETERS
C ON ENTRY
C IARC - INTEGER
C ALLOWS TWO MODES OF DEFINING THE POINT ON THE
C BOUNDARY OF THE PHYSICAL DOMAIN. IF IARC > 0 THEN
C THE PHYSICAL POINT LIES ON ANALYTIC ARC NUMBER
C IARC (AS DEFINED IN THE PARAMETRIC FUNCTION
C PARFUN). IF IARC <= 0 THEN THE PARTICULAR ARC ON
C WHICH THE PHYSICAL POINT LIES IS CONSIDERED TO BE
C UNKNOWN ON ENTRY.
C
C PHYPT - COMPLEX
C IF IARC > 0 THEN PHYPT IS THE (COMPLEX) PARAMETER
C VALUE WHICH DEFINES THE PHYSICAL POINT ON ANALYTIC
C ARC NUMBER IARC. IF IARC <= 0 THEN PHYPT IS THE
C GIVEN PHYSICAL POINT.
C
C WANTD - LOGICAL
C IF WANTD IS TRUE THEN DERIV IS COMPUTED OTHERWISE
C DERIV ISN'T COMPUTED.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE. (AS PREVIOUSLY USED IN JAPHYC, GQPHYC)
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC.
C
C IQUPH - INTEGER ARRAY
C THE INTEGER VECTOR IQUPH PREVIOUSLY SET UP BY
C GQPHYC.
C
C RQUPH - REAL ARRAY
C THE REAL ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C ZQUPH - COMPLEX ARRAY
C THE COMPLEX ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C WANTM - LOGICAL
C IF WANTM IS TRUE THEN, ON AN ABNORMAL EXIT, AN
C ERROR MESSAGE IS WRITTEN ON THE STANDARD OUTPUT
C CHANNEL. IF WANTM IS FALSE THEN NO MESSAGE IS
C WRITTEN.
C
C
C ON EXIT
C CANPT - COMPLEX
C THE POINT ON THE UNIT DISC CORRESPONDING TO THE
C GIVEN PHYSICAL POINT UNDER THE MAP : PHYSICAL -->
C CANONICAL.
C
C DERIV - COMPLEX
C THE COMPUTED DERIVATIVE OF THE MAP : PHYSICAL -->
C CANONICAL AT THE GIVEN POINT ON THE PHYSICAL BOUN-
C DARY. THIS IS COMPUTED ONLY IF WANTD IS TRUE.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINES JAPHYC AND GQPHYC HAVE SUCCESSFULLY EXECUTED,
C AND THAT MANY INPUT ARGUMENTS FOR BMPHYC ARE OUTPUT VALUES
C FROM JAPHYC AND GQPHYC.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOEF,AICOF,BCFSN,BCOEF,BICOF,DGPOL,H0VAL,HALEN,HIVAL,
+JACIN,JATYP,LOSUB,LQSBF,MIDPT,MNSUA,MNEQN,MQUPH,NARCS,NJIND,NPPQF,
+NQPTS,PARNT,SOLUN,TNGQP,TNSUA,TPPQF,TRRAD,VTARG,ZPPQF
CHARACTER*6 IERTXT
C
EXTERNAL BMPHC1,IERTXT
C
NARCS=ISNPH(1)
NJIND=NARCS+1
NQPTS=ISNPH(2)
TNSUA=ISNPH(3)
MNSUA=ISNPH(5)
MNEQN=ISNPH(6)
MQUPH=IQUPH(4)
TNGQP=NQPTS*NJIND
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP THE POINTERS TO ISNPH AND RSNPH, AS IN JAPHYC
C
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
BCFSN=MNSUA+3*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
C**** SET UP POINTERS TO IQUPH AND RQUPH, AS IN GQPHYC
C
LQSBF=5
NPPQF=MNSUA+5
TPPQF=2
TRRAD=MQUPH+2
ZPPQF=2
C
C**** GET REQUIRED MAP AND DERIVATIVE
C
CALL BMPHC1(IARC,PHYPT,CANPT,DERIV,NQPTS,TNSUA,ISNPH(DGPOL),
+ISNPH(JATYP),ISNPH(LOSUB),IQUPH(LQSBF),IQUPH(NPPQF),IGEOM(PARNT),
+RSNPH(AICOF),RSNPH(ACOEF),RSNPH(BICOF),RSNPH(BCFSN),RSNPH(BCOEF),
+RSNPH(H0VAL),RSNPH(HIVAL),RGEOM(HALEN),RSNPH(JACIN),RGEOM(MIDPT),
+RSNPH(SOLUN),RQUPH(TPPQF),RQUPH(TRRAD),RGEOM(VTARG),ZQUPH(ZPPQF),
+INTER,WANTD,IER)
C
C**** SEND ERROR MESSAGE TO STANDARD OUTPUT OF NECESSARY
C
IF (IER.GT.0 .AND. WANTM) WRITE(*,*) IERTXT(IER)
C
END
SUBROUTINE CATPH4(NPTS,PHYPT,CANPT,NARCS,NQPTS,TNSUC,DGPOC,JTYPC,
+LSUBC,LQSBG,NPPQG,PARNT,PRNSA,A1COC,ACOFC,B1COC,BCOFC,H0VLC,
+H1VLC,HALEN,JAINC,LGTOL,MIDPT,PHPAS,QUPTC,QUWTC,THET0,
+VARGC,BFSNC,CENTR,FACTR,SOLNC,WPPQG,ZPPQG,INTER,IER)
INTEGER IER,NPTS,NARCS,NQPTS,TNSUC
INTEGER DGPOC(*),JTYPC(*),LSUBC(*),LQSBG(*),NPPQG(*),PARNT(*),
+PRNSA(*)
REAL LGTOL,THET0
REAL A1COC(*),ACOFC(*),B1COC(*),BCOFC(*),H0VLC(*),H1VLC(*),
+HALEN(*),JAINC(*),MIDPT(*),PHPAS(*),QUPTC(*),QUWTC(*),VARGC(*)
COMPLEX CENTR,FACTR
COMPLEX BFSNC(*),CANPT(*),PHYPT(*),SOLNC(*),WPPQG(*),ZPPQG(*)
LOGICAL INTER
C
C GIVEN THE ARRAY CANPT OF NPTS POINTS IN THE CANONICAL PLANE, THIS
C ROUTINE COMPUTES THE ARRAY PHYPT OF IMAGES IN THE PHYSICAL
C PLANE.
C
C IER=0 - NORMAL EXIT
C IER=47 - LOCAL PARAMETER MXNQD NEEDS INCREASING
C IER=48 - LOCAL PARAMETER MNCOF NEEDS INCREASING
C IER=49 - LOCAL PARAMETER MQIN1 NEEDS INCREASING
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 7 JULY 90
C.......................................................................
C
C LOCAL VARIABLES
C
INTEGER AJTC,DGC,I,IA,IP,K,J,J1,JQ,JTC,LODC,LOL,
+LOMC,MNCOF,MQIN1,MXNQD,NBSCT,NQ,NQUAD,PSA,QINTS
REAL AA,ARG,ARGW,AWW,BB,BETAC,DELTA,DIST,EFPTL,EPS,HA,ILW,IMXI,MD,
+MEAN,PI,PTHTL,R1MACH,REXI,RLW,RR,RRB,S2C,SCO,SJTC,SUM1,TOLOU,TT,
+TUPI,UPPER
COMPLEX CT0,CT2,CTA,CTB,FP,CCJACS,CSUM,CT,JACSUC,PARFUN,PHI,TERM,
+XI,WW
PARAMETER (MNCOF=32,MQIN1=21,MXNQD=144,NBSCT=3,
+PTHTL=1E-3,DELTA=2E-1)
REAL XENPT(MQIN1)
COMPLEX JCOFC(MNCOF),WSPEC(MXNQD),ZSPEC(MXNQD)
EXTERNAL CCJACS,JACSUC,PARFUN,PPSBI1,R1MACH
C
EPS=1E+1*R1MACH(4)
PI=4E+0*ATAN(1E+0)
TUPI=2E+0*PI
LOL=NARCS*NQPTS
DO 300 IP=1,NPTS
WW=CANPT(IP)
AWW=ABS(WW)
IF (AWW.LE.EPS) THEN
PHYPT(IP)=CENTR
GOTO 300
ENDIF
RLW=LOG(AWW)
ILW=ATAN2(AIMAG(WW),REAL(WW))
10 CONTINUE
IF (ILW .GT. THET0+TUPI) THEN
ILW=ILW-TUPI
GOTO 10
ENDIF
20 CONTINUE
IF (ILW .LT. THET0) THEN
ILW=ILW+TUPI
GOTO 20
ENDIF
CSUM=(0E+0,0E+0)
DO 200 IA=1,TNSUC
C
C PRELIMINARIES FOR ARC IA
C
HA=(VARGC(IA+1)-VARGC(IA))*5E-1
MD=(VARGC(IA+1)+VARGC(IA))*5E-1
EFPTL=MAX(PTHTL,EPS/HA)
IMXI=-RLW/HA
C
IF (ILW .GT. (MD+PI)) THEN
ARGW=ILW-TUPI
ELSE IF (ILW .LT. (MD-PI)) THEN
ARGW=ILW+TUPI
ELSE
ARGW=ILW
ENDIF
C
REXI=(ARGW-MD)/HA
IF (REXI .GT. 1E+0) THEN
DIST=SQRT(IMXI**2+(REXI-1E+0)**2)
ELSE IF (REXI .LT. -1E+0) THEN
DIST=SQRT(IMXI**2+(REXI+1E+0)**2)
ELSE
DIST=ABS(IMXI)
ENDIF
C
IF (DIST .GE. DELTA) THEN
C
C USE THE STANDARD PRECOMPUTED COMPOSITE GAUSSIAN RULE
C
NQ=NPPQG(IA)
K=LQSBG(IA)-1
DO 30 JQ=1,NQ
K=K+1
CT=WW/ZPPQG(K)
IF (.NOT. INTER) THEN
CT=1E+0/CT
ENDIF
CSUM=CSUM+WPPQG(K)*CLOG(1E+0-CT)
30 CONTINUE
C
ELSE IF (DIST.LT.EFPTL) THEN
C
C WW IS PATHOLOGICALLY CLOSE TO ARC IA (OR MAYBE JUST CLOSE TO
C ARC IA AND APPARENTLY OUTSIDE THE CANONICAL DOMAIN) AND WE
C USE THE CONTINUATION OF THE BOUNDARY CORRESPONDENCE FUNCTION
C TO ESTIMATE PHYPT.
C
C INITIALISE SOME DATA
C
XI=CMPLX(REXI,IMXI)
DGC=DGPOC(IA)
IF (DGC+1 .GT. MNCOF) THEN
IER=48
RETURN
ENDIF
JTC=JTYPC(IA)
AJTC=ABS(JTC)
BETAC=JAINC(AJTC)
LOMC=LSUBC(IA)
LODC=(AJTC-1)*NQPTS+1
SJTC=SIGN(1E+0,REAL(JTC))
PSA=PRNSA(IA)
C
IF (PHPAS(IA+1) .LE. PHPAS(IA)) THEN
BB=1E+0
ELSE
BB=PHPAS(IA+1)
ENDIF
AA=PHPAS(IA)
C
IF (INTER) THEN
S2C=SJTC
ELSE
S2C=-SJTC
ENDIF
C
CTA=CMPLX(MIDPT(PSA)+AA*HALEN(PSA))
CTB=CMPLX(MIDPT(PSA)+BB*HALEN(PSA))
IF (SJTC.GT.0) THEN
CT0=CTA
CT2=CTB
ELSE
CT0=CTB
CT2=CTA
ENDIF
C
TERM=1E+0+SJTC*XI
IF (TERM.EQ.(0E+0,0E+0)) THEN
PHYPT(IP)=PARFUN(PARNT(PSA),CT0)
GOTO 300
ENDIF
C
IF (TERM.EQ.(2E+0,0E+0)) THEN
PHYPT(IP)=PARFUN(PARNT(PSA),CT2)
GOTO 300
ENDIF
C
ARG=ATAN2(AIMAG(TERM),REAL(TERM))
UPPER=(1E+0+S2C*5E-1)*PI
IF (ARG.GT.UPPER) THEN
ARG=ARG-TUPI
ELSE IF (ARG.LE.(UPPER-TUPI)) THEN
ARG=ARG+TUPI
ENDIF
C
FP=ABS(TERM)**(BETAC+1E+0)*CMPLX(COS((BETAC+1E+0)*ARG),
+ SIN((BETAC+1E+0)*ARG))
IF (INTER) THEN
FP=-FP
ENDIF
PHI=CCJACS(SJTC*XI,DGC-1,A1COC(LODC),B1COC(LODC),
+ H1VLC(AJTC),BFSNC(LOMC+1))
PHI=(BFSNC(LOMC)-(1E+0-SJTC*XI)*PHI)*SJTC*CMPLX(0E+0,1E+0)
PHYPT(IP)=CENTR+(PARFUN(PARNT(PSA),CT0)-CENTR)*EXP(FP*PHI)
GOTO 300
ELSE
C
C SET UP A SPECIAL COMPOSITE GAUSSIAN RULE TO HANDLE THIS
C PARTICULAR POINT WW.
C
C INITIALISE SOME DATA
C
DGC=DGPOC(IA)
IF (DGC+1 .GT. MNCOF) THEN
IER=48
RETURN
ENDIF
JTC=JTYPC(IA)
AJTC=ABS(JTC)
BETAC=JAINC(AJTC)
LOMC=LSUBC(IA)
LODC=(AJTC-1)*NQPTS+1
SJTC=SIGN(1E+0,REAL(JTC))
SCO=SJTC
C
DO 100 J=1,DGC+1
J1=LOMC+J-1
SCO=SCO*SJTC
JCOFC(J)=SOLNC(J1)*SCO
100 CONTINUE
C
XI=SJTC*CMPLX(REXI,IMXI)
CALL PPSBI1(XI,BETAC,NQPTS,DGC,ACOFC(LODC),BCOFC(LODC),
+ H0VLC(AJTC),JCOFC,LGTOL,TOLOU,XENPT,QINTS,
+ MQIN1,IER)
IF (IER .GT. 0) THEN
IF (IER .EQ. 29) THEN
IER=49
ENDIF
RETURN
ENDIF
NQUAD=QINTS*NQPTS
IF (NQUAD .GT. MXNQD) THEN
IER=47
RETURN
ENDIF
K=0
SUM1=BETAC+1E+0
DO 130 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
DO 110 J=1,NQPTS
J1=LODC+J-1
K=K+1
TT=MEAN+RR*QUPTC(J1)
WSPEC(K)=RRB*QUWTC(J1)*JACSUC(TT,DGC,ACOFC(LODC),
+ BCOFC(LODC),H0VLC(AJTC),JCOFC)
TT=MD+TT*SJTC*HA
ZSPEC(K)=CMPLX(COS(TT),SIN(TT))
110 CONTINUE
ELSE
DO 120 J=1,NQPTS
J1=LOL+J
K=K+1
TT=MEAN+RR*QUPTC(J1)
WSPEC(K)=RR*QUWTC(J1)*(1E+0+TT)**BETAC*JACSUC(TT,
+ DGC,ACOFC(LODC),BCOFC(LODC),H0VLC(AJTC),
+ JCOFC)
TT=MD+TT*SJTC*HA
ZSPEC(K)=CMPLX(COS(TT),SIN(TT))
120 CONTINUE
ENDIF
130 CONTINUE
C
C THIS COMPLETES THE SETTING UP OF THE SPECIAL WEIGHTS
C AND POINTS WSPEC AND ZSPEC. NOW ESTIMATE THE INTEGRAL.
C
DO 140 K=1,NQUAD
CT=WW/ZSPEC(K)
IF (.NOT. INTER) THEN
CT=1E+0/CT
ENDIF
CSUM=CSUM+WSPEC(K)*CLOG(1E+0-CT)
140 CONTINUE
C
C END OF ELSE BLOCK RELATING TO SPECIAL QUADRATURE RULE FOR
C WW NEAR ARC IA
C
ENDIF
C
C END OF LOOP FOR CONTRIBUTIONS FROM ARC NUMBER IA
C
200 CONTINUE
PHYPT(IP)=CENTR+FACTR*WW*CEXP(CSUM)
C
C END OF MAP CALCULATION FOR FIELD POINT NUMBER IP
C
300 CONTINUE
C
IER=0
C
END
COMPLEX FUNCTION CCJACS(X,N,A,B,H,CO)
INTEGER N
REAL A(*),B(*),H
COMPLEX CO(*),X
C ..TO CALCULATE SUMMATION{CO(K+1)*P(K,X)},K=0(1)N, WHERE P(K,X)
C ..DENOTES THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE K
C ..EVALUATED AT X, ARRAY CO STORES A GIVEN SET OF COEFFICIENTS,
C ..ARRAYS A,B STORE THE COEFFICIENTS IN THE THREE-TERM
C ..RECURRENCE FORMULA FOR THE JACOBI POLYNOMIALS (SEE ASONJ7)
C ..AND H IS THE SQUARED 2-NORM OF UNITY.
COMPLEX PREV,CURR,NEXT
INTEGER K
C
IF (N .EQ. 0) THEN
CCJACS=CO(1)/SQRT(H)
ELSE IF (N .GT. 0) THEN
PREV=CO(N+1)
CURR=CO(N)+(X-B(N))*PREV/A(N)
DO 10 K=N-2,0,-1
NEXT=CO(K+1)+(X-B(K+1))*CURR/A(K+1)-A(K+1)*PREV/A(K+2)
PREV=CURR
CURR=NEXT
10 CONTINUE
CCJACS=CURR/SQRT(H)
ELSE
CCJACS=(0E+0,0E+0)
ENDIF
C
END
LOGICAL FUNCTION CHRIN(A,B)
CHARACTER*1 A,B
C
C**** TEST WHETHER THE EITHER CHARACTER A OR B IS CONTAINED IN THE FIRST
C**** 6 CHARACTERS OF THE NEXT RECORD FROM STANDARD INPUT.
C
C LOCAL VARIABLES
C
CHARACTER*6 C
C
READ(*,'(A6)') C
CHRIN=(INDEX(C,A).NE.0 .OR. INDEX(C,B).NE.0)
C
END
COMPLEX FUNCTION CINRAD(NARCS,NQPTS,TNSUA,DGPOL,JATYP,LOSUB,LPQSB,
+NPPQF,PARNT,ACOEF,BCOEF,H0VAL,HALEN,JACIN,LGTOL,MIDPT,QUPTS,QUWTS,
+SOLUN,TPPQF,TRRAD,WPPQF,CENTR,FACTR,ZPPQF,IER)
INTEGER IER,NARCS,NQPTS,TNSUA
INTEGER DGPOL(*),JATYP(*),LOSUB(*),LPQSB(*),NPPQF(*),PARNT(*)
REAL LGTOL
REAL ACOEF(*),BCOEF(*),
+H0VAL(*),HALEN(*),JACIN(*),MIDPT(*),QUPTS(*),QUWTS(*),SOLUN(*),
+TPPQF(*),TRRAD(*),WPPQF(*)
COMPLEX CENTR,FACTR
COMPLEX ZPPQF(*)
C
C TO COMPUTE THE COMPLEX INNER RADIUS (I.E. THE RECIPROCAL OF THE
C DERIVATIVE OF THE INTERIOR MAP AT THE CENTRE POINT OF THE PHYSICAL
C DOMAIN)
C
C IER=0 - NORMAL EXIT
C IER=37 - LOCAL PARAMETER MXNQD NEEDS INCREASING
C IER=38 - LOCAL PARAMETER MNCOF NEEDS INCREASING
C IER=39 - THE CENTRE POINT IS PATHOLOGICALLY CLOSE TO THE
C BOUNDARY
C IER=40 - LOCAL PARAMETER MQIN1 MUST BE INCREASED
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,I,IA,K,J,J1,J2,JQ,JT,LIM,LOD,LOL,LOM,MNCOF,
+MQIN1,MXNQD,NQ,NQUAD,PT,QINTS
REAL AISUM,ANGLE,ARGBR,ARGIN1,ARSUM,BETA,CURARG,DIST,HL,ISUM,
+JACSUM,LIMIT,MD,MEAN,MINDS,NEWTL,PI,PTHTL,R1MACH,RR,RRB,RSUM,RT1,
+RT2,SCO,SS,STARG,STRT1,STTH1,SUM1,THET1,THET2,TOLOU,TT,TXI,TUPI,WT
COMPLEX CT,DPARFN,PARFUN,XI,DIFF1,DIFF2,
+STDF1,ZXI,ZZ
LOGICAL FIRST
EXTERNAL ARGIN1,DPARFN,JACSUM,PARFUN,PPSBI1,R1MACH
PARAMETER (MNCOF=32,MQIN1=11,MXNQD=80,PTHTL=1E-3)
PARAMETER (LIMIT=2.3562E+0)
REAL JACOF(MNCOF),TSPEC(MXNQD),WSPEC(MXNQD),XENPT(MQIN1)
COMPLEX JCOFC(MNCOF),ZSPEC(MXNQD)
C
NEWTL=SQRT(R1MACH(4))
PI=4E+0*ATAN(1E+0)
TUPI=2E+0*PI
LOL=NARCS*NQPTS
ZZ=CENTR
RSUM=0E+0
ISUM=0E+0
FIRST=.TRUE.
DO 200 IA=1,TNSUA
PT=PARNT(IA)
JT=JATYP(IA)
NQ=NPPQF(IA)
K=LPQSB(IA)-1
HL=HALEN(IA)
MD=MIDPT(IA)
ARSUM=0E+0
AISUM=0E+0
DO 100 JQ=1,NQ
K=K+1
DIFF2=ZZ-ZPPQF(K)
RT2=MD+HL*TPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .GE. TRRAD(K)) THEN
WT=WPPQF(K)
IF (WT .NE. 0E+0) THEN
ARSUM=ARSUM+WT*LOG(DIST)
IF (FIRST) THEN
CURARG=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
THET2=CURARG
FIRST=.FALSE.
STARG=CURARG
ELSE
C CT=DIFF2/DIFF1
C CT=DIFF2*CONJG(DIFF1)
C ANGLE=ATAN2(AIMAG(CT),REAL(CT))
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ENDIF
AISUM=CURARG*WT+AISUM
RT1=RT2
DIFF1=DIFF2
THET1=THET2
ENDIF
ELSE
C
C ZZ IS TOO CLOSE TO ARC IA TO USE THE STANDARD RULE.
C FIND THE QUADRATURE POINT NEAREST TO ZZ.
C
J1=JQ
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
40 CONTINUE
J1=J1+1
IF (J1 .LE. NQ) THEN
K=K+1
DIFF2=ZZ-ZPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .LT. MINDS) THEN
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
GOTO 40
ENDIF
ENDIF
C
C PRELIMINARIES
C
IF (JT .GT. 0) THEN
SS=1E+0
ELSE
SS=-1E+0
ENDIF
AJT=ABS(JT)
BETA=JACIN(AJT)
DEG=DGPOL(IA)
IF (DEG+1 .GT. MNCOF) THEN
IER=38
RETURN
ENDIF
LOM=LOSUB(IA)
LOD=(AJT-1)*NQPTS+1
C
C NOW USE NEWTON'S METHOD TO ESTIMATE THE PARAMETRIC
C PRE-IMAGE XI OF ZZ.
C
XI=CMPLX(TXI)
CT=MD+HL*XI
DIFF2=(ZXI-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
50 CONTINUE
IF (ABS(DIFF2) .GT. NEWTL) THEN
CT=MD+HL*XI
DIFF2=(PARFUN(PT,CT)-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
GOTO 50
ENDIF
XI=SS*XI
C
IF (ABS(AIMAG(XI)) .LT. PTHTL .AND. ABS(REAL(XI)) .LT. 1E+
+ 0+PTHTL) THEN
C
C THE CENTRE OF THE DOMAIN (I.E. ZZ) IS PATHOLOGICALLY
C CLOSE TO ARC IA AND WE DO NOT ALLOW THIS.
C
IER=39
RETURN
ELSE
C
C SET UP A SPECIAL COMPOSITE GAUSSIAN RULE TO HANDLE THIS
C PARTICULAR POINT ZZ.
C
SCO=SS
DO 55 J=1,DEG+1
J1=LOM+J-1
SCO=SCO*SS
JACOF(J)=SOLUN(J1)*SCO
JCOFC(J)=CMPLX(SOLUN(J1)*SCO)
55 CONTINUE
CALL PPSBI1(XI,BETA,NQPTS,DEG,ACOEF(LOD),BCOEF(LOD),
+ H0VAL(AJT),JCOFC,LGTOL,TOLOU,XENPT,QINTS,
+ MQIN1,IER)
IF (IER .GT. 0) THEN
IF (IER .EQ. 29) THEN
IER=40
ENDIF
RETURN
ENDIF
NQUAD=QINTS*NQPTS
IF (NQUAD .GT. MXNQD) THEN
IER=37
RETURN
ENDIF
K=0
SUM1=BETA+1E+0
DO 70 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
DO 60 J=1,NQPTS
J1=LOD+J-1
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WSPEC(K)=RRB*QUWTS(J1)*JACSUM(TT,DEG,ACOEF(LOD),
+ BCOEF(LOD),H0VAL(AJT),JACOF)
TT=TT*SS
TSPEC(K)=MD+TT*HL
CT=CMPLX(TSPEC(K))
ZSPEC(K)=PARFUN(PT,CT)
60 CONTINUE
ELSE
DO 65 J=1,NQPTS
J1=LOL+J
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WSPEC(K)=RR*QUWTS(J1)*(1E+0+TT)**BETA*JACSUM(TT,
+ DEG,ACOEF(LOD),BCOEF(LOD),H0VAL(AJT),
+ JACOF)
TT=TT*SS
TSPEC(K)=MD+TT*HL
CT=CMPLX(TSPEC(K))
ZSPEC(K)=PARFUN(PT,CT)
65 CONTINUE
ENDIF
70 CONTINUE
IF (SS .LT. 0E+0) THEN
LIM=NQUAD
IF (MOD(LIM,2) .EQ. 0) THEN
LIM=LIM/2
ELSE
LIM=(LIM-1)/2
ENDIF
J1=0
J2=NQUAD+1
DO 75 J=1,LIM
J1=J1+1
J2=J2-1
TT=WSPEC(J1)
WSPEC(J1)=WSPEC(J2)
WSPEC(J2)=TT
TT=TSPEC(J1)
TSPEC(J1)=TSPEC(J2)
TSPEC(J2)=TT
CT=ZSPEC(J1)
ZSPEC(J1)=ZSPEC(J2)
ZSPEC(J2)=CT
75 CONTINUE
ENDIF
C
C THIS COMPLETES THE SETTING UP OF THE SPECIAL WEIGHTS
C AND POINTS WSPEC AND ZSPEC. NOW ESTIMATE THE INTEGRAL.
C
ARSUM=0E+0
AISUM=0E+0
IF (IA .EQ. 1) THEN
FIRST=.TRUE.
ELSE
CURARG=STARG
RT1=STRT1
DIFF1=STDF1
THET1=STTH1
ENDIF
DO 80 K=1,NQUAD
WT=WSPEC(K)
DIFF2=ZZ-ZSPEC(K)
RT2=TSPEC(K)
DIST=ABS(DIFF2)
ARSUM=ARSUM+WT*LOG(DIST)
IF (FIRST) THEN
CURARG=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
THET2=CURARG
FIRST=.FALSE.
ELSE
C CT=DIFF2/DIFF1
C CT=DIFF2*CONJG(DIFF1)
C ANGLE=ATAN2(AIMAG(CT),REAL(CT))
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ENDIF
AISUM=CURARG*WT+AISUM
RT1=RT2
DIFF1=DIFF2
THET1=THET2
80 CONTINUE
GOTO 150
ENDIF
ENDIF
C
C END OF QUADRATURE SUM LOOP
C
100 CONTINUE
C
150 CONTINUE
RSUM=RSUM+ARSUM
ISUM=ISUM+AISUM
IF (JT .LT. 0) THEN
C
C BRING THE ARGUMENT FORWARD TO THE CORNER POINT AND REPLACE
C THE INCREMENTED CURARG VALUE BY AN INVERSE TANGENT
C EVALUATION
C
DIFF2=ZZ-PARFUN(PT,(1E+0,0E+0))
RT2=1E+0
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ARGBR=ANINT((CURARG-THET2)/TUPI)
CURARG=THET2+TUPI*ARGBR
RT1=-1E+0
DIFF1=DIFF2
THET1=THET2
ENDIF
STARG=CURARG
STRT1=RT1
STDF1=DIFF1
STTH1=THET1
C
C END OF LOOP FOR CONTRIBUTIONS FROM ARC NUMBER IA
C
200 CONTINUE
CT=CMPLX(RSUM,ISUM)
CT=CEXP(CT)
CINRAD=CT/FACTR
C
IER=0
C
END
SUBROUTINE CNDPLT(MAP11,RESMN,UPHYC,UCANP,CRRES,IGEOM,RGEOM,ISNPH,
+RSNPH,CH0,CH1,DASH,NEWD,IER)
C
INTEGER CH0,CH1,IER
INTEGER IGEOM(*),ISNPH(*)
REAL RESMN,UPHYC,UCANP,CRRES
REAL RGEOM(*),RSNPH(*)
LOGICAL MAP11
CHARACTER DASH*(*),NEWD*(*)
C
C ......................................................................
C
C 1. CNDPLT
C REPORTS ON THE CONDITION OF THE PROBLEM OF EVALUATING THE
C MAPPING FUNCTIONS AND ALSO OUTPUTS DATA FOR GRAPH PLOTTING.
C
C 2. PURPOSE
C THE ROUTINE COMPUTES CONDITION NUMBERS FOR THE PROBLEMS OF
C EVALUATING THE TWO MAPS PHYSICAL --> CANONICAL AND
C CANONICAL --> PHYSICAL AND COMPUTES THE ERROR THAT MAY BE
C EXPECTED (IN THE WORST CASE) IN THE RANGE OF EACH APPROX-
C IMATE MAP FROM A MACHINE PRECISION LEVEL ROUNDING ERROR IN
C THE DOMAIN OF EACH MAP.
C THE ROUTINE ALSO COMPUTES THE LEAST RESOLUTION OF THE
C COMPUTED MAP : PHYSICAL --> CANONICAL OVER ALL SUB-ARCS ON
C THE PHYSICAL BOUNDARY. THE RESOLUTION OF THE MAP FOR ANY
C PHYSICAL SUB-ARC IS DEFINED AS THE COMPUTED ANGULAR WIDTH OF
C THE IMAGE SUB-ARC ON THE UNIT DISC DIVIDED BY THE ESTIMATED
C MAXIMUM ERROR IN THE MODULUS OF THE MAP ON THE GIVEN SUB-
C ARC. A LEAST RESOLUTION OF LESS THAN, SAY, 10 INDICATES
C THAT THERE ARE REGIONS OF SEVERE CROWDING AND THAT IT WILL
C BE PRACTICALLY IMPOSSIBLE TO COMPUTE THE INVERSE MAP
C EVERYWHERE ON THE CANONICAL DOMAIN.
C THE ROUTINE ALSO SEARCHES (NOT VERY EXHAUSTIVELY) FOR
C CHANGES OF SIGN IN THE COMPUTED BOUNDARY CORRESPONDENCE
C DERIVATIVE FOR THE MAP : PHYSICAL --> CANONICAL. SUCH
C SIGN CHANGES MEAN THAT THE COMPUTED MAP IS NOT ONE-TO-ONE
C AND HENCE ONE SHOULD EXPECT DIFFICULTIES IN TRYING TO
C COMPUTE THE INVERSE MAP : CANONICAL --> PHYSICAL.
C FINALLY THREE OUTPUT FILES
C cn, p0, p1
C ARE WRITTEN. THE FIRST OF THESE IS A SUMMARY OF THE ABOVE
C RESULTS INTENDED TO BE READ BY THE USER. THE TWO FILES
C p0 AND p1 ARE NOT INTENDED TO BE READ BY THE
C USER, BUT COULD BE USED TO CREATE PLOTS OF THE BOUNDARY
C CORRESPONDENCE FUNCTION AND ITS DERIVATIVE; SEE FURTHER
C COMMENTS BELOW.
C
C 3. CALLING SEQUENCE
C CALL CNDPLT(MAP11,RESMN,UPHYC,UCANP,CRRES,IGEOM,RGEOM,ISNPH,
C RSNPH,CH0,CH1,DASH,NEWD,IER)
C
C PARAMETERS
C ON ENTRY
C CRRES - REAL
C THE CRITICAL RESOLUTION. IF THE COMPUTED RESOL-
C UTION OF THE PHYSICAL-->CANONICAL MAP ON ANY ARC
C FALLS BELOW CRRES THAN A WARNING MESSAGE IS
C OUTPUT.
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC.
C
C CH0 - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILES cn AND p0.
C
C CH1 - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILE p1; MUST HAVE CH0.NE.CH1.
C
C DASH - CHARACTER
C A CHARACTER VARIABLE OF USER-DEFINED LENGTH WHICH
C DEFINES THE DASH-PATTERN THAT THE USER MAY REQUIRE
C FOR GRAPH PLOTTING; SEE FURTHER COMMENTS BELOW
C
C NEWD - CHARACTER
C A CHARACTER VARIABLE OF USER-DEFINED LENGTH WHICH
C DENOTES THE START OF A NEW DATA GROUP THAT THE
C USER MAY REQUIRE FOR GRAPH PLOTTING; SEE FURTHER
C COMMENTS BELOW
C ON EXIT
C MAP11 - LOGICAL
C IF BOUNDARY REVERSALS ARE DETECTED THEN MAP11 IS
C SET TO .FALSE. (THE COMPUTED PHYSICAL-->CANONICAL
C MAP ISN'T 1-1) OTHERWISE MAP11 IS SET TO .TRUE.
C
C RESMN - REAL
C THE MINIMUM COMPUTED RESOLUTION OF THE PHYSICAL-->
C CANONICAL MAP OVER ALL SUBARCS ON THE PHYSICAL
C BOUNDARY. IF RESMN IS LESS THAN CRRES THEN
C A WARNING MESSAGE IS OUTPUT.
C
C UPHYC - REAL
C ESTIMATED MAXIMUM POSSIBLE ERROR IN THE RANGE OF
C THE PHYSICAL-->CANONICAL MAP DUE UNIT ROUNDOFF IN
C THE PHYSICAL DOMAIN.
C
C UCANP - REAL
C ESTIMATED MAXIMUM POSSIBLE ERROR IN THE RANGE OF
C THE CANONICAL-->PHYSICAL MAP DUE UNIT ROUNDOFF IN
C THE CANONICAL DOMAIN.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL AND THE
C LISTING FILE cn.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINE JAPHYC HAS SUCCESSFULLY EXECUTED, AND THAT MOST
C INPUT ARGUMENTS FOR CNDPLT ARE OUTPUT VALUES FROM JAPHYC.
C - A DETAILED LISTING OF RESULTS IS WRITTEN ON THE FILE
C cn.
C - DATA FOR PLOTTING A GRAPH OF THE DIMENSIONLESS BOUNDARY
C CORRESPONDENCE FUNCTION AGAINST DIMENSIONLESS ARC LENGTH
C ARE WRITTEN ON THE FILE p0. THE CONTENTS OF THIS
C FILE ARE AS FOLLOWS:
C 1. ABOUT 200 COORDINATE PAIRS X Y, ONE PAIR PER LINE,
C WHERE X = DIMENSIONLESS ARC LENGTH (0 <= X <=1) AND
C Y = DIMENSIONLESS BOUNDARY CORRESPONDENCE FUNCTION
C (0 <= Y <=1); THE NUMBER OF COORDINATE PAIRS IS
C CONTROLLED BY THE LOCAL PARAMETER NXINT.
C 2. THE SINGLE LINE
C
C WHERE DENOTES THE VALUE OF THE ARGUMENT DASH;
C THIS CAN BE USED TO INDICATE A CHANGE OF DASH PATTERN
C TO THE LOCAL GRAPH PLOTTER.
C 3. SEVERAL REPETITIONS OF THE FOLLOWING 3-LINE GROUP:
C
C X 0E+0
C X 1E+0
C HERE DENOTES THE VALUE OF THE ARGUMENT NEWD AND
C X (WITH 0 < X < 1) IS THE DIMENSIONLESS ARC
C LENGTH OF A CORNER POINT. THE ABOVE GROUP MAY THEN
C BE USED TO CONSTRUCT A DASHED LINE FROM (X,0) TO
C (X,1). THE NUMBER OF REPETITIONS IS EQUAL TO THE
C NUMBER OF CORNERS WITH ARC LENGTH IN THE INTERVAL
C 0 < X < 1.
C - DATA FOR PLOTTING A GRAPH OF THE DERIVATIVE OF THE DIMEN-
C SIONLESS BOUNDARY CORRESPONDENCE FUNCTION WITH RESPECT TO
C DIMENSIONLESS ARC LENGTH ARE WRITTEN ON THE FILE p1.
C THE CONTENTS OF THIS FILE ARE AS FOLLOWS:
C 1. ABOUT 200 COORDINATE PAIRS X Y, ONE PAIR PER LINE,
C WHERE X = DIMENSIONLESS ARC LENGTH (0 <= X <=1) AND
C Y = DIMENSIONLESS BOUNDARY CORRESPONDENCE DERIVATIVE
C (0 <= Y <=1); THE NUMBER OF COORDINATE PAIRS IS
C CONTROLLED BY THE LOCAL PARAMETER NXINT.
C 2. THE SINGLE LINE
C
C WHERE DENOTES THE VALUE OF THE ARGUMENT DASH;
C THIS CAN BE USED TO INDICATE A CHANGE OF DASH PATTERN
C TO THE LOCAL GRAPH PLOTTER.
C 3. SEVERAL REPETITIONS OF THE FOLLOWING 3-LINE GROUP:
C
C X 0E+0
C X 4.4E+0
C HERE DENOTES THE VALUE OF THE ARGUMENT NEWD AND
C X (WITH 0 < X < 1) IS THE DIMENSIONLESS ARC
C LENGTH OF A RE-ENTRANT CORNER POINT. THE ABOVE GROUP
C MAY THEN BE USED TO CONSTRUCT A DASHED LINE FROM (X,0)
C TO (X,4.4), TO INDICATE THE PRESENCE OF AN ASYMPTOTE.
C SINCE THE AVERAGE VALUE OF THE DIMENSIONLESS BCF DERI-
C VATIVE IS 1, 4.4 IS AN ARBITRARILY CHOSEN BUT RELATI-
C VELY LARGE HEIGHT AT WHICH TO TERMINATE AN ASYMPTOTE;
C THIS HEIGHT IS CONTROLLED BY THE LOCAL PARAMETER BIG.
C THE NUMBER OF REPETITIONS OF THIS GROUP IS EQUAL TO
C THE NUMBER OF RE-ENTRANT CORNERS WITH DIMENSIONLESS
C ARC LENGTH IN THE INTERVAL 0 < X < 1.
C - A SUMMARY LISTING OF RESULTS IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 17 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOEF,AICOF,BCFSN,BCOEF,BICOF,DGPOL,ERARC,H0VAL,HALEN,
+HIVAL,JACIN,JATYP,LOSUB,MIDPT,PARNT,QUPTS,QUWTS,SOLUN,VTARG
INTEGER I,IMNLA,J,L,LODP,LODW,MAXSA,MNEQN,MNSUA,NARCS,NASYM,NCRVS,
+NINFD,NJIND,NPRVS,NQPTS,NXINT,NZERD,TNGQP,TNSUA
REAL ANGSP,BIG,CCAPH,COCAP,COPHC,CPHCA,CR,EXCAP,EXPHC,LA,
+OFLOW,PI,R1MACH,TOTLN,MCHEP
CHARACTER OFLC*6,OFP0*6,OFP1*6,JBNM*4,CHPC*2,CHCP*2
C
PARAMETER(NXINT=200,MAXSA=100,BIG=4.4E+0)
C
C**** NXINT = GLOBAL NUMBER OF INTERVALS ON [0,1] FOR SAMPLING THE
C**** DIMENSIONLESS DERIVATE OF THE BOUNDARY CORRESPONDENCE
C**** FUNCTION.
C**** IER=52 - LOCAL PARAMETER MAXSA MUST BE INCEASED TO AT LEAST THE
C**** VALUE OF ARGUMENT ISNPH(3)=TOTAL NUMBER OF SUBARCS ON
C**** PHYSICAL BOUNDARY.
C
INTEGER ICRVS(MAXSA),IPRVS(MAXSA)
REAL ARCLN(MAXSA),ASYMP(MAXSA),BCDMN(MAXSA),CORXX(MAXSA)
EXTERNAL DIAGN4,R1MACH,WRHEAD,WRTAIL
C
C**** WRITE HEADING TO STANDARD OUTPUT CHANNEL
C
CALL WRHEAD(5,0)
C
C GET JOBNAME FROM FILE *jbnm*
C
OPEN(CH0,FILE='jbnm')
READ(CH0,'(A4)') JBNM
CLOSE(CH0)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
C
OFLC=JBNM(1:L)//'cn'
OFP1=JBNM(1:L)//'p1'
OFP0=JBNM(1:L)//'p0'
C
NARCS=ISNPH(1)
NQPTS=ISNPH(2)
TNSUA=ISNPH(3)
MNSUA=ISNPH(5)
MNEQN=ISNPH(6)
C
NJIND=NARCS+1
TNGQP=NJIND*NQPTS
C
IF (TNSUA .GT. MAXSA) THEN
IER=52
GOTO 999
ENDIF
C
C**** COPY POINTERS FROM JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
ERARC=3*NJIND+6*TNGQP+1
BCFSN=MNSUA+3*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
OPEN(CH0,FILE=OFP0)
OPEN(CH1,FILE=OFP1)
WRITE(*,5) 'EVALUATION OF BCF STARTED:'
5 FORMAT(A45)
LODP=QUPTS+NARCS*NQPTS
LODW=QUWTS+NARCS*NQPTS
CALL DIAGN4(CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,ICRVS,IER,
+IPRVS,NASYM,NCRVS,NINFD,NPRVS,NZERD,ARCLN,ASYMP,BCDMN,CORXX,
+TOTLN,RGEOM(VTARG),MAP11,ISNPH(DGPOL),ISNPH(JATYP),ISNPH(LOSUB),
+NARCS,NQPTS,NXINT,CH0,CH1,IGEOM(PARNT),TNSUA,RSNPH(AICOF),
+RSNPH(ACOEF),RSNPH(BICOF),RSNPH(BCFSN),RSNPH(BCOEF),RSNPH(H0VAL),
+RSNPH(HIVAL),RGEOM(HALEN),RSNPH(JACIN),RGEOM(MIDPT),RSNPH(SOLUN),
+RSNPH(LODP),RSNPH(LODW))
WRITE(*,5) 'EVALUATION OF BCF DONE:'
C
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
IF (NASYM .GT. 0) THEN
WRITE(CH1,*) DASH
DO 10 I=1,NASYM
WRITE(CH1,*) NEWD
WRITE(CH1,20) ASYMP(I),0E+0
WRITE(CH1,20) ASYMP(I),BIG
10 CONTINUE
20 FORMAT(2E16.8)
ENDIF
CLOSE(CH1)
C
WRITE(CH0,*) DASH
DO 30 I=2,NARCS
WRITE(CH0,*) NEWD
WRITE(CH0,20) CORXX(I),0E+0
WRITE(CH0,20) CORXX(I),1E+0
30 CONTINUE
CLOSE(CH0)
WRITE(*,5) 'DATA FOR PLOTS DONE:'
C
OFLOW=R1MACH(2)
MCHEP=R1MACH(4)
UPHYC=MCHEP*CPHCA
UCANP=MCHEP*CCAPH
WRITE(*,*)
WRITE(*,35) 'PHYSICAL ROUNDOFF MAGNIFIES TO:',UPHYC
WRITE(*,35) 'CANONICAL ROUNDOFF MAGNIFIES TO:',UCANP
35 FORMAT(A45,2X,E9.2)
C
OPEN(CH0,FILE=OFLC)
C
C**** WRITE CONFPACK HEADING ON LISTING FILE
C
CALL WRHEAD(5,CH0)
C
WRITE(CH0,*)
WRITE(CH0,40)
40 FORMAT(T4,'MAP',T18,'ESTIMATED EVALUATION',T42,'ESTIMATED MAXIMUM'
+,/,T18,'CONDITION NUMBER',T42,'ROUNDOFF ERROR *',/)
C
IF (NINFD .GT. 0) THEN
CHPC='**'
ELSE
CHPC=' '
ENDIF
IF (NZERD .GT. 0) THEN
CHCP='**'
ELSE
CHCP=' '
ENDIF
C
WRITE(CH0,50) CPHCA,CHPC,UPHYC
WRITE(CH0,60) CCAPH,CHCP,UCANP
50 FORMAT('PHY --> CAN',T20,E11.3,A2,T44,E11.3,/)
60 FORMAT('CAN --> PHY',T20,E11.3,A2,T44,E11.3,/)
WRITE(CH0,*) '* BASED ON UNIT ROUNDOFF IN DOMAIN OF MAP'
IF (NINFD.GT.0 .OR. NZERD.GT.0) THEN
WRITE(CH0,*)'** CONDITION NUMBER DEPENDS ON UNIT ROUNDOFF,U:'
IF (NINFD .GT. 0) THEN
WRITE(CH0,70) COPHC,EXPHC
ENDIF
IF (NZERD .GT. 0) THEN
WRITE(CH0,80) COCAP,EXCAP
ENDIF
ENDIF
70 FORMAT(T4,'PHY --> CAN : CONDTN NO = ',E11.3,'*U**',E11.3)
80 FORMAT(T4,'CAN --> PHY : CONDTN NO = ',E11.3,'*U**',E11.3)
C
PI=4E+0*ATAN(1E+0)
WRITE(CH0,90) 'END PT.','PARENT','ARGUMENT/PI'
90 FORMAT(//,A,T10,A,T18,A)
DO 100 I=1,TNSUA
WRITE(CH0,110) I,IGEOM(PARNT+I-1),RGEOM(VTARG+I-1)/PI
100 CONTINUE
110 FORMAT(I3,T10,I3,T18,E16.8)
C
WRITE(CH0,120) 'SUBARC','% PHYSICAL','% CIRCLE'
120 FORMAT(/,A,T10,A,T29,A)
DO 130 I=1,TNSUA
ANGSP=RGEOM(VTARG+I)-RGEOM(VTARG+I-1)
WRITE(CH0,140) I,ARCLN(I)/TOTLN,ANGSP/2E+0/PI
130 CONTINUE
140 FORMAT(I4,T10,E14.7,T29,E14.7)
C
WRITE(CH0,150) 'SUB','ACHIEVED','CROWDING','ARC','RESOLUTION',
+'FACTOR'
150 FORMAT(/,A,T7,A,T19,A,/,A,T7,A,T19,A)
RESMN=OFLOW
DO 160 I=1,TNSUA
ANGSP=RGEOM(VTARG+I)-RGEOM(VTARG+I-1)
IF (ANGSP.EQ.0E+0) THEN
CR=OFLOW
LA=0E+0
ELSE
CR=2E+0*PI*ARCLN(I)/ABS(ANGSP)/TOTLN
IF (RSNPH(ERARC+I-1).EQ.0E+0) THEN
LA=OFLOW
ELSE
LA=ABS(ANGSP)/(2E+0*RSNPH(ERARC+I-1))
ENDIF
ENDIF
IF (LA .LT. RESMN) THEN
RESMN=LA
IMNLA=I
ENDIF
WRITE(CH0,170) I,LA,CR
160 CONTINUE
170 FORMAT(I2,T4,2E12.3)
C
WRITE(CH0,180) RESMN,IMNLA
180 FORMAT(/,'MINIMUM SUBARC RESOLUTION IS ',E11.3,' ON SUBARC ',I2)
WRITE(*,*)
WRITE(*,35) 'MINIMUM SUBARC RESOLUTION:',RESMN
C
WRITE(CH0,*)
IF (.NOT.MAP11 .OR. RESMN.LT.CRRES) THEN
C
C**** MESSAGE TO STANDARD OUTPUT
C
WRITE(*,185) '*** W A R N I N G ***'
185 FORMAT(//,T20,A)
IF (RESMN.LT.CRRES) THEN
WRITE(*,5) 'THE ABOVE RESOLUTION IS TOO SMALL:'
ENDIF
IF (.NOT.MAP11) THEN
WRITE(*,5) 'BCF DERIVATIVE CHANGES SIGN:'
ENDIF
C
WRITE(CH0,*) ' *** W A R N I N G ***'
WRITE(CH0,*)
I=0
C
IF (RESMN.LT.1) THEN
I=I+1
WRITE(CH0,190) I,'. THE ABOVE SUBARC RESOLUTION MEANS THAT IT
+ WILL BE PRACTICALLY'
WRITE(CH0,*) ' IMPOSSIBLE FOR THE INVERSE MAP TO DISCRIMINA
+TE CORRECTLY'
WRITE(CH0,200) ' BETWEEN NEIGHBOURING POINTS NEAR SUB ARC '
+,IMNLA
ELSE IF (RESMN.LT.CRRES) THEN
I=I+1
WRITE(CH0,190) I,'. THE ABOVE SUBARC RESOLUTION MEANS THAT THE
+ INVERSE MAP MAY NOT'
WRITE(CH0,*) ' BE ABLE TO RELIABLY DISCRIMINATE CORRECTLY B
+ETWEEN'
WRITE(CH0,200) ' NEIGHBOURING POINTS NEAR ARC ',IMNLA
ENDIF
190 FORMAT(/,I1,A)
200 FORMAT(A,I3)
C
IF (NCRVS .GT. 0) THEN
I=I+1
WRITE(CH0,190) I,'. THERE IS A COMPLETE REVERSAL OF DIRECTION
+ ON THE FOLLOWING SUB ARCS:'
WRITE(CH0,'(T10,I3)') (ICRVS(J),J=1,NCRVS)
ENDIF
C
IF (NPRVS .GT. 0) THEN
I=I+1
WRITE(CH0,190) I,'. THERE IS A REVERSAL OF DIRECTION WITHIN T
+HE FOLLOWING SUB ARCS:'
WRITE(CH0,'(T10,I3)') (IPRVS(J),J=1,NPRVS)
WRITE(CH0,*) ' THE CORRESPONDING MINIMUM VALUES OF THE BOUN
+DARY CORRESPONDENCE'
WRITE(CH0,*) ' DERIVATIVE ARE:'
WRITE(CH0,'(T10,E9.2)') (BCDMN(J),J=1,NPRVS)
ENDIF
ENDIF
CLOSE(CH0)
999 CONTINUE
C
C**** WRITE CLOSING MESSAGE TO STANDARD OUTPUT CHANNEL AND LISTING FILE
C
CALL WRTAIL(5,0,IER)
CALL WRTAIL(5,CH0,IER)
C
END
SUBROUTINE CPJAC3(NARCS,NQPTS,INDEG,DGPOL,JACIN,ACOEF,BCOEF,DIAG,
+SDIAG,TNSUA,LOSUB,HISUB,JATYP,PARNT,MIDPT,HALEN,COLPR,ZCOLL,LNSEG,
+LOOLD,HIOLD,EPS,IER,INIBT)
INTEGER NARCS,NQPTS,INDEG,TNSUA,IER
INTEGER DGPOL(*),LOSUB(*),HISUB(*),JATYP(*),PARNT(*)
REAL EPS,JACIN(*),ACOEF(*),BCOEF(*),DIAG(*),SDIAG(*),
+MIDPT(*),HALEN(*),COLPR(*),LOOLD(*),HIOLD(*)
COMPLEX ZCOLL(*)
LOGICAL LNSEG(*),INIBT
C
C**** TO MAKE THE INITIAL ASSIGNMENT OF THE COLLOCATION PARAMETERS
C**** (STORED IN COLPR), THE COLLOCATION POINTS ON THE PHYSICAL
C**** BOUNDARY (STORED IN ZCOLL) AND THE ARRAYS LOSUB AND HISUB
C**** NEEDED TO ACCESS THIS DATA CORRECTLY. ALSO TO SET UP THE
C**** ARRAYS
C**** JATYP - THE JACOBI INDEX TYPE OF EACH SUBARC
C**** PARNT - THE ORIGINAL PARENT ARC OF EACH SUBARC
C**** MIDPT - THE GLOBAL PARAMETRIC MIDPOINT OF EACH SUBARC
C**** HALEN - THE GLOBAL PARAMETRIC HALF-LENGTH OF EACH SUBARC
C**** DGPOL - THE INITIAL POLYNOMIAL DEGREE ON EACH SUBARC
C**** LNSEG - THE INITIAL LINE SEGMENT TYPE OF EACH SUBARC.
C
C**** IER=0 - NORMAL EXIT
C**** IER=7 - FAILURE TO CONVERGE IN EIGENVALUE ROUTINE IMTQLH
C
C LOCAL VARIABLES
C
INTEGER D,D1,FIRST,I,J,K,K1,K2,P,PREV,IFAIL
REAL S,TC,ALFA,BETA,MED,MDNBT
COMPLEX PARFUN
EXTERNAL PARFUN,IMTQLH,MDNBT
C
TNSUA=2*NARCS
DO 10 I=1,NARCS
BETA=JACIN(I)
IF (I .EQ. NARCS) THEN
ALFA=JACIN(1)
ELSE
ALFA=JACIN(I+1)
ENDIF
IF (INIBT) THEN
MED=MDNBT(ALFA,BETA)
ELSE
MED=0E+0
ENDIF
J=2*I-1
MIDPT(J)=5E-1*(MED-1E+0)
HALEN(J)=5E-1*(MED+1E+0)
PARNT(J)=I
JATYP(J)=I
J=J+1
MIDPT(J)=5E-1*(MED+1E+0)
HALEN(J)=5E-1*(1E+0-MED)
PARNT(J)=I
IF (I .EQ. NARCS) THEN
JATYP(J)=-1
ELSE
JATYP(J)=-I-1
ENDIF
10 CONTINUE
C
DO 11 I=NARCS,1,-1
J=2*I
LNSEG(J)=LNSEG(I)
LNSEG(J-1)=LNSEG(I)
11 CONTINUE
C
DO 12 I=1,TNSUA
DGPOL(I)=INDEG
12 CONTINUE
C
LOSUB(1)=1
HISUB(1)=1+DGPOL(1)
DO 20 I=2,TNSUA
LOSUB(I)=HISUB(I-1)+1
HISUB(I)=LOSUB(I)+DGPOL(I)
20 CONTINUE
C
DO 25 I=1,TNSUA
LOOLD(I)=0
HIOLD(I)=-1
25 CONTINUE
C
DO 50 I=1,TNSUA
J=JATYP(I)
P=PARNT(I)
D=DGPOL(I)
D1=D+1
IF (J .GT. 0) THEN
S=1E+0
ELSE
S=-1E+0
J=-J
ENDIF
PREV=(J-1)*NQPTS
FIRST=LOSUB(I)
DO 30 K=1,D1
K1=PREV+K
DIAG(K)=BCOEF(K1)
IF (K .EQ. 1) THEN
SDIAG(K)=0E+0
ELSE
SDIAG(K)=ACOEF(K1-1)
ENDIF
30 CONTINUE
CALL IMTQLH(D1,DIAG,SDIAG,IFAIL)
IF (IFAIL .GT. 0) THEN
IER=7
RETURN
ENDIF
DO 40 K=1,D1
TC=S*DIAG(K)
K2=FIRST+K-1
COLPR(K2)=TC
TC=MIDPT(I)+HALEN(I)*TC
ZCOLL(K2)=PARFUN(P,CMPLX(TC))
40 CONTINUE
50 CONTINUE
C
C NORMAL EXIT
C
IER=0
C
END
COMPLEX FUNCTION CJACSU(X,N,A,B,H,CO)
INTEGER N
REAL A(*),B(*),H,CO(*)
COMPLEX X
C ..TO CALCULATE SUMMATION{CO(K+1)*P(K,X)},K=0(1)N, WHERE P(K,X)
C ..DENOTES THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE K
C ..EVALUATED AT X, ARRAY CO STORES A GIVEN SET OF COEFFICIENTS,
C ..ARRAYS A,B STORE THE COEFFICIENTS IN THE THREE-TERM
C ..RECURRENCE FORMULA FOR THE JACOBI POLYNOMIALS (SEE ASONJ7)
C ..AND H IS THE SQUARED 2-NORM OF UNITY.
COMPLEX PREV,CURR,NEXT
INTEGER K
C
IF (N .EQ. 0) THEN
CJACSU=CO(1)/SQRT(H)
ELSE IF (N .GT. 0) THEN
PREV=CO(N+1)
CURR=CO(N)+(X-B(N))*PREV/A(N)
DO 10 K=N-2,0,-1
NEXT=CO(K+1)+(X-B(K+1))*CURR/A(K+1)-A(K+1)*PREV/A(K+2)
PREV=CURR
CURR=NEXT
10 CONTINUE
CJACSU=CURR/SQRT(H)
ELSE
CJACSU=(0E+0,0E+0)
ENDIF
C
END
INTEGER FUNCTION CRITCO(N,POSCO)
INTEGER N
REAL POSCO(*)
C
C GIVEN THE NON-NEGATIVE NUMBERS POSCO(I), I=1,...,N, TO FIND THE
C INDEX CRITCO SUCH THAT POSCO(CRITCO) > 1 AND POSCO(I) <=1 FOR
C I=CRITCO+1,...,N. IN CASE POSCO(I) <=1 FOR ALL I=1,...,N THEN
C POSCO=0.
C
C**** LOCAL VARIABLE
C
INTEGER I
C
I=N
10 CONTINUE
IF (I.EQ.0) THEN
CRITCO=0
ELSE IF (POSCO(I) .GT. 1E+0) THEN
CRITCO=I
ELSE
I=I-1
GOTO 10
ENDIF
C
END
SUBROUTINE CSCAL3(COLSC,NQPTS,NJIND,ACOEF,BCOEF,H0VAL,QUPTS,QUWTS,
+JACIN,MU,TT,QQ)
INTEGER NQPTS,NJIND
REAL COLSC(*),ACOEF(*),BCOEF(*),H0VAL(*),QUPTS(*),QUWTS(*),
+JACIN(*),MU(*),TT(*),QQ(*)
C
C TO SET UP THE A PRIORI COLUMN SCALE FACTORS USING TRUNCATED
C CHEBYSHEV EXAPANSIONS FOR THE LOGARITHMIC KERNEL, GAUSS-JACOBI
C QUADRATURE AND GAUSS-JACOBI TEST POINTS.
C
C LOCAL VARIABLES
C
INTEGER I,J,J1,JI,K,K1,KMAX,LO,LO1,M
REAL BETA,ROOTH,P0SCL,X,MAXVL,SUM1,SUM2
EXTERNAL JAPAR7
C
K1=0
MU(1)=-LOG(2E+0)
DO 10 I=2,2*NQPTS
MU(I)=-2E+0/REAL(I-1)
10 CONTINUE
C
DO 80 JI=1,NJIND
BETA=JACIN(JI)
ROOTH=SQRT(H0VAL(JI))
P0SCL=1E+0/ROOTH
LO=(JI-1)*NQPTS
LO1=LO+1
C
DO 30 J=1,NQPTS
X=QUPTS(LO+J)
QQ(1+(J-1)*NQPTS)=P0SCL
CALL JAPAR7(QQ(1+(J-1)*NQPTS),X,ACOEF(LO1),BCOEF(LO1),
+ NQPTS-1)
TT(J)=1E+0
TT(J+NQPTS)=X
DO 20 K=3,2*NQPTS
TT(J+(K-1)*NQPTS)=2E+0*X*TT(J+(K-2)*NQPTS)-
+ TT(J+(K-3)*NQPTS)
20 CONTINUE
30 CONTINUE
C
DO 70 K=1,NQPTS
MAXVL=0E+0
DO 60 I=1,NQPTS
SUM2=0E+0
KMAX=2*NQPTS+1-K
DO 50 M=K,KMAX
SUM1=0E+0
DO 40 J=1,NQPTS
J1=LO+J
SUM1=SUM1+QUWTS(J1)*QQ(K+(J-1)*NQPTS)*
+ TT(J+(M-1)*NQPTS)
40 CONTINUE
SUM2=SUM2+MU(M)*TT(I+(M-1)*NQPTS)*SUM1
50 CONTINUE
MAXVL=MAX(MAXVL,ABS(SUM2))
60 CONTINUE
K1=K1+1
COLSC(K1)=1E+0/MAXVL
70 CONTINUE
C
80 CONTINUE
C
END
SUBROUTINE DEJAC7(ZZ,NZZ,BETA,TAU,MAXDG,NQUAD,ACOEF,BCOEF,H0VAL,
+REMND,CSCAL,TOL,MAXRM,IER)
INTEGER MAXDG,NQUAD,NZZ,IER
REAL BETA,TAU,H0VAL,TOL,MAXRM
REAL ACOEF(*),BCOEF(*),CSCAL(*)
COMPLEX ZZ(*),REMND(*)
C
C WE COMPUTE THE DONALDSON-ELLIOTT ESTIMATES FOR THE REMAINDERS IN
C USING AN NQUAD-POINT GAUSS-JACOBI RULE TO ESTIMATE THE INTEGRALS
C
C INTEGRAL [(1+X)**BETA*P(X,I)*LOG(ZZ(J)-X)*dX], I=0,MAXDG
C -1<=X<=TAU J=1,NZZ
C
C WHERE P(.,I) IS THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE I
C ASSOCIATED WITH THE WEIGHT (1+X)**BETA. THE REMAINDER
C CORRESPONDING TO P(.,I) AND ZZ(J) IS STORED IN
C REMND(I+J+MAXDG*(J-1)), I=0,MAXDG, J=1,NZZ. THIS ROUTINE USES
C THE SIMPLEST POSSIBLE ESTIMATES; I.E. THE LEADING TERM ONLY IN
C THE ASYMPTOTIC EXPANSION AND THE WATSON-DOETSCH ESTIMATE FOR ANY
C INTEGRALS.
C
C THE PURPOSE OF THIS ROUTINE IS THEN TO DETERMINE A VALUE FOR TAU
C SUCH THAT
C
C ABS( REAL(REMND(I)) )*CSCAL(I) < TOL , I=1,NZZ*(MAXDG+1)
C
C AND THAT, IF POSSIBLE,
C
C 0.5*TOL <= ABS( REAL(REMND(I)) )*CSCAL(I) < TOL
C
C FOR AT LEAST ONE VALUE OF I.
C
C IER=0 - NORMAL EXIT
C IER=12- LOCAL PARAMETER NC NEEDS INCREASING TO AT LEAST NZZ
C (THIS ERROR CAN'T ARISE IN THE PRESENT VERSION, SINCE
C NZZ IS FIXED AT 2)
C IER=13- LOCAL PARAMETER NR NEEDS INCREASING TO AT LEAST MAXDG
C (AT PRESENT MAXDG=NQPTS-1)
C IER=14- A JACOBI INDEX MAY BE LARGE ENOUGH TO CAUSE OVERFLOW IN
C THE GAMMA FUNCTION (AN ANGLE ON THE PHYSICAL BOUNDARY
C MUST BE LESS THAN ABOUT 6 DEGREES)
C
C LOCAL VARIABLES..
C
INTEGER I,J,K,LIM,NC,NR
REAL S,KK,GAMMA,LGGAM,SUM1,RI,TURI,RN,OFLOW,P0SCL,TUK,LOWER,
+UPPER,R1MACH,TERM,HTOL
COMPLEX XI,Z1,XI1,FF,PRE,CUR,NXT
PARAMETER (NC=8,NR=30)
COMPLEX GG(NC),CONST(NR,NC)
EXTERNAL GAMMA,LGGAM,R1MACH
C
IF (NZZ .GT. NC ) THEN
IER=12
RETURN
ENDIF
C
IF (MAXDG .GE. NR) THEN
IER=13
RETURN
ENDIF
C
S=BETA+4E+0
IF (S .GT. 2E+1) THEN
C
C TEST FOR POSSIBLE OVERFLOW IN GAMMA FUNCTION
C
OFLOW=LOG(R1MACH(2))
KK=LGGAM(S)
IF (KK.GT.OFLOW) THEN
IER=14
RETURN
ELSE
KK=EXP(-KK)
ENDIF
ELSE
KK=1E+0/GAMMA(S)
ENDIF
C
C FIRST WE COMPUTE THE FACTORS WHICH ARE INDEPENDENT OF TAU
C
S=S-1E+0
KK=4E+0**S*KK*GAMMA(BETA+2E+0)/(S-1E+0)
SUM1=BETA+1E+0
DO 100 I=2,NQUAD
RI=REAL(I)
TURI=2E+0*RI
KK=KK*16E+0*(RI+BETA)/(TURI+SUM1)
KK=KK*RI/(TURI+BETA)
KK=KK*(RI+BETA)/(TURI+BETA)
KK=KK*RI/(TURI+BETA-1E+0)
100 CONTINUE
RN=REAL(NQUAD)
TUK=2E+0*RN+SUM1
KK=-KK/TUK/2E+0
C
DO 125 I=1,NZZ
GG(I)=(1E+0+ZZ(I))**BETA*KK
125 CONTINUE
C
C NOW GIVE THE JACOBI POLYNOMIALS THE SCALING CORRESPONDING TO
C [-1,1] AS STANDARD INTERVAL
C
P0SCL=1E+0/SQRT(H0VAL)
DO 225 J=1,NZZ
PRE=CMPLX(P0SCL)
CUR=PRE
CONST(1,J)=CUR*GG(J)*CSCAL(1)
IF (MAXDG .GE. 1) THEN
CUR=(ZZ(J)-BCOEF(1))*PRE/ACOEF(1)
CONST(2,J)=CUR*GG(J)*CSCAL(2)
DO 200 I=2,MAXDG
NXT=((ZZ(J)-BCOEF(I))*CUR-ACOEF(I-1)*PRE)/ACOEF(I)
PRE=CUR
CUR=NXT
CONST(I+1,J)=CUR*GG(J)*CSCAL(I+1)
200 CONTINUE
ENDIF
225 CONTINUE
C
C NOW COME THE FACTORS DEPENDENT ON TAU
C
TAU=1E+0
LOWER=-1E+0
UPPER=1E+0
LIM=NZZ*(MAXDG+1)
C
250 CONTINUE
C
HTOL=5E-1*TOL
K=0
DO 325 J=1,NZZ
XI=(2E+0*ZZ(J)+1E+0-TAU)/(1E+0+TAU)
Z1=SQRT(XI*XI-1E+0)
XI1=XI+Z1
IF (ABS(XI1) .LT. 1E+0) THEN
XI1=XI-Z1
ENDIF
FF=XI1**(-TUK-1E+0)*(XI1*XI1-1E+0)*(1E+0+TAU)*5E-1
DO 300 I=0,MAXDG
K=K+1
REMND(K)=CONST(I+1,J)*FF
300 CONTINUE
325 CONTINUE
C
MAXRM=0E+0
DO 600 I=1,LIM
TERM=ABS(REAL(REMND(I)))
MAXRM=MAX(MAXRM,TERM)
600 CONTINUE
C
IF (MAXRM .LT. TOL) THEN
C
C ACCURACY IS ACHIEVED, BUT MAYBE TAU COULD BE INCREASED.
C
IF (MAXRM .LT. HTOL) THEN
C
C TAU NEEDS INCREASING, BUT THIS IS ONLY POSSIBLE IF TAU<1.
C
IF (TAU .LT. 1E+0) THEN
LOWER=TAU
TAU=5E-1*(LOWER+UPPER)
GOTO 250
ENDIF
ENDIF
ELSE
C
C ACCURACY NOT ACHIEVED AND TAU NEEDS DECREASING.
C
IF (TAU .EQ. 1E+0) THEN
TOL=HTOL
ENDIF
UPPER=TAU
TAU=5E-1*(LOWER+UPPER)
GOTO 250
ENDIF
C
C NORMAL TERMINATION
C
IER=0
C
END
SUBROUTINE DELEG7(ZZ,NZZ,BETA,TAU1,TAU2,T1FXD,MAXDG,NQUAD,ACOEF,
+BCOEF,H0VAL,REMND,CSCAL,TOL,MAXRM,IER)
INTEGER MAXDG,NQUAD,IER,NZZ
REAL BETA,TAU1,TAU2,H0VAL,TOL,MAXRM
REAL ACOEF(*),BCOEF(*),CSCAL(*)
LOGICAL T1FXD
COMPLEX ZZ(*),REMND(*)
C
C WE COMPUTE THE DONALDSON-ELLIOTT ESTIMATES FOR THE REMAINDERS IN
C USING AN NQUAD-POINT GAUSS-LEGENDRE RULE TO ESTIMATE THE INTEGRALS
C
C INTEGRAL [(1+X)**BETA*P(X,I)*LOG(ZZ(J)-X)*dX], I=0,1,...,MAXDG
C TAU1<=X<=TAU2 J=1,2
C
C WHERE P(.,I) IS THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE I
C ASSOCIATED WITH THE WEIGHT (1+X)**BETA AND -1-1)
C
IF (T1FXD .AND. TAU2 .LT. 1E+0) THEN
LOWER=TAU2
TAU2=5E-1*(LOWER+UPPER)
GOTO 250
ELSE IF (.NOT.T1FXD .AND. TAU1 .GT. -1E+0) THEN
UPPER=TAU1
TAU1=5E-1*(LOWER+UPPER)
GOTO 250
ENDIF
ENDIF
ELSE
C
C ACCURACY NOT ACHIEVED AND TAU2 NEEDS DECREASING OR TAU1 NEEDS
C INCREASING.
C
IF (FIRST) THEN
TOL=HTOL
FIRST=.FALSE.
ENDIF
IF (T1FXD) THEN
UPPER=TAU2
TAU2=5E-1*(LOWER+UPPER)
ELSE
LOWER=TAU1
TAU1=5E-1*(LOWER+UPPER)
ENDIF
GOTO 250
ENDIF
C
C NORMAL TERMINATION
C
IER=0
C
END
SUBROUTINE DEPPJ8(BETA,TAU,NQUAD,DGPOL,ACOEF,BCOEF,H0VAL,
+SOLUN,TOL,MAXRM,NINTS,DELTA,IER)
INTEGER NQUAD,IER,DGPOL,NINTS
REAL BETA,TAU,TOL,MAXRM,ACOEF(*),BCOEF(*),H0VAL,DELTA
COMPLEX SOLUN(*)
C
C WE COMPUTE THE DONALDSON-ELLIOTT ESTIMATES FOR THE REMAINDERS IN
C USING AN NQUAD-POINT GAUSS-JACOBI RULE TO ESTIMATE THE INTEGRALS
C
C INTEGRAL [(1+X)**BETA*FNPHI(X)*LOG(ZZ-X)*dX]
C -1<=X<=TAU
C
C WHERE FNPHI IS A POLYNOMIAL APPROXIMATION TO THE BOUNDARY
C CORRESPONDENCE DERIVATIVE / JACOBI WEIGHT QUOTIENT.
C
C ZZ IS ANY POINT ON A "DELTA-CONTOUR" IN THE UPPER HALF PLANE,
C THIS CONTOUR BEING DEFINED BY THE PARAMETE DELTA. TEST VALUES
C FOR ZZ ARE ASSIGNED IN THE BODY OF THE ROUTINE AND THE LOCAL ARRAY
C XIVAL IS USED FOR STORING THESE TEST VALUES.
C
C THE PARAMETERS DGPOL,ACOEF,BCOEF,H0VAL AND SOLUN ARE USED TO
C DEFINE FNPHI AND ARE PASSED TO DEPPJ9 FOR THIS PURPOSE.
C
C MAXRM RECORDS THE MAXIMUM OF THE ABSOLUTE VALUES OF THE REMAINDER
C ESTIMATES ASSOCIATED WITH THE DELTA-CONTOUR.
C
C ON ENTRY NINTS IS THE NUMBER OF INITIAL TEST INTERVALS TO BE USED
C ON THE UPPER HALF DELTA-CONTOUR; ON EXIT NINTS GIVES THE FINAL
C NUMBEROF INTERVALS REQUIRED FOR CONVERGENCE TO TAU.
C
C THE PURPOSE OF THIS ROUTINE IS TO DETERMINE A VALUE FOR TAU
C SUCH THAT
C
C MAXRM < TOL
C
C AND THAT, IF POSSIBLE,
C
C 0.5*TOL <= MAXRM < TOL.
C
C IER=0 - NORMAL EXIT
C IER=25- THE LOCAL ARRAY BOUND PARAMETER MNXI NEEDS INCREASING.
C
C
C LOCAL VARIABLES
C
INTEGER NXI,MNXI
REAL SS,PI,SS1,SS2,SS3,DP,LEN,TAUI,SINC,STAR,RXI,DT,HDP
COMPLEX XI
PARAMETER (MNXI=100)
COMPLEX XIVAL(MNXI)
EXTERNAL DEPPJ9
C
C INITIALISATION
C
PI=4E+0*ATAN(1E+0)
TAUI=1E+0
DP=DELTA*PI
DT=DELTA*2E+0
HDP=5E-1*DP
LEN=2E+0+DP
SINC=LEN/NINTS
STAR=SINC
C
C START OF LOOP FOR INTERVAL HALVING
C
10 CONTINUE
NXI=0
SS1=-STAR+SINC
SS2=LEN
DO 30 SS=SS1,SS2,SINC
IF (SS .LT. HDP) THEN
SS3=SS/DELTA
XI=1E+0+DELTA*CMPLX(COS(SS3),SIN(SS3))
ELSE IF (SS .GT. 2E+0+HDP) THEN
SS3=(SS-2E+0-HDP)/DELTA
XI=-1E+0+DELTA*(0E+0,1E+0)*CMPLX(COS(SS3),SIN(SS3))
ELSE
SS3=SS-HDP
XI=CMPLX(1E+0-SS3,DELTA)
ENDIF
RXI=REAL(XI)
IF (RXI .LT. (TAUI+DT)) THEN
NXI=NXI+1
IF (NXI .GT. MNXI) THEN
IER=25
RETURN
ENDIF
XIVAL(NXI)=XI
ENDIF
30 CONTINUE
C
IF (NXI .EQ. 0) THEN
SINC=STAR
STAR=5E-1*STAR
NINTS=NINTS*2
GOTO 10
ENDIF
C
TAU=TAUI
CALL DEPPJ9(XIVAL,NXI,BETA,TAU,NQUAD,DGPOL,ACOEF,BCOEF,H0VAL,
+ SOLUN(1),TOL,MAXRM,IER)
IF (IER .GT. 0) THEN
RETURN
ENDIF
C
IF (TAU .NE. TAUI) THEN
TAUI=TAU
SINC=STAR
STAR=5E-1*STAR
NINTS=NINTS*2
GOTO 10
ENDIF
C
IER=0
C
END
SUBROUTINE DEPPJ9(ZZ,NZZ,BETA,TAU,NQUAD,DGPOL,ACOEF,BCOEF,H0VAL,
+SOLUN,TOL,MAXRM,IER)
INTEGER NQUAD,NZZ,IER,DGPOL
REAL BETA,TAU,TOL,MAXRM,ACOEF(*),BCOEF(*),H0VAL
COMPLEX SOLUN(*),ZZ(*)
C
C WE COMPUTE THE DONALDSON-ELLIOTT ESTIMATES FOR THE REMAINDERS IN
C USING AN NQUAD-POINT GAUSS-JACOBI RULE TO ESTIMATE THE INTEGRALS
C
C INTEGRAL [(1+X)**BETA*FNPHI(X)*LOG(ZZ(I)-X)*dX], I=1,NZZ
C -1<=X<=TAU
C
C WHERE FNPHI IS A POLYNOMIAL APPROXIMATION TO THE BOUNDARY
C CORRESPONDENCE DERIVATIVE - JACOBI WEIGHT QUOTIENT AND ZZ IS
C A GIVEN ARRAY OF POINTS.
C
C THE PARAMETERS DGPOL,ACOEF,BCOEF,H0VAL AND SOLUN ARE USED TO
C DEFINE FNPHI.
C
C THE MAXIMUM ABSOLUTE VALUE OF ALL THE REMAINDERS CORRESPONDING TO
C ZZ(I) , I=1,NZZ, IS STORED IN MAXRM.
C
C THIS ROUTINE USES THE SIMPLEST POSSIBLE ESTIMATES; I.E. THE
C LEADING TERM ONLY IN THE ASYMPTOTIC EXPANSION AND THE WATSON-
C DOETSCH ESTIMATE FOR ANY INTEGRALS.
C
C THE PURPOSE OF THIS ROUTINE IS THEN TO DETERMINE A VALUE FOR TAU
C SUCH THAT
C
C MAXRM < TOL
C
C AND THAT, IF POSSIBLE,
C
C 0.5*TOL <= MAXRM < TOL.
C
C IER=0 - NORMAL EXIT
C IER=26- TOO MANY TEST POINTS ON DELTA CONTOUR; INCREASE
C PARAMETER MAXNZ BELOW
C IER=14- BETA MAY CAUSE OVERFLOW IN GAMMA FUNCTION; AN ANGLE
C ON THE BOUNDARY IS TOO SMALL
C
C LOCAL VARIABLES
C
INTEGER I,MAXNZ
REAL S,KK,GAMMA,SUM1,RI,TURI,RN,TUK,LOWER,UPPER,TERM,HTOL,TAUI,
+OFLOW,LGGAM,R1MACH
COMPLEX XI,Z1,XI1,FF,FNPHI,CCJACS,REMND
PARAMETER (MAXNZ=200)
COMPLEX GG(MAXNZ)
EXTERNAL GAMMA,CCJACS,LGGAM,R1MACH
C
IF (NZZ .GT. MAXNZ ) THEN
C
C SOME LOCAL ARRAY BOUNDS MUST BE INCREASED
C
IER=26
RETURN
ENDIF
C
S=BETA+4E+0
IF (S .GT. 2E+1) THEN
C
C TEST FOR POSSIBLE OVERFLOW IN GAMMA FUNCTION
C
OFLOW=LOG(R1MACH(2))
KK=LGGAM(S)
IF (KK.GT.OFLOW) THEN
IER=14
RETURN
ELSE
KK=EXP(-KK)
ENDIF
ELSE
KK=1E+0/GAMMA(S)
ENDIF
C
C FIRST WE COMPUTE THE FACTORS WHICH ARE INDEPENDENT OF TAU
C
S=S-1E+0
KK=4E+0**S*KK*GAMMA(BETA+2E+0)/(S-1E+0)
SUM1=BETA+1E+0
DO 100 I=2,NQUAD
RI=REAL(I)
TURI=2E+0*RI
KK=KK*16E+0*(RI+BETA)/(TURI+SUM1)
KK=KK*RI/(TURI+BETA)
KK=KK*(RI+BETA)/(TURI+BETA)
KK=KK*RI/(TURI+BETA-1E+0)
100 CONTINUE
RN=REAL(NQUAD)
TUK=2E+0*RN+SUM1
KK=-KK/TUK/2E+0
C
DO 125 I=1,NZZ
FNPHI=CCJACS(ZZ(I),DGPOL,ACOEF,BCOEF,H0VAL,SOLUN)
GG(I)=(1E+0+ZZ(I))**BETA*KK*FNPHI
125 CONTINUE
C
C NOW COME THE FACTORS DEPENDENT ON TAU
C
LOWER=-1E+0
UPPER=TAU
TAUI=TAU
C
250 CONTINUE
C
MAXRM=0E+0
HTOL=5E-1*TOL
DO 325 I=1,NZZ
XI=(2E+0*ZZ(I)+1E+0-TAU)/(1E+0+TAU)
Z1=SQRT(XI*XI-1E+0)
XI1=XI+Z1
IF (ABS(XI1) .LT. 1E+0) THEN
XI1=XI-Z1
ENDIF
FF=XI1**(-TUK-1E+0)*(XI1*XI1-1E+0)*(1E+0+TAU)*5E-1
REMND=GG(I)*FF
TERM=ABS(REMND)
MAXRM=MAX(MAXRM,TERM)
325 CONTINUE
C
IF (MAXRM .LT. TOL) THEN
C
C ACCURACY IS ACHIEVED, BUT MAYBE TAU COULD BE INCREASED.
C
IF (MAXRM .LT. HTOL) THEN
C
C TAU NEEDS INCREASING, BUT THIS IS ONLY POSSIBLE IF TAUTAU1I)
C
IF (T1FXD .AND. TAU2 .LT. TAU2I) THEN
LOWER=TAU2
TAU2=5E-1*(LOWER+UPPER)
GOTO 250
ELSE IF (.NOT.T1FXD .AND. TAU1 .GT. TAU1I) THEN
UPPER=TAU1
TAU1=5E-1*(LOWER+UPPER)
GOTO 250
ENDIF
ENDIF
ELSE
C
C ACCURACY NOT ACHIEVED AND TAU2 NEEDS DECREASING OR TAU1 NEEDS
C INCREASING.
C
IF (FIRST) THEN
TOL=HTOL
FIRST=.FALSE.
ENDIF
IF (T1FXD) THEN
UPPER=TAU2
TAU2=5E-1*(LOWER+UPPER)
ELSE
LOWER=TAU1
TAU1=5E-1*(LOWER+UPPER)
ENDIF
GOTO 250
ENDIF
C
C NORMAL EXIT
C
IER=0
C
END
SUBROUTINE DIAGN4(CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,ICRVS,IER,
+IPRVS,NASYM,NCRVS,NINFD,NPRVS,NZERD,ARCLN,ASYMP,BCDMN,CORXX,
+TOTLN,VTARG,MAP11,DGPOL,JATYP,LOSUB,NARCS,NQPTS,NXINT,OUCH0,OUCH1,
+PARNT,TNSUA,A1COF,ACOEF,B1COF,BCFSN,BCOEF,H0VAL,H1VAL,HALEN,JACIN,
+MIDPT,SOLUN,QUPTS,QUWTS)
INTEGER IER,NARCS,NASYM,NCRVS,NINFD,NPRVS,NQPTS,NXINT,NZERD,OUCH0,
+OUCH1,TNSUA
INTEGER DGPOL(*),ICRVS(*),IPRVS(*),JATYP(*),LOSUB(*),PARNT(*)
REAL CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,TOTLN
REAL A1COF(*),ACOEF(*),ARCLN(*),ASYMP(*),B1COF(*),
+BCDMN(*),BCFSN(*),BCOEF(*),CORXX(*),JACIN(*),MIDPT(*),H0VAL(*),
+H1VAL(*),HALEN(*),SOLUN(*),VTARG(*),QUPTS(*),QUWTS(*)
LOGICAL MAP11
C
C IER=0 - NORMAL EXIT
C IER=50 - LOCAL PARAMETER MXCOF MUST BE >= NQPTS.
C IER=51 - NON-ANALYTIC ARC DETECTED
C
C**** LOCAL VARIABLES
C
INTEGER AJT,DG,I,I1,IA,JT,K,LOD,LOM,MININ,MXCOF,NINTS,PT,QP
REAL AL,ATOL,BT,CC,COF,D,DSDT,H0,HH,HL,JACSUM,MD,MCHEP,MPT,
+PHI,R1MACH,RTOL,SEND,SINC,SJT,SS,SUM,TERM,TINC,TT,TUPI,X,XX,YMAX,
+YMIN,YY
COMPLEX PARFUN,T1,T2
COMMON /DSDTDA/PT,MD,HL
PARAMETER (MININ=20,MXCOF=32,QP=4)
REAL JACOF(MXCOF)
EXTERNAL DSDT,JACSUM,PARFUN,R1MACH
C
C INITIALISE SOME CONSTANTS
C
TUPI=8E+0*ATAN(1E+0)
MCHEP=R1MACH(4)
RTOL=1E+1*MCHEP
ATOL=1E+2*MCHEP
NCRVS=0
NPRVS=0
CCAPH=0E+0
CPHCA=0E+0
MAP11=.TRUE.
YMAX=R1MACH(2)
NASYM=0
C
C START TO COMPUTE THE ARC LENGTHS OF EACH SUBARC (ARCLN) AND THE
C TOTAL LENGTH (TOTLN) OF THE BOUNDARY
C
TOTLN=0E+0
DO 10 IA=1,TNSUA
PT=PARNT(IA)
MD=MIDPT(IA)
HL=HALEN(IA)
T1=CMPLX(MD+HL)
T2=CMPLX(MD-HL)
C
C**** COMPOSITE QP-PANEL GAUSS-LEGENDRE ESTIMATE FOR ARCLN(IA)
C
HH=1E+0/QP
SUM=0E+0
DO 6 K=1,QP
MPT=-1E+0+(2E+0*K-1E+0)*HH
DO 3 I=1,NQPTS
X=MPT+HH*QUPTS(I)
SUM=SUM+QUWTS(I)*DSDT(X)
3 CONTINUE
6 CONTINUE
ARCLN(IA)=HH*SUM
TOTLN=TOTLN+ARCLN(IA)
10 CONTINUE
C
C TEST FOR COMPLETE REVERSAL OF DIRECTION OF A BOUNDARY SUBARC ON
C THE UNIT DISC.
C
DO 20 IA=1,TNSUA
IF (VTARG(IA+1) .LT. VTARG(IA)) THEN
NCRVS=NCRVS+1
ICRVS(NCRVS)=IA
MAP11=.FALSE.
ENDIF
20 CONTINUE
C
C COMPUTE THE NUMBERS *NINFD* (*NZERD*) OF POINTS WHERE THE
C DERIVATIVE OF THE MAP PHYSICAL --> CANONICAL IS RESPECTIVELY
C INFINITE (ZERO).
C
NINFD=0
NZERD=0
DO 25 I=1,NARCS
IF (JACIN(I) .LT. 0E+0) THEN
NINFD=NINFD+1
ELSE IF (JACIN(I) .GT. 0E+0) THEN
NZERD=NZERD+1
ENDIF
25 CONTINUE
C
C NOW START TO EVALUATE THE DIMENSIONLESS BOUNDARY CORRESPONDENCE
C DERIVATIVE AT SELECTED VALUES OF DIMENSIONLESS ARC LENGTH;
C OUTPUT RESULTS FOR SUBSEQUENT GRAPH PLOTTING IF REQUIRED AND
C TEST FOR SIGN CHANGES IN THIS DERIVATIVE.
C
SS=0E+0
SEND=0E+0
DO 60 IA=1,TNSUA
NINTS=MAX(MININ,NINT(ARCLN(IA)*NXINT/TOTLN))
TINC=2E+0/NINTS
DG=DGPOL(IA)
IF (DG+1 .GT. MXCOF) THEN
IER=50
RETURN
ENDIF
JT=JATYP(IA)
AJT=ABS(JT)
H0=H0VAL(AJT)
BT=JACIN(AJT)
AL=1E+0/(1E+0+BT)
PT=PARNT(IA)
MD=MIDPT(IA)
HL=HALEN(IA)
LOM=LOSUB(IA)
LOD=(AJT-1)*NQPTS+1
IF (JT.GT.0) THEN
CC=VTARG(IA)-VTARG(1)
ELSE
CC=VTARG(IA+1)-VTARG(1)
ENDIF
DO 30 I=1,DG+1
I1=I+LOM-1
JACOF(I)=SOLUN(I1)
30 CONTINUE
SJT=SIGN(1E+0,REAL(JT))
DO 40 I=2,DG+1,2
JACOF(I)=SJT*JACOF(I)
40 CONTINUE
TT=-1E+0
D=DSDT(TT)
YMIN=YMAX
IF (IA .EQ. 1) THEN
XX=0E+0
IF (BT .LT. 0E+0) THEN
YY=YMAX
NASYM=NASYM+1
ASYMP(NASYM)=XX
ELSE IF (BT .GT. 0E+0) THEN
YY=0E+0
ELSE
PHI=JACSUM(TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)
IF (D .EQ. 0E+0) THEN
IER=51
RETURN
ENDIF
YY=TOTLN*PHI/D
ENDIF
IF (NINFD .EQ. 0E+0) THEN
CPHCA=TUPI*ABS(YY)/TOTLN
ENDIF
IF (NZERD .EQ. 0E+0) THEN
IF (YY .EQ. 0E+0) THEN
CCAPH=YMAX
ELSE
CCAPH=TOTLN/TUPI/ABS(YY)
ENDIF
ENDIF
WRITE(OUCH1,902) XX,YY
YY=0E+0
WRITE(OUCH0,902) XX,YY
CORXX(1)=0E+0
ENDIF
C
C ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS FOR INFINITE
C DERIVATIVE CASES.
C
IF (BT .LT. 0E+0) THEN
PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=BCFSN(LOM)-2E+0*PHI
COF=ABS(PHI)/D**(BT+1E+0)
TERM=MCHEP**BT*COF
IF (TERM .GT. CPHCA) THEN
CPHCA=TERM
COPHC=COF
EXPHC=BT
ENDIF
ENDIF
IF (BT .GT. 0E+0) THEN
PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=BCFSN(LOM)-2E+0*PHI
IF (ABS(PHI) .EQ. 0E+0) THEN
CCAPH=YMAX
COCAP=YMAX
EXCAP=AL-1E+0
ELSE
COF=D/ABS(PHI)**AL
TERM=MCHEP**(AL-1E+0)*COF
IF (TERM .GT. CCAPH) THEN
CCAPH=TERM
COCAP=COF
EXCAP=AL-1E+0
ENDIF
ENDIF
ENDIF
C
C "DO 50" LOOP FOR POINTS INTERIOR TO ARC NUMBER IA
C
DO 50 I=1,NINTS-1
TT=TT+TINC
C
C**** ARC LENGTH INCREASE BY GAUSS-LEGENDRE
C
SUM=0E+0
DO 45 K=1,NQPTS
X=TT+5E-1*TINC*(QUPTS(K)-1E+0)
SUM=SUM+QUWTS(K)*DSDT(X)
45 CONTINUE
SINC=5E-1*TINC*SUM
SS=SS+SINC
XX=SS/TOTLN
C
C EVALUATE DIMENSIONLESS BCF DERIVATIVE *YY*
C
PHI=JACSUM(SJT*TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)
D=DSDT(TT)
IF (D .EQ. 0E+0) THEN
IER=51
RETURN
ENDIF
YY=TOTLN*(1E+0+SJT*TT)**BT*PHI/D
WRITE(OUCH1,902) XX,YY
YMIN=MIN(YY,YMIN)
C
C ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS FOR FINITE
C DERIVATIVE CASES.
C
IF (NINFD .EQ. 0E+0) THEN
CPHCA=MAX(CPHCA,TUPI*ABS(YY)/TOTLN)
ENDIF
IF (NZERD .EQ. 0E+0) THEN
IF (YY .EQ. 0E+0) THEN
CCAPH=YMAX
ELSE
CCAPH=MAX(CCAPH,TOTLN/TUPI/ABS(YY))
ENDIF
ENDIF
C
C EVALUATE DIMENSIONLESS BCF *YY*
C
PHI=JACSUM(SJT*TT,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=BCFSN(LOM)-(1E+0-SJT*TT)*PHI
YY=(CC+SJT*(1E+0+SJT*TT)**(1E+0+BT)*PHI)/TUPI
WRITE(OUCH0,902) XX,YY
50 CONTINUE
C
C NEXT TAKE END POINT OF ARC NUMBER IA
C
TT=1E+0
D=DSDT(TT)
SEND=SEND+ARCLN(IA)
SS=SEND
XX=SS/TOTLN
C
C EVALUATE DIMENSIONLESS BCF DERIVATIVE *YY*
C
IF (JT .LT. 0E+0) THEN
IF (BT .LT. 0E+0) THEN
YY=YMAX
NASYM=NASYM+1
ASYMP(NASYM)=XX
ELSE IF (BT .GT. 0E+0) THEN
YY=0E+0
ELSE
PHI=JACSUM(SJT*TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)
IF (D .EQ. 0E+0) THEN
IER=51
RETURN
ENDIF
YY=TOTLN*PHI/D
ENDIF
ELSE
PHI=JACSUM(TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)
IF (D .EQ. 0E+0) THEN
IER=51
RETURN
ENDIF
YY=TOTLN*2E+0**BT*PHI/D
ENDIF
WRITE(OUCH1,902) XX,YY
YMIN=MIN(YY,YMIN)
IF (YMIN.LT.0E+0 .AND. (VTARG(IA+1) .GE. VTARG(IA))) THEN
NPRVS=NPRVS+1
IPRVS(NPRVS)=IA
BCDMN(NPRVS)=YMIN
MAP11=.FALSE.
ENDIF
C
C ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS
C
IF (NINFD .EQ. 0E+0) THEN
CPHCA=MAX(CPHCA,TUPI*ABS(YY)/TOTLN)
ENDIF
IF (NZERD .EQ. 0E+0) THEN
IF (YY .EQ. 0E+0) THEN
CCAPH=YMAX
ELSE
CCAPH=MAX(CCAPH,TOTLN/TUPI/ABS(YY))
ENDIF
ENDIF
IF (BT .LT. 0E+0) THEN
PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=BCFSN(LOM)-2E+0*PHI
COF=ABS(PHI)/D**(BT+1E+0)
TERM=MCHEP**BT*COF
IF (TERM .GT. CPHCA) THEN
CPHCA=TERM
COPHC=COF
EXPHC=BT
ENDIF
ENDIF
IF (BT .GT. 0E+0) THEN
PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PHI=BCFSN(LOM)-2E+0*PHI
IF (ABS(PHI) .EQ. 0E+0) THEN
CCAPH=YMAX
COCAP=YMAX
EXCAP=AL-1E+0
ELSE
COF=D/ABS(PHI)**AL
TERM=MCHEP**(AL-1E+0)*COF
IF (TERM .GT. CCAPH) THEN
CCAPH=TERM
COCAP=COF
EXCAP=AL-1E+0
ENDIF
ENDIF
ENDIF
C
C EVALUATE DIMENSIONLESS BCF *YY*
C
YY=(VTARG(IA+1)-VTARG(1))/TUPI
WRITE(OUCH0,902) XX,YY
IF (JT.LT.0) THEN
CORXX(PT+1)=XX
ENDIF
C
60 CONTINUE
C
901 FORMAT(2E16.8,1X,A3)
902 FORMAT(2E16.8)
C
C NORMAL EXIT
C
IER=0
C
END
REAL FUNCTION DIAPHY(NARCS)
INTEGER NARCS
C
C**** THE APPROXIMATE DIAMETER OF THE PHYSICAL DOMAIN.
C
C LOCAL VARIABLES
C
INTEGER I,IA,NH
REAL A1,HH,T,DPD
COMPLEX C1,CENTR,PARFUN
PARAMETER (NH=5)
EXTERNAL PARFUN
C
C**** GET ROUGH ESTIMATE OF CENTRE OF DOMAIN
C
CENTR=(0E+0,0E+0)
DO 10 IA=1,NARCS
C1=PARFUN(IA,(-1E+0,0E+0))
CENTR=CENTR+C1
C1=PARFUN(IA,(0E+0,0E+0))
CENTR=CENTR+C1
10 CONTINUE
CENTR=CENTR/2E+0/NARCS
C
C**** GET ROUGH ESTIMATE OF MAXIMUM DISTANCE FROM CENTRE
C
DPD=0E+0
HH=2E+0/REAL(NH)
DO 30 IA=1,NARCS
T=-1E+0
DO 20 I=1,NH
T=T+HH
C1=PARFUN(IA,CMPLX(T))-CENTR
A1=ABS(C1)
DPD=MAX(DPD,A1)
20 CONTINUE
30 CONTINUE
DIAPHY=2E+0*DPD
C
END
SUBROUTINE DMCANP(NPTS,PHYPT,CANPT,INTER,CENTR,IGEOM,RGEOM,
+ISNCA,RSNCA,ZSNCA,IQUCA,ZQUCA,WANTM,IER)
C
INTEGER NPTS,IER
INTEGER IGEOM(*),ISNCA(*),IQUCA(*)
REAL RGEOM(*),RSNCA(*)
COMPLEX CENTR
COMPLEX PHYPT(*),CANPT(*),ZSNCA(*),ZQUCA(*)
LOGICAL INTER,WANTM
C
C ......................................................................
C
C 1. DMCANP
C DOMAIN MAPPING FOR THE CANONICAL --> PHYSICAL MAP.
C
C 2. PURPOSE
C GIVEN A VECTOR OF ARBITRARY POINTS IN THE CANONICAL DOMAIN,
C THIS ROUTINE COMPUTES THE VECTOR OF APPROXIMATE IMAGE POINTS
C IN THE PHYSICAL DOMAIN.
C
C 3. CALLING SEQUENCE
C CALL DMCANP(NPTS,PHYPT,CANPT,INTER,CENTR,IGEOM,RGEOM,ISNCA,
C RSNCA,ZSNCA,IQUCA,ZQUCA,WANTM,IER)
C
C PARAMETERS
C ON ENTRY
C NPTS - INTEGER
C THE NUMBER OF POINTS TO BE MAPPED.
C
C CANPT - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST NPTS. THIS IS
C THE VECTOR OF GIVEN POINTS IN THE CANONICAL
C DOMAIN.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE. (AS PREVIOUSLY USED IN JAPHYC, GQPHYC)
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS TO BE
C MAPPED TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN. (AS PREV-
C IOUSLY USED IN JAPHYC, GQPHYC)
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C
C ISNCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY JACANP.
C
C RSNCA - REAL ARRAY
C THE REAL VECTOR PREVIOUSLY SET UP BY JACANP.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY JACANP.
C
C IQUCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY GQCANP.
C
C RQUCA - REAL ARRAY
C THE REAL VECTOR PREVIOUSLY SET UP BY GQCANP.
C
C ZQUCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY GQCANP.
C
C WANTM - LOGICAL
C IF WANTM IS TRUE THEN, ON AN ABNORMAL EXIT, AN
C ERROR MESSAGE IS WRITTEN ON THE STANDARD OUTPUT
C CHANNEL. IF WANTM IS FALSE THEN NO MESSAGE IS
C WRITTEN.
C ON EXIT
C PHYPT - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST NPTS. PHYPT(K)
C IS THE COMPUTED IMAGE IN THE PHYSICAL DOMAIN OF
C THE GIVEN CANONICAL POINT CANPT(K), K=1,...,NPTS.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS WRITTEN ON
C THE STANDARD OUTPUT CHANNEL IF WANTM IS TRUE.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINES JACANP AND GQCANP HAVE SUCCESSFULLY EXECUTED,
C AND THAT MANY INPUT ARGUMENTS FOR DMCANP ARE OUTPUT VALUES
C FROM JACANP AND GQCANP.
C - THIS ROUTINE MAY BE USED FOR MAPPING POINTS ON THE UNIT
C CIRCLE, BUT THE ROUTINE BMCANP WILL BE SOMEWHAT MORE
C EFFICIENT FOR THIS CASE.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOFC,AICOC,BCOFC,BFSNC,BICOC,DGPOC,H0VLC,HALEN,HIVLC,
+JAINC,JTYPC,LQSBG,LSUBC,MIDPT,MNCOF,MNSUA,MNSUC,MQUCA,NARCS,NJIND,
+NPPQG,NQPTS,PARNT,PHPAS,PRNSA,QUWTC,QUPTC,SOLNC,TNGQP,TNSUC,VARGC,
+VTARG,WPPQG,ZPPQG
CHARACTER*6 IERTXT
C
EXTERNAL CATPH4,IERTXT
C
NARCS=ISNCA(1)
NQPTS=ISNCA(2)
TNSUC=ISNCA(3)
MNSUC=ISNCA(5)
MNCOF=ISNCA(6)
MQUCA=IQUCA(4)
MNSUA=IGEOM(4)
C
NJIND=NARCS+1
TNGQP=NJIND*NQPTS
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP POINTERS TO ISNCA, RSNCA AND ZSNCA, AS IN JACANP
C
DGPOC=7
JTYPC=MNSUC+7
LSUBC=2*MNSUC+7
PRNSA=3*MNSUC+7
ACOFC=2
BCOFC=TNGQP+2
AICOC=2*TNGQP+2
BICOC=3*TNGQP+2
QUPTC=4*TNGQP+2
QUWTC=5*TNGQP+2
H0VLC=6*TNGQP+2
HIVLC=NJIND+6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
PHPAS=4*NJIND+6*TNGQP+2
VARGC=MNSUC+4*NJIND+6*TNGQP+2
BFSNC=2
SOLNC=MNCOF+2
C
C**** SET UP POINTERS TO IQUCA AND ZQUCA, AS IN GQCANP
C
LQSBG=5
NPPQG=MNSUC+5
WPPQG=2
ZPPQG=MQUCA+2
C
C**** GET THE REQUIRED PHYSICAL POINTS
C
CALL CATPH4(NPTS,PHYPT,CANPT,NARCS,NQPTS,TNSUC,ISNCA(DGPOC),
+ISNCA(JTYPC),ISNCA(LSUBC),IQUCA(LQSBG),IQUCA(NPPQG),IGEOM(PARNT),
+ISNCA(PRNSA),RSNCA(AICOC),RSNCA(ACOFC),RSNCA(BICOC),RSNCA(BCOFC),
+RSNCA(H0VLC),RSNCA(HIVLC),RGEOM(HALEN),RSNCA(JAINC),RGEOM(2),
+RGEOM(MIDPT),RSNCA(PHPAS),RSNCA(QUPTC),RSNCA(QUWTC),RGEOM(VTARG),
+RSNCA(VARGC),ZSNCA(BFSNC),CENTR,ZSNCA(1),ZSNCA(SOLNC),
+ZQUCA(WPPQG),ZQUCA(ZPPQG),INTER,IER)
C
C**** SEND ERROR MESSAGE TO STANDARD OUTPUT OF NECESSARY
C
IF (IER.GT.0 .AND. WANTM) WRITE(*,*) IERTXT(IER)
C
END
SUBROUTINE DMPHYC(NPTS,PHYPT,CANPT,INTER,CENTR,IGEOM,RGEOM,ISNPH,
+RSNPH,IQUPH,RQUPH,ZQUPH,WANTM,IER)
C
INTEGER NPTS,IER
INTEGER IGEOM(*),ISNPH(*),IQUPH(*)
REAL RGEOM(*),RSNPH(*),RQUPH(*)
COMPLEX CENTR
COMPLEX PHYPT(*),CANPT(*),ZQUPH(*)
LOGICAL INTER,WANTM
C
C ......................................................................
C
C 1. DMPHYC
C DOMAIN MAPPING FOR THE PHYSICAL --> CANONICAL MAP.
C
C 2. PURPOSE
C GIVEN A VECTOR OF ARBITRARY POINTS IN THE PHYSICAL DOMAIN,
C THIS ROUTINE COMPUTES THE VECTOR OF APPROXIMATE IMAGE POINTS
C IN THE CANONICAL DOMAIN.
C
C
C 3. CALLING SEQUENCE
C CALL DMPHYC(NPTS,PHYPT,CANPT,INTER,CENTR,IGEOM,RGEOM,ISNPH,
C RSNPH,IQUPH,RQUPH,ZQUPH,WANTM,IER)
C
C PARAMETERS
C ON ENTRY
C NPTS - INTEGER
C THE NUMBER OF POINTS TO BE MAPPED.
C
C PHYPT - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST NPTS. THIS IS
C THE VECTOR OF GIVEN POINTS IN THE PHYSICAL DOMAIN.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE. (AS PREVIOUSLY USED IN JAPHYC, GQPHYC)
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS TO BE
C MAPPED TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN. (AS PREV-
C IOUSLY USED IN JAPHYC, GQPHYC)
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC.
C
C IQUPH - INTEGER ARRAY
C THE INTEGER VECTOR IQUPH PREVIOUSLY SET UP BY
C GQPHYC.
C
C RQUPH - REAL ARRAY
C THE REAL ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C ZQUPH - COMPLEX ARRAY
C THE COMPLEX ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C WANTM - LOGICAL
C IF WANTM IS TRUE THEN, ON AN ABNORMAL EXIT, AN
C ERROR MESSAGE IS WRITTEN ON THE STANDARD OUTPUT
C CHANNEL. IF WANTM IS FALSE THEN NO MESSAGE IS
C WRITTEN.
C
C ON EXIT
C CANPT - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST NPTS. CANPT(K)
C IS THE COMPUTED IMAGE IN THE CANONICAL DOMAIN OF
C THE GIVEN PHYSICAL POINT PHYPT(K), K=1,...,NPTS.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINES JAPHYC AND GQPHYC HAVE SUCCESSFULLY EXECUTED,
C AND THAT MANY INPUT ARGUMENTS FOR DMPHYC ARE OUTPUT VALUES
C FROM JAPHYC AND GQPHYC.
C - THIS ROUTINE MAY BE USED FOR MAPPING POINTS ON THE BOUN-
C DARY OF THE PHYSICAL DOMAIN, BUT THE ROUTINE BMPHYC WILL
C BE SOMEWHAT MORE EFFICIENT FOR THIS CASE.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 6 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOEF,AICOF,BCFSN,BCOEF,BICOF,DGPOL,FACTR,H0VAL,HALEN,
+HIVAL,JACIN,JATYP,LOSUB,LQSBF,MIDPT,MNEQN,MNSUA,MQUPH,NARCS,NJIND,
+NPPQF,NQPTS,PARNT,QUPTS,QUWTS,SOLUN,TNGQP,TNSUA,TPPQF,TRRAD,VTARG,
+WPPQF,ZPPQF
CHARACTER*6 IERTXT
C
EXTERNAL PHTCA1,IERTXT
C
NARCS=ISNPH(1)
NQPTS=ISNPH(2)
TNSUA=ISNPH(3)
MNSUA=ISNPH(5)
MNEQN=ISNPH(6)
MQUPH=IQUPH(4)
C
NJIND=NARCS+1
TNGQP=NQPTS*NJIND
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP THE POINTERS TO ISNPH AND RSNPH, AS IN JAPHYC
C
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
BCFSN=MNSUA+3*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
C**** SET UP POINTERS TO IQUPH AND RQUPH, AS IN GQPHYC
C
LQSBF=5
NPPQF=MNSUA+5
TPPQF=2
TRRAD=MQUPH+2
WPPQF=2*MQUPH+2
FACTR=1
ZPPQF=2
C
C**** GET REQUIRED CANONICAL POINTS
C
CALL PHTCA1(NPTS,PHYPT,CANPT,NARCS,NQPTS,TNSUA,ISNPH(DGPOL),
+ISNPH(JATYP),ISNPH(LOSUB),IQUPH(LQSBF),IQUPH(NPPQF),IGEOM(PARNT),
+RSNPH(AICOF),RSNPH(ACOEF),RSNPH(BICOF),RSNPH(BCFSN),RSNPH(BCOEF),
+RSNPH(H0VAL),RSNPH(HIVAL),RGEOM(HALEN),RSNPH(JACIN),RGEOM(2),
+RGEOM(MIDPT),RSNPH(QUPTS),RSNPH(QUWTS),RSNPH(SOLUN),RQUPH(TPPQF),
+RQUPH(TRRAD),RGEOM(VTARG),RQUPH(WPPQF),CENTR,ZQUPH(FACTR),
+ZQUPH(ZPPQF),INTER,IER)
C
C**** SEND ERROR MESSAGE TO STANDARD OUTPUT OF NECESSARY
C
IF (IER.GT.0 .AND. WANTM) WRITE(*,*) IERTXT(IER)
C
END
REAL FUNCTION DSDT(X)
REAL X
C
C**** TO COMPUTE THE PARAMETRIC DERIVATIVE OF THE ARC LENGTH FOR THE
C**** ARC SPECIFIED IN DSDTDA
C
C**** LOCAL VARIABLES
C
INTEGER I
REAL M,H
COMPLEX DPARFN
COMMON /DSDTDA/I,M,H
EXTERNAL DPARFN
C
DSDT=ABS(DPARFN(I,CMPLX(M+H*X)))*H
C
END
SUBROUTINE EIGSYS(N,EPS,D,E,Z,IER)
INTEGER N,IER
REAL EPS
REAL D(N),E(N),Z(N)
C
C THIS IS A MODIFIED VERSION OF THE EISPACK ROUTINE IMTQL2.
C IT FINDS THE EIGENVALUES AND FIRST COMPONENTS OF THE
C EIGENVECTORS OF A SYMMETRIC TRIDIAGONAL MATRIX BY THE IMPLICIT QL
C METHOD.
C
C**** LOCAL VARIABLES
C
INTEGER L,J,M ,MML,II,K,I
REAL P,G,R,S,C,F,B
C
IER = 0
C
IF (N .EQ. 1) GO TO 1001
C
E(N) = 0E+0
DO 240 L = 1,N
J = 0
C
C**** LOOK FOR SMALL SUB-DIAGONAL ELEMENT
C
105 DO 110 M = L,N
IF (M .EQ. N) GO TO 120
IF (ABS(E(M)) .LE. EPS * (ABS(D(M)) + ABS(D(M+1))))
+ GO TO 120
110 CONTINUE
C
120 P = D(L)
IF (M .EQ. L) GO TO 240
IF (J .EQ. 30) GO TO 1000
J = J + 1
C
C**** FORM SHIFT
C
G = (D(L+1) - P) / (2. * E(L))
R = SQRT(G*G+1E+0)
G = D(M) - P + E(L) / (G + SIGN(R,G))
S = 1E+0
C = 1E+0
P = 0E+0
MML = M - L
C
DO 200 II = 1,MML
I = M - II
F = S * E(I)
B = C * E(I)
IF (ABS(F) .LT. ABS(G)) GO TO 150
C = G / F
R = SQRT(C*C+1E+0)
E(I+1) = F * R
S = 1E+0 / R
C = C * S
GO TO 160
150 S = F / G
R = SQRT(S*S+1E+0)
E(I+1) = G * R
C = 1E+0 / R
S = S * C
160 G = D(I+1) - P
R = (D(I) - G) * S + 2. * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
C
C**** FORM FIRST COMPONENT OF VECTOR
C
F = Z(I+1)
Z(I+1) = S * Z(I) + C * F
200 Z(I) = C * Z(I) - S * F
C
D(L) = D(L) - P
E(L) = G
E(M) = 0E+0
GO TO 105
240 CONTINUE
C
C**** ORDER EIGENVALUES AND EIGENVECTORS
C
DO 300 II = 2,N
I = II - 1
K = I
P = D(I)
DO 260 J = II,N
IF (D(J) .GE. P) GO TO 260
K = J
P = D(J)
260 CONTINUE
C
IF (K .EQ. I) GO TO 300
D(K) = D(I)
D(I) = P
P = Z(I)
Z(I) = Z(K)
Z(K) = P
300 CONTINUE
C
GO TO 1001
C
C**** SET ERROR -- NO CONVERGENCE TO AN EIGENVALUE AFTER 30 ITERATIONS
C
1000 IER = L
C
1001 RETURN
C
END
REAL FUNCTION FNVAL(X)
REAL X
C
C LOCAL VARIABLES.
C
INTEGER TYPE
REAL BETA,A1,B1,P0VAL,SCALE
COMMON /FNDEF/BETA,A1,B1,P0VAL,SCALE,TYPE
C
IF (TYPE .EQ. 1) THEN
FNVAL=P0VAL*SCALE
ELSE IF (TYPE .EQ. 2) THEN
FNVAL=(1E+0+X)**BETA*P0VAL*SCALE
ELSE IF (TYPE .EQ. 3) THEN
FNVAL=(X-B1)*P0VAL*SCALE/A1
ELSE
FNVAL=(1E+0+X)**BETA*(X-B1)*P0VAL*SCALE/A1
ENDIF
C
END
REAL FUNCTION GAMMA(U)
REAL U
C
C TO COMPUTE THE GAMMA FUNCTION FOR REAL ARGUMENT U BY USING
C THE CHEBYSHEV EXPANSION GIVEN IN TABLE 1.3 OF "MATHEMATICAL
C FUNCTIONS AND THEIR APPROXIMATION" BY Y.L. LUKE ,ACADEMIC PRESS,
C NEW YORK, 1975.
C SINCE GAMMA HAS POLES AT U=0,-1,-2,-3,... DIVISION BY ZERO WILL
C OCCUR FOR THESE ARGUMENT VALUES.
C
C LOCAL VARIABLES
C
INTEGER N
REAL UWORK,FACTOR
DOUBLE PRECISION X,B0,B1,B2,A(0:17)
DATA A(0)/3.65738772508338243850D+0/,
+A(1)/1.95754345666126826928D+0/,
+A(2)/0.33829711382616038916D+0/,A(3)/0.4208951276557549199D-1/,
+A(4)/0.42876504821290877D-2/,A(5)/0.36521216929461767D-3/,
+A(6)/0.27400642226422D-4/,A(7)/0.181240233365124D-5/,
+A(8)/0.10965775865997D-6/,A(9)/0.598718404552D-8/,
+A(10)/0.30769080535D-9/,A(11)/0.143179303D-10/,
+A(12)/0.65108773D-12/,A(13)/0.259585D-13/,A(14)/0.110789D-14/,
+A(15)/0.3547D-16/,A(16)/0.169D-17/,A(17)/0.3D-19/
C
UWORK=U
FACTOR=1E+0
C
10 CONTINUE
IF (UWORK.GT.4E+0) THEN
UWORK=UWORK-1E+0
FACTOR=FACTOR*UWORK
GOTO 10
ELSE IF (UWORK.LT.3E+0) THEN
FACTOR=FACTOR/UWORK
UWORK=UWORK+1E+0
GOTO 10
ENDIF
C
X=UWORK-3D+0
X=4D+0*X-2D+0
B2=0D+0
B1=0D+0
DO 20 N=17,0,-1
B0=X*B1-B2+A(N)
IF (N.GT.0) THEN
B2=B1
B1=B0
ENDIF
20 CONTINUE
C
GAMMA=5E-1*(B0+A(0)-B2)*FACTOR
C
END
SUBROUTINE GQCANP(MQIN1,MQUCA,ISNCA,RSNCA,ZSNCA,RWORK,CHNL,IQUCA,
+ZQUCA,IER)
C
INTEGER MQIN1,MQUCA,CHNL,IER
INTEGER IQUCA(*),ISNCA(*)
REAL RSNCA(*),RWORK(*)
COMPLEX ZQUCA(*),ZSNCA(*)
C
C ......................................................................
C
C 1. GQCANP
C COMPUTES A GLOBAL QUADRATURE RULE FOR APPROXIMATING THE
C BOUNDARY INTEGRAL REPRESENTATION OF THE MAP : CANONICAL -->
C PHYSICAL.
C
C 2. PURPOSE
C THE ROUTINE SETS UP THE BOUNDARY QUADRATURE POINTS AND
C CORRESPONDING WEIGHTS FOR A COMPOSITE GAUSS-JACOBI/GAUSS-
C LEGENDRE RULE FOR ESTIMATING THE BOUNDARY INTEGRAL THAT
C APPEARS IN THE RESPRESENTATION FOR THE CONFORMAL MAP OF THE
C CANONICAL DOMAIN ONTO THE PHYSICAL DOMAIN. THIS QUADRATURE
C RULE IS USED IN THE STANDARD NON-SINGULAR CASE WHEN THE
C FIELD POINT IN THE CANONICAL DOMAIN DOES NOT LIE CLOSE TO
C THE UNIT CIRCLE.
C
C 3. CALLING SEQUENCE
C CALL GQCANP(MQIN1,MQUCA,ISNCA,RSNCA,ZSNCA,RWORK,CHNL,IQUCA,
C ZQUCA,IER)
C
C PARAMETERS
C ON ENTRY
C MQIN1 - INTEGER
C DEFINES THE NUMBER OF PANELS ALLOWED IN A
C COMPOSITE RULE. SPECIFICALLY, MQIN1 = 1 + (THE
C MAXIMUM NUMBER OF PANELS IN A COMPOSITE RULE FOR
C A SINGLE SUB-ARC ON THE BOUNDARY)
C
C MQUCA - INTEGER
C THE MAXIMUM NUMBER OF QUADRATURE POINTS ALLOWED
C IN THE FINAL GLOBAL RULE. THE VALUE OF THIS
C ARGUMENT IS LINKED TO THOSE OF ARGUMENTS NQPTS
C AND IBNDS(1) PREVIOUSLY SUPPLIED TO JACANP VIA
C MQUCA <= (MQIN1-1)*NQPTS*IBNDS(1). (NOTE THAT
C NQPTS = ISNCA(2) 'JACANP'IBNDS(1) =ISNCA(5) )
C
C ISNCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY JACANP.
C
C RSNCA - REAL ARRAY
C THE REAL VECTOR PREVIOUSLY SET UP BY JACANP.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY JACANP.
C
C RWORK - REAL ARRAY
C A WORKING VECTOR OF SIZE AT LEAST MQIN1.
C
C CHNL - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILE cq.
C
C ON EXIT
C IQUCA - INTEGER ARRAY
C AN INTEGER VECTOR OF SIZE AT LEAST 2*IBNDS(1) + 4,
C WHERE IBNDS(1) (=ISNCA(5)) IS THE VALUE PREVIOUSLY
C SUPPLIED TO JACANP; IQUCA MAINLY STORES POINTERS
C TO ACCESS ZQUCA.
C
C ZQUCA - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST 2*MQUCA+1;
C STORES THE QUADRATURE POINTS AND WEIGHTS.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINE JACANP HAS SUCCESSFULLY EXECUTED, AND THAT SOME
C INPUT ARGUMENTS FOR GQCANP ARE OUTPUT VALUES FROM JACANP.
C - THE GLOBAL QUADRATURE DATA ARE AUTOMATICALLY OUTPUT ON THE
C FILE cq, WHERE IS COLLECTED FROM THE FILE
C jbnm PREVIOUSLY CREATED BY JAPHYC.
C - A SUMMARY LISTING OF ACTIONS TAKEN IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOFC,BCOFC,DGPOC,H0VLC,JAINC,JTYPC,LQSBG,LSUBC,
+MNCOF,MNSUC,NARCS,NINTS,NJIND,NPPQG,NQPTS,QUPTC,QUWTC,SOLNC,
+TNGQP,TNPQP,TNSUC,VARGC,WPPQG,ZPPQG
REAL DELTA,LGTOL,TOLOU
C
PARAMETER(DELTA=2E-1,NINTS=5)
C
EXTERNAL POPQG1,OUPTCQ
C
C**** WRITE HEADING TO STANDARD OUTPUT CHANNEL
C
CALL WRHEAD(4,0)
C
NARCS=ISNCA(1)
NQPTS=ISNCA(2)
TNSUC=ISNCA(3)
MNSUC=ISNCA(5)
MNCOF=ISNCA(6)
LGTOL=RSNCA(1)
ZQUCA(1)=ZSNCA(1)
C
NJIND=NARCS+1
TNGQP=NJIND*NQPTS
C
IQUCA(2)=TNSUC
IQUCA(3)=MNSUC
IQUCA(4)=MQUCA
C
C**** COPY RELEVANT POINTERS TO ISNCA, RSNCA AND ZSNCA FROM JACANP
C
DGPOC=7
JTYPC=MNSUC+7
LSUBC=2*MNSUC+7
ACOFC=2
BCOFC=TNGQP+2
QUPTC=4*TNGQP+2
QUWTC=5*TNGQP+2
H0VLC=6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
VARGC=MNSUC+4*NJIND+6*TNGQP+2
SOLNC=MNCOF+2
C
C**** SET UP POINTERS FOR QUADRATURE ARRAYS IQUCA AND ZQUCA
C
LQSBG=5
NPPQG=MNSUC+5
WPPQG=2
ZPPQG=MQUCA+2
C
WRITE(*,10) 'QUADRATURE RULES STARTED:'
10 FORMAT(A45)
CALL POPQG1(IQUCA(NPPQG),IQUCA(LQSBG),TNPQP,TOLOU,ZQUCA(WPPQG),
+ZQUCA(ZPPQG),MQUCA,MQIN1,NARCS,NINTS,NQPTS,TNSUC,ISNCA(DGPOC),
+ISNCA(JTYPC),ISNCA(LSUBC),DELTA,LGTOL,RSNCA(ACOFC),RSNCA(BCOFC),
+RSNCA(H0VLC),RSNCA(JAINC),RSNCA(QUPTC),RSNCA(QUWTC),ZSNCA(SOLNC),
+RSNCA(VARGC),RWORK,IER)
IQUCA(1)=TNPQP
WRITE(*,10) 'QUADRATURE RULES DONE:'
C
C**** WRITE CLOSING MESSAGE TO STANDARD OUTPUT CHANNEL
C
CALL WRTAIL(4,0,IER)
C
IF (IER .EQ. 0) THEN
CALL OUPTCQ(IQUCA,ZQUCA,CHNL)
ENDIF
C
END
SUBROUTINE GQPHYC(MQIN1,MQUPH,INTER,CENTR,IGEOM,RGEOM,ISNPH,RSNPH,
+RWORK,CHNL,IQUPH,RQUPH,ZQUPH,IER)
C
INTEGER MQIN1,MQUPH,CHNL,IER
INTEGER IQUPH(*),IGEOM(*),ISNPH(*)
REAL RQUPH(*),RGEOM(*),RSNPH(*),RWORK(*)
COMPLEX CENTR
COMPLEX ZQUPH(*)
LOGICAL INTER
C
C ......................................................................
C
C 1. GQPHYC
C COMPUTES A GLOBAL QUADRATURE RULE FOR APPROXIMATING THE
C BOUNDARY INTEGRAL REPRESENTATION OF THE MAP : PHYSICAL -->
C CANONICAL.
C
C
C 2. PURPOSE
C THE ROUTINE SETS UP THE BOUNDARY QUADRATURE POINTS AND
C CORRESPONDING WEIGHTS FOR A COMPOSITE GAUSS-JACOBI/GAUSS-
C LEGENDRE RULE FOR ESTIMATING THE BOUNDARY INTEGRAL THAT
C APPEARS IN THE RESPRESENTATION FOR THE CONFORMAL MAP OF THE
C PHYSICAL DOMAIN ONTO THE CANONICAL DOMAIN. THIS QUADRATURE
C RULE IS USED IN THE STANDARD NON-SINGULAR CASE WHEN THE
C FIELD POINT IN THE PHYSICAL DOMAIN DOES NOT LIE CLOSE TO THE
C BOUNDARY.
C
C
C 3. CALLING SEQUENCE
C CALL GQPHYC(MQIN1,MQUPH,INTER,CENTR,IGEOM,RGEOM,ISNPH,RSNPH,
C RWORK,CHNL,IQUPH,RQUPH,ZQUPH,IER)
C
C PARAMETERS
C ON ENTRY
C MQIN1 - INTEGER
C DEFINES THE NUMBER OF PANELS ALLOWED IN A
C COMPOSITE RULE. SPECIFICALLY, MQIN1 = 1 + (THE
C MAXIMUM NUMBER OF PANELS IN A COMPOSITE RULE FOR
C A SINGLE SUB-ARC ON THE BOUNDARY)
C
C MQUPH - INTEGER
C THE MAXIMUM NUMBER OF QUADRATURE POINTS ALLOWED
C IN THE FINAL GLOBAL RULE. (THE VALUE OF THIS
C ARGUMENT IS LINKED TO THOSE OF ARGUMENTS NQPTS
C AND IBNDS(1) PREVIOUSLY SUPPLIED TO JAPHYC VIA
C MQUPH <= (MQIN1-1)*NQPTS*IBNDS(1))
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE.
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS TO BE
C MAPPED TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN.
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC.
C
C RWORK - REAL ARRAY
C A WORKING VECTOR OF SIZE AT LEAST MQIN1.
C
C CHNL - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILE pq.
C
C ON EXIT
C IQUPH - INTEGER ARRAY
C AN INTEGER VECTOR OF SIZE AT LEAST 2*IBNDS(1) + 4,
C WHERE IBNDS(1) (=IGEOM(4)) IS THE VALUE PREVIOUSLY
C SUPPLIED TO JAPHYC; IQUPH STORES POINTERS TO
C ACCESS RQUPH AND ZQUPH.
C
C RQUPH - REAL ARRAY
C A REAL VECTOR OF SIZE AT LEAST 3*MQUPH + 1; STORES
C THE REAL QUADRATURE DATA.
C
C ZQUPH - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST MQUPH + 1;
C STORES THE QUADRATURE POINTS ON THE PHYSICAL
C BOUNDARY.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINE JAPHYC HAS SUCCESSFULLY EXECUTED, AND THAT SOME
C INPUT ARGUMENTS FOR GQPHYC ARE OUTPUT VALUES FROM JAPHYC.
C - THE GLOBAL QUADRATURE DATA ARE AUTOMATICALLY OUTPUT ON THE
C FILE pq, WHERE IS COLLECTED FROM THE FILE
C jbnm PREVIOUSLY CREATED BY JAPHYC.
C - A SUMMARY LISTING OF ACTIONS TAKEN IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOEF,BCOEF,DGPOL,FACTR,H0VAL,HALEN,JACIN,JATYP,LOSUB,
+LQSBF,MIDPT,NPPQF,PARNT,QUPTS,QUWTS,SOLUN,TPPQF,TRRAD,VTARG,WPPQF,
+ZPPQF
INTEGER MNEQN,MNSUA,NARCS,NEQNS,NINTS,NJIND,NQPTS,TNGQP,TNPQP,
+TNSUA
REAL DELTA,LGTOL,SUPER,THET0,TOLOU
COMPLEX CT
C
PARAMETER(DELTA=2E-1,NINTS=5)
EXTERNAL POPQF1,OUPTPQ,WRHEAD,WRTAIL
C
C**** WRITE HEADING TO STANDARD OUTPUT CHANNEL
C
CALL WRHEAD(2,0)
C
NARCS=ISNPH(1)
NQPTS=ISNPH(2)
TNSUA=ISNPH(3)
NEQNS=ISNPH(4)
MNSUA=ISNPH(5)
MNEQN=ISNPH(6)
NJIND=NARCS+1
TNGQP=NJIND*NQPTS
SUPER=RGEOM(1)
LGTOL=RGEOM(2)
C
IQUPH(2)=TNSUA
IQUPH(3)=MNSUA
IQUPH(4)=MQUPH
C
C**** COPY POINTERS FROM JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
C**** SET UP POINTERS FOR QUADRATURE DATA.
C
LQSBF=5
NPPQF=MNSUA+5
TPPQF=2
TRRAD=MQUPH+2
WPPQF=2*MQUPH+2
FACTR=1
ZPPQF=2
C
RQUPH(1)=RSNPH(SOLUN+NEQNS-1)
C
WRITE(*,10) 'QUADRATURE RULES STARTED:'
10 FORMAT(A45)
CALL POPQF1(IQUPH(NPPQF),IQUPH(LQSBF),TNPQP,TOLOU,RQUPH(TPPQF),
+RQUPH(TRRAD),RQUPH(WPPQF),ZQUPH(ZPPQF),MQUPH,MQIN1,NARCS,NINTS,
+NQPTS,TNSUA,ISNPH(DGPOL),ISNPH(JATYP),ISNPH(LOSUB),IGEOM(PARNT),
+DELTA,LGTOL,RSNPH(ACOEF),RSNPH(BCOEF),RSNPH(H0VAL),RGEOM(HALEN),
+RSNPH(JACIN),RGEOM(MIDPT),RSNPH(QUPTS),RSNPH(QUWTS),RSNPH(SOLUN),
+RWORK,IER)
WRITE(*,10) 'QUADRATURE RULES DONE:'
C
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
IQUPH(1)=TNPQP
C
C**** SET UP THE CONSTANT FACTOR FOR THE MAPPING FORMULA
C
THET0=RGEOM(VTARG)
IF (INTER) THEN
ZQUPH(FACTR)=CMPLX(COS(THET0),SIN(THET0))
ELSE
ZQUPH(FACTR)=(1E+0,0E+0)
CALL DMPHYC(1,CENTR,CT,INTER,CENTR,IGEOM,RGEOM,ISNPH,RSNPH,
+ IQUPH,RQUPH,ZQUPH,.TRUE.,IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
CT=CMPLX(RQUPH(1),THET0-AIMAG(LOG(CT)))
ZQUPH(FACTR)=CEXP(CT)
ENDIF
C
CALL OUPTPQ(IQUPH,RQUPH,ZQUPH,CHNL)
999 CONTINUE
C
C**** WRITE CLOSING MESSAGE TO STANDARD OUTPUT CHANNEL
C
CALL WRTAIL(2,0,IER)
C
END
SUBROUTINE HEADER(TXT,REDD,CHNL)
INTEGER CHNL
CHARACTER TXT*6,REDD*6
C
C LOCAL VARIABLES
C
REAL PI
CHARACTER LINE*72,TAB6*6,FMT*16
PARAMETER(TAB6=' ')
C
LINE=TAB6//'COMPLEX FUNCTION '//TXT//'(IA,TT)'
WRITE(CHNL,'(A36)') LINE
C
LINE=TAB6//'IMPLICIT REAL(A-H,O-S),INTEGER(I-N),COMPLEX(T-Z)'
WRITE(CHNL,'(A54)') LINE
C
PI=4E+0*ATAN(1E+0)
FMT='(A20,'//REDD//',A15)'
WRITE(CHNL,FMT) ' PARAMETER (PI=',PI,',UI=(0.0,1.0))'
WRITE(CHNL,'(A1)') 'C'
C
END
SUBROUTINE ICOQR1(NARCS,NJIND,NQPTS,MDGPO,MQIN1,AQTOL,QUPTS,QUWTS,
+JACIN,MIDPT,HALEN,ACOEF,BCOEF,H0VAL,COLSC,NQUAD,LOQSB,QCOMX,
+QCOMW,MNQUA,TOLOU,MCQER,XENPT,XIVAL,XIDST,IER)
INTEGER NARCS,NJIND,NQPTS,MDGPO,MQIN1,IER,NQUAD(*),LOQSB(*),
+MNQUA
REAL AQTOL,QUPTS(*),QUWTS(*),JACIN(*),MIDPT(*),HALEN(*),ACOEF(*),
+BCOEF(*),H0VAL(*),COLSC(*),QCOMX(*),QCOMW(*),TOLOU(*),XENPT(*),
+XIDST(*),MCQER
COMPLEX XIVAL(*)
C
C THE MAIN PURPOSE OF THIS ROUTINE IS TO SET UP THE ABSCISSAE
C (QCOMX) AND WEIGHTS (QCOMW) FOR THE COMPOSITE GAUSSIAN RULES
C FOR THE ESTIMATION OF
C
C INTEGRAL [(1+X)**BETA*P(X,I)*LOG|ZZ-X|*dX], I=0,1,...,MDGPO.
C -1<=X<=1 J=1,NZZ
C
C HERE P(.,I) IS THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE I
C ASSOCIATED WITH THE WEIGHT (1+X)**BETA AND ZZ IS ANY COLLOCATION
C POINT PREIMAGE NOT ON [-1,1]. BETA TAKES ON THE VARIOUS VALUES
C DEFINED BY ARRAY JACIN. THE ROUTINE ALSO COMPUTES
C
C NQUAD - NQUAD(I) IS THE NUMBER OF QUADRATURE POINTS IN THE
C COMPOSITE RULE FOR BETA=JACIN(I).
C LOQSB - THE ABSCISSAE AND WEIGHTS OF THE COMPOSITE RULE FOR
C BETA=JACIN(I) ARE STORED IN ARRAYS QCOMX AND QCOMW IN
C THE POSITIONS LOQSB(I) TO LOQSB(I)+NQUAD(I)-1 INCLUSIVE.
C XIDST,
C XIVAL - XIVAL(2*I-1) STORES THE COLLOCATION PREIMAGE THOUGHT
C TO BE NEAREST TO -1 AND XIDST(2*I-1) STORES ITS DISTANCE
C FROM -1; SIMILARLY, XIVAL(2*I) STORES THE PREIMAGE
C THOUGHT TO BE NEAREST TO +1 AND XIDST(2*I) ITS DISTANCE
C FROM +1. THE PREIMAGES ARE WITH RESPECT TO
C THE PARAMETRIC FUNCTIONS DEFINING THE SUBARCS WHICH
C MEET AT THE PHYSICAL CORNER WHERE BETA=JACIN(I).
C TOLOU - TOLOU(I) IS THE ESTIMATED MAXIMUM ERROR OVER ALL
C COLLOCATION POINTS IN USING THE COMPOSITE RULE
C FOR BETA=JACIN(I).
C MCQRE - THE INFINITY NORM OF TOLOU.
C IER - IER=0 FOR NORMAL TERMINATION.
C IER=9 THE REQUIRED TOTAL NUMBER OF COMPOSITE QUADRATURE
C POINTS EXCEEDS THE LIMIT MNQUA.
C
C
C LOCAL VARIABLES
C
INTEGER I,J,K,J0,J1,J2,J3,JI,JI0,JI1,HI,LO,QINTS
REAL BETA,H1,H2,T0,T1,T2,T3,SUM1,RR,RRB,MEAN,RXI,IXI,DST(4),R1MACH
COMPLEX ONE,Z0,Z1,Z2,Z3,XI(4),PARFUN,DPARFN,GT
PARAMETER (ONE=(1E+0,0E+0))
EXTERNAL DPARFN,PARFUN,R1MACH,SUBIN7
C
HI=0
DO 50 JI=1,NARCS
C
C AT THE JI'TH CORNER, THE ANALYTIC ARC IN THE BACKWARDS DIRECTION
C IS THE JI0'TH, IN THE FORWARDS DIRECTION IT IS THE JI'TH AND THE
C ONE BEYOND THAT IS THE JI1'TH. THE FOUR SUBARCS ON THE JI0'TH
C AND JI'TH ANALYTIC ARCS ARE THE J0'TH, J1'TH, J2'TH AND J3'TH,
C STARTING AT THE BEGINING OF ARC JI0 AND ENDING AT THE END OF ARC
C JI.
C
BETA=JACIN(JI)
LO=(JI-1)*NQPTS+1
J2=2*JI-1
J3=J2+1
IF (JI .EQ. 1) THEN
JI0=NARCS
J1=2*NARCS
ELSE
JI0=JI-1
J1=J2-1
ENDIF
J0=J1-1
IF (JI .EQ. NARCS) THEN
JI1=1
ELSE
JI1=JI+1
ENDIF
C
C NEXT WE FIX THE LOCAL PARAMETER VALUES OF THE COLLOCATION
C POINTS NEAREST TO SUBARCS J1 AND J2. FOR SUBARC J1 THE NEAR
C POINTS HAVE LOCAL PARAMETER VALUES T0 ON J0 AND T2 ON J2. FOR
C SUBARC J2 THE NEAR POINTS HAVE LOCAL PARAMETER VALUES T1 ON J1
C AND T3 ON J3.
C
T0=QUPTS(JI0*NQPTS)
T2=QUPTS(LO)
T1=-T2
T3=-QUPTS(JI1*NQPTS)
C
C NOW CONVERT THESE LOCAL PARAMETER VALUES FOR THE SUBARCS TO
C GLOBAL PARMETER VALUES FOR THE MAIN ARCS JI0 AND JI.
C
T0=MIDPT(J0)+HALEN(J0)*T0
H1=HALEN(J1)
T1=MIDPT(J1)+H1*T1
H2=HALEN(J2)
T2=MIDPT(J2)+H2*T2
T3=MIDPT(J3)+HALEN(J3)*T3
C
C NOW COMPUTE THE POSITIONS OF THE FOUR NEAR POINTS ON THE
C PHYSICAL BOUNDARY.
C
Z0=PARFUN(JI0,CMPLX(T0))
Z1=PARFUN(JI0,CMPLX(T1))
Z2=PARFUN(JI,CMPLX(T2))
Z3=PARFUN(JI,CMPLX(T3))
C
C FIND THE APPROXIMATE PARAMETRIC PREIMAGE OF Z0 WRT SUBARC J1.
C
GT=CMPLX(MIDPT(J1)-H1)
XI(1)=-ONE+(Z0-PARFUN(JI0,GT))/DPARFN(JI0,GT)/H1
C
C CONVERT TO PARAMETRIC PREIMAGE WRT SUBARC J2.
C
XI(1)=-XI(1)
C
C FIND THE APPROXIMATE PARAMETRIC PREIMAGE OF Z1 WRT SUBARC J2.
C
XI(2)=-ONE+(Z1-PARFUN(JI,-ONE))/DPARFN(JI,-ONE)/H2
C
C FIND THE APPROXIMATE PARAMETRIC PREIMAGE OF Z2 WRT SUBARC J1.
C
XI(3)=ONE+(Z2-PARFUN(JI0,ONE))/DPARFN(JI0,ONE)/H1
C
C CONVERT TO PARAMETRIC PREIMAGE WRT SUBARC J2.
C
XI(3)=-XI(3)
C
C FIND THE APPROXIMATE PARAMETRIC PREIMAGE OF Z3 WRT SUBARC J2.
C
GT=CMPLX(MIDPT(J2)+H2)
XI(4)=ONE+(Z3-PARFUN(JI,GT))/DPARFN(JI,GT)/H2
C
C SELECT THE PREIMAGE NEAREST -1 AND THE ONE NEAREST +1.
C
DO 10 J=1,4
RXI=REAL(XI(J))
IXI=AIMAG(XI(J))
IF (-1E+0 .LE. RXI .AND. RXI .LE. 1E+0) THEN
DST(J)=ABS(IXI)
ELSE IF (RXI .LT. -1E+0) THEN
DST(J)=ABS(XI(J)+ONE)
ELSE
DST(J)=ABS(XI(J)-ONE)
ENDIF
10 CONTINUE
C
IF (DST(2) .LT. DST(3)) THEN
XIVAL(J2)=XI(2)
XIDST(J2)=DST(2)
ELSE
XIVAL(J2)=XI(3)
XIDST(J2)=DST(3)
ENDIF
C
IF (DST(1) .LT. DST(4)) THEN
XIVAL(J3)=XI(1)
XIDST(J3)=DST(1)
ELSE
XIVAL(J3)=XI(4)
XIDST(J3)=DST(4)
ENDIF
C
C NOW DETERMINE THE NUMBER AND LOCATION OF THE QUADRATURE
C SUBINTERVALS NEEDED TO MEET THE TOLERANCE AT XIVAL(J2) AND
C XIVAL(J3).
C
CALL SUBIN7(XIVAL(J2),2,BETA,MDGPO,NQPTS,ACOEF(LO),BCOEF(LO),
+ H0VAL(JI),COLSC(LO),AQTOL,TOLOU(JI),XENPT,QINTS,MQIN1,IER)
IF (IER .GT. 0) THEN
RETURN
ENDIF
C
C SET UP THE COMPOSITE RULE ABSCISSAE AND WEIGHTS FOR THIS
C JACOBI INDEX.
C
NQUAD(JI)=QINTS*NQPTS
LOQSB(JI)=HI+1
IF (HI+NQUAD(JI) .GT. MNQUA) THEN
IER=9
RETURN
ENDIF
SUM1=BETA+1E+0
K=HI
DO 40 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
LO=LO-1
DO 20 J=1,NQPTS
K=K+1
QCOMX(K)=MEAN+RR*QUPTS(LO+J)
QCOMW(K)=RRB*QUWTS(LO+J)
20 CONTINUE
ELSE
LO=NARCS*NQPTS
DO 30 J=1,NQPTS
K=K+1
QCOMX(K)=MEAN+RR*QUPTS(LO+J)
QCOMW(K)=RR*QUWTS(LO+J)*(1E+0+QCOMX(K))**BETA
30 CONTINUE
ENDIF
40 CONTINUE
HI=HI+NQUAD(JI)
50 CONTINUE
C
C ASSIGN INITIAL DATA FOR LEGENDRE ARCS
C
I=2*NJIND
RR=R1MACH(2)
XIDST(I)=RR
XIDST(I-1)=RR
XIVAL(I)=CMPLX(RR)
XIVAL(I-1)=CMPLX(RR)
LOQSB(NJIND)=HI+1
NQUAD(NJIND)=0
C
C FIND THE MAXIMUM OF THE TOLOU ELEMENTS
C
MCQER=0E+0
DO 60 I=1,NARCS
MCQER=MAX(MCQER,TOLOU(I))
60 CONTINUE
C
C NORMAL TERMINATION
C
IER=0
C
END
CHARACTER*66 FUNCTION IERTXT(IER)
INTEGER IER
C
C**** SUPPLY ERROR MESSAGE TEXT FOR ERROR NUMBER IER
C
IF (IER.EQ.0) THEN
IERTXT=' '
C
ELSE IF (IER.EQ.1) THEN
IERTXT='PARAMETER IBNDS(1) IS TOO SMALL AT START OF JAPHYC'
C
ELSE IF (IER.EQ.2) THEN
IERTXT='PARAMETER IBNDS(2) IS TOO SMALL AT START OF JAPHYC'
C
ELSE IF (IER.EQ.3) THEN
IERTXT='NQPTS < 1 AT START OF JAPHYC'
C
ELSE IF (IER.EQ.4) THEN
IERTXT='FAILURE TO CONVERGE IN EIGSYS; CAN''T SET UP BASIC QUADRAT
+URE RULES'
C
ELSE IF (IER.EQ.5) THEN
IERTXT='PARAMETER MNQPT IN IGNLVL MUST BE INCREASED TO AT LEAST NQ
+PTS'
C
ELSE IF (IER.EQ.6) THEN
IERTXT='FAILURE TO CONVERGE IN IMTQLH; CAN''T SET UP IGNORE LEVELS
+'
C
ELSE IF (IER.EQ.7) THEN
IERTXT='FAILURE TO CONVERGE IN IMTQLH; CAN''T SET UP COLLOCATION P
+OINTS'
C
ELSE IF (IER.EQ.8) THEN
IERTXT='ARGUMENT MNEQN IS TOO SMALL AT START OF JAPHYC'
C
ELSE IF (IER.EQ.9) THEN
IERTXT='PARAMETER IBNDS(4) IS TOO SMALL AT START OF JAPHYC'
C
ELSE IF (IER.EQ.10) THEN
IERTXT='PARAMETER NMAX IN SUBIN7 MUST BE INCREASED TO AT LEAST 2*N
+QPTS'
C
ELSE IF (IER.EQ.11) THEN
IERTXT='PARAMETER IBNDS(3) IS TOO SMALL AT START OF JAPHYC'
C
ELSE IF (IER.EQ.12) THEN
IERTXT='PARAMETER NC IN DEJAC7 AND DELEG7 MUST BE INCREASED'
C
ELSE IF (IER.EQ.13) THEN
IERTXT='PARAMETER NR IN DEJAC7 AND DELEG7 MUST BE >= (NQPTS -1)'
C
ELSE IF (IER.EQ.14) THEN
IERTXT='A CORNER ANGLE IS TOO SMALL; MAY CAUSE OVERFLOW IN GAMMA F
+UNCTION'
C
ELSE IF (IER.EQ.15) THEN
IERTXT='SINGULAR COLLOCATION MATRIX'
C
ELSE IF (IER.EQ.16) THEN
IERTXT='COLLOCATION MATRIX IS EFFECTIVELY SINGULAR'
C
ELSE IF (IER.EQ.17) THEN
IERTXT='NUMBER OF SUBARCS EXCEEDS IBNDS(1) DURING REFINEMENT'
C
ELSE IF (IER.EQ.18) THEN
IERTXT='NUMBER OF EQUATIONS EXCEEDS MNEQN DURING REFINEMENT'
C
ELSE IF (IER.EQ.19) THEN
IERTXT='TOTAL NUMBER OF QUADRATURE PTS EXCEEDS IBNDS(4) DURING REF
+INEMENT'
C
ELSE IF (IER.EQ.20) THEN
IERTXT='NUMBER OF QUADRATURE PANELS EXCEEDS IBNDS(3) DURING REFINE
+MENT'
C
ELSE IF (IER.EQ.21) THEN
IERTXT='FAILURE TO CONVERGE IN IMTQLH; CAN''T SET UP TEST POINTS'
C
ELSE IF (IER.EQ.22) THEN
IERTXT='ARGUMENT MQUPH OF GQPHYC MUST BE INCREASED'
C
ELSE IF (IER.EQ.23) THEN
IERTXT='PARAMETER MNCOF IN POPQF1 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.24) THEN
IERTXT='NUMBER OF QUADRATURE PANELS EXCEEDS MQIN1 IN GQPHYC'
C
ELSE IF (IER.EQ.25) THEN
IERTXT='PARAMETER MNXI IN DEPPJ8 AND DEPPL8 MUST BE INCREASED'
C
ELSE IF (IER.EQ.26) THEN
IERTXT='PARAMETER MAXNZ IN DEPPJ9 AND DEPPL9 MUST BE INCREASED'
C
ELSE IF (IER.EQ.27) THEN
IERTXT='PARAMETER MXNQD IN PHTCA1 MUST BE INCREASED'
C
ELSE IF (IER.EQ.28) THEN
IERTXT='PARAMETER MXCOF IN PHTCA1 MUST BE INCREASED'
C
ELSE IF (IER.EQ.29) THEN
IERTXT='PARAMETER MQIN1 IN PHTCA1 MUST BE INCREASED'
C
ELSE IF (IER.EQ.30) THEN
IERTXT='PARAMETER MNDG IN JCFIM5 MUST BE INCREASED'
C
ELSE IF (IER.EQ.31) THEN
IERTXT='PARAMETER MNQD IN JCFIM5 MUST BE INCREASED'
C
ELSE IF (IER.EQ.32) THEN
IERTXT='ARGUMENT IBNDS(2) SUPPLIED TO JACANP MUST BE INCREASED'
C
ELSE IF (IER.EQ.33) THEN
IERTXT='ARGUMENT IBNDS(1) SUPPLIED TO JACANP MUST BE INCREASED'
C
ELSE IF (IER.EQ.34) THEN
IERTXT='FN HAS SAME SIGN AT INTERVAL ENDS IN BISNEW; CAN''T SOLVE
+BCF EQN'
C
ELSE IF (IER.EQ.35) THEN
IERTXT='DERIVATIVE OF BCF IS ZERO IN BISNEW; CAN''T SOLVE BCF EQN'
C
ELSE IF (IER.EQ.36) THEN
IERTXT='ELEMENT OF ARGUMENT ARRAY SVAL IN RHOFN IS +-1; CAN''T CON
+TINUE'
C
ELSE IF (IER.EQ.37) THEN
IERTXT='PARAMETER MXNQD IN CINRAD MUST BE INCREASED'
C
ELSE IF (IER.EQ.38) THEN
IERTXT='PARAMETER MXCOF IN CINRAD MUST BE INCREASED'
C
ELSE IF (IER.EQ.39) THEN
IERTXT='CENTRE POINT IS PATHOLOGICALLY CLOSE TO BOUNDARY;CAN''T CO
+NTINUE'
C
ELSE IF (IER.EQ.40) THEN
IERTXT='PARAMETER MQIN1 IN CINRAD MUST BE INCREASED'
C
ELSE IF (IER.EQ.41) THEN
IERTXT='ARGUMENT MQUCA OF GQCANP MUST BE INCREASED'
C
ELSE IF (IER.EQ.42) THEN
IERTXT='PARAMETER MNCOF IN POPQG1 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.43) THEN
IERTXT='NUMBER OF QUADRATURE PANELS EXCEEDS MQIN1 IN GQCANP'
C
ELSE IF (IER.EQ.44) THEN
IERTXT='PARAMETER MNCOF IN BMPHC1 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.45) THEN
IERTXT='ARGUMENTS IARC, PHYPT OF BMPHYC DON''T DEFINE A BOUNDARY P
+OINT'
C
ELSE IF (IER.EQ.46) THEN
IERTXT='PARAMETER MNCOF IN BMCAP1 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.47) THEN
IERTXT='PARAMETER MXNQD IN CATPH4 MUST BE INCREASED'
C
ELSE IF (IER.EQ.48) THEN
IERTXT='PARAMETER MNCOF IN CATPH4 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.49) THEN
IERTXT='PARAMETER MQIN1 IN CATPH4 MUST BE INCREASED'
C
ELSE IF (IER.EQ.50) THEN
IERTXT='PARAMETER MXCOF IN DIAGN3 MUST BE >= NQPTS'
C
ELSE IF (IER.EQ.51) THEN
IERTXT='NON-ANALYTIC ARC DETECTED IN DIAGN3'
C
ELSE IF (IER.EQ.52) THEN
IERTXT='PARAMETER MAXSA IN CNDPLT MUST BE INCREASED'
C
ELSE IF (IER.EQ.53) THEN
IERTXT='OVERFLOW EXPECTED IN IGNLVL; A CORNER ANGLE IS TOO SMALL'
C
ELSE IF (IER.EQ.54) THEN
IERTXT='PARAMETER MXCO IN AXION1 MUST BE INCREASED'
C
ELSE IF (IER.EQ.55) THEN
IERTXT='NARCS ISN''T AN INTEGER MULTIPLE OF THE ORDER OF THE SYMME
+TRY GROUP'
C
ELSE IF (IER.EQ.56) THEN
IERTXT='CENTRE OF SYMMETRY IS PATHOLOGICALLY CLOSE TO LAST POINT O
+N FBS'
C
ELSE IF (IER.EQ.57) THEN
IERTXT='CENTRE OF SYMMETRY IS PATHOLOGICALLY CLOSE TO FIRST POINT
+ON FBS'
C
ELSE IF (IER.EQ.58) THEN
IERTXT='NUMBER OF ARCS IS TOO BIG; INCREASE PARAMETER MNARC IN PAR
+GEN'
C
ELSE IF (IER.EQ.59) THEN
IERTXT='NUMBER OF ARCS IS TOO BIG; INCREASE PARAMETER MNARC IN TST
+PLT'
C
ELSE IF (IER.EQ.60) THEN
IERTXT='NON-ANALYTIC ARC (DPARFN=(0.,0.)) DETECTED IN TSTPLT'
C
ELSE
IERTXT='UNRECOGNISED ERROR NUMBER IN IERTXT ROUTINE !!'
C
ENDIF
C
END
SUBROUTINE IGNLVL(RIGLL,COLSC,ACOEF,BCOEF,H0VAL,JACIN,NJIND,NQPTS,
+IER)
INTEGER IER,NJIND,NQPTS
REAL ACOEF(*),BCOEF(*),H0VAL(*),JACIN(*),RIGLL(*),COLSC(*)
C
C TO SET UP THE A PRIORI COLUMN SCALE FACTORS USING THE COEFFICIENT
C IGNORE LEVELS OBTAINED FROM BOUNDARY CORRESPONDENCE FUNCTION
C REPRESENTATION FOR THE BOUNDARY MAP; SEE RB #50 P141 ET SEQ.
C COMBINE WITH A PRIORI COLUMN SCALE FACTORS COLSC IN THE CASE OF
C SOLVING SYMM'S EQUATION.
C
C IER=0 - NORMAL EXIT
C IER=5 - LOCAL PARAMETER MNQPT MUST BE INCREASED TO AT LEAST THE
C VALUE OF NQPTS
C IER=6 - FAILURE OF IMTQLH EIGENVALUE ROUTINE
C IER=53- A CORNER ANGLE IS SO SMALL THAT IT MAY CAUSE OVERFLOW
C
C LOCAL VARIABLES
C
INTEGER JT,K,K1,LO,N,MNQPT
REAL B1,B2,BETA,EXPON,H1VAL,LGTWO,OFLOW,PI,R1MACH,RH,RH1,SUP,T
LOGICAL SYMM
PARAMETER (MNQPT=20)
REAL A1COF(MNQPT),B1COF(MNQPT),DIAG(MNQPT),PP(MNQPT),SDIAG(MNQPT)
EXTERNAL ASONJ7,IMTQLH,JAPAR7,R1MACH
C
IF (NQPTS.GT.MNQPT) THEN
IER=5
RETURN
ENDIF
C
IF (COLSC(1) .LE. 0E+0) THEN
SYMM=.FALSE.
ELSE
SYMM=.TRUE.
ENDIF
C
K1=0
PI=4E+0*ATAN(1E+0)
LGTWO=LOG(2E+0)
OFLOW=LOG(R1MACH(2))
DO 40 JT=1,NJIND
BETA=JACIN(JT)
B1=BETA+1E+0
B2=BETA+2E+0
RH=SQRT(H0VAL(JT))
CALL ASONJ7(1E+0,B1,A1COF,B1COF,H1VAL,NQPTS)
LO=(JT-1)*NQPTS
K1=K1+1
C
C**** COMPUTE THE QUANTITY
C**** PI*2E+0**B2/B1/RH
C**** BUT CHECK FOR POSSIBLE OVERFLOW
C
EXPON=B2*LGTWO+LOG(PI/B1/RH)
IF (EXPON.GE.OFLOW) THEN
IER=53
RETURN
ELSE
IF (SYMM) THEN
RIGLL(K1)=EXP(EXPON)*COLSC(K1)
ELSE
RIGLL(K1)=EXP(EXPON)
ENDIF
ENDIF
C
IF (NQPTS.EQ.1) THEN
GOTO 40
ENDIF
C
RH1=SQRT(H1VAL)
K1=K1+1
C
C**** COMPUTE THE QUANTITY
C**** PI*2E+0**(B2+1E+0)*B1**B1/RH1/B2**(B2+5E-1)
C**** BUT CHECK FOR POSSIBLE OVERFLOW
C
EXPON=(B2+1E+0)*LGTWO+B1*LOG(B1)-(B2+5E-1)*LOG(B2)+LOG(PI/RH1)
IF (EXPON.GE.OFLOW) THEN
IER=53
RETURN
ELSE
IF (SYMM) THEN
RIGLL(K1)=EXP(EXPON)*COLSC(K1)
ELSE
RIGLL(K1)=EXP(EXPON)
ENDIF
ENDIF
C
DO 30 N=2,NQPTS-1
C
C FIND THE ZEROES OF THE JACOBI POLYNOMIAL OF DEGREE N FOR
C WEIGHT (1+X)**BETA
C
DO 10 K=1,N
DIAG(K)=BCOEF(LO+K)
IF (K.EQ.1) THEN
SDIAG(K)=0E+0
ELSE
SDIAG(K)=ACOEF(LO+K-1)
ENDIF
10 CONTINUE
C
CALL IMTQLH(N,DIAG,SDIAG,IER)
IF (IER.GT.0) THEN
IER=6
RETURN
ENDIF
C
SUP=0E+0
DO 20 K=1,N
T=DIAG(K)
PP(1)=1E+0/RH1
CALL JAPAR7(PP,T,A1COF,B1COF,N)
T=(1E+0-T)*(1E+0+T)**B1*PP(N)
SUP=MAX(SUP,ABS(T))
20 CONTINUE
C
K1=K1+1
IF (SYMM) THEN
RIGLL(K1)=2E+0*PI*SUP*COLSC(K1)/SQRT(N*(N+B1))
ELSE
RIGLL(K1)=2E+0*PI*SUP/SQRT(N*(N+B1))
ENDIF
30 CONTINUE
40 CONTINUE
C
C NORMAL EXIT
C
IER=0
C
END
SUBROUTINE INPTCA(ISNCA,RSNCA,ZSNCA,CHNL)
C
INTEGER CHNL
INTEGER ISNCA(*)
REAL RSNCA(*)
COMPLEX ZSNCA(*)
C
C ......................................................................
C
C 1. INPTCA
C READS IN DATA.
C
C 2. PURPOSE
C TO READ IN THE DATA ARRAYS ISNCA, RSNCA AND ZSNCA FROM THE
C FILE ca PREVIOUSLY CREATED BY JACANP. THE VALUE
C IS READ FROM THE FILE jbnm.
C
C 3. CALLING SEQUENCE
C CALL INPTCA(ISNCA,RSNCA,ZSNCA,CHNL)
C
C PARAMETERS
C ON ENTRY
C CHNL - INTEGER
C DEFINES AN INPUT CHANNEL THAT MAY BE USED FOR
C READING THE FILE ca.
C
C ON EXIT
C ISNCA - INTEGER ARRAY
C THE INTEGER VECTOR ISNCA PRVIOUSLY SET UP BY
C JACANP, READ FROM ca.
C
C RSNCA - REAL ARRAY
C THE REAL VECTOR RSNCA PRVIOUSLY SET UP BY
C JACANP, READ FROM ca.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR ZSNCA PRVIOUSLY SET UP BY
C JACANP, READ FROM ca.
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOFC,AICOC,BCOFC,BFSNC,BICOC,COARG,DGPOC,H0VLC,HIVLC,I,
+JAINC,JTYPC,L,LSUBC,NJIND,PHPAS,PRNSA,QUPTC,QUWTC,SOLNC,SW,TNGQP,
+VARGC
REAL EPS,R1MACH
CHARACTER IFORM(6)*5,RFORM(6)*9,JBNM*4,IFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(6)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)','(5I6)','(6I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3','4','5','6'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE INPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
IFL=JBNM(1:L)//'ca'
OPEN(CHNL,FILE=IFL)
C
C**** SET UP REAL READ FORMATS
C
DO 5 I=1,6
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START INPUT
C
READ(CHNL,IFORM(6)) (ISNCA(I),I=1,6)
C
NJIND=ISNCA(1)+1
TNGQP=ISNCA(2)*NJIND
C
C**** SET UP POINTERS, AS IN JACANP
C
DGPOC=7
JTYPC=ISNCA(5)+7
LSUBC=2*ISNCA(5)+7
PRNSA=3*ISNCA(5)+7
ACOFC=2
BCOFC=TNGQP+2
AICOC=2*TNGQP+2
BICOC=3*TNGQP+2
QUPTC=4*TNGQP+2
QUWTC=5*TNGQP+2
H0VLC=6*TNGQP+2
HIVLC=NJIND+6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
COARG=3*NJIND+6*TNGQP+2
PHPAS=4*NJIND+6*TNGQP+2
VARGC=ISNCA(5)+4*NJIND+6*TNGQP+2
BFSNC=2
SOLNC=ISNCA(6)+2
C
DO 10 I=1,ISNCA(3)
READ(CHNL,IFORM(4)) ISNCA(DGPOC+I-1),ISNCA(JTYPC+I-1),
+ ISNCA(LSUBC+I-1),ISNCA(PRNSA+I-1)
10 CONTINUE
C
READ(CHNL,RFORM(1)) RSNCA(1)
C
DO 20 I=1,TNGQP
READ(CHNL,RFORM(6)) RSNCA(ACOFC+I-1),RSNCA(BCOFC+I-1),
+ RSNCA(AICOC+I-1),RSNCA(BICOC+I-1),
+ RSNCA(QUPTC+I-1),RSNCA(QUWTC+I-1)
20 CONTINUE
C
DO 30 I=1,NJIND
READ(CHNL,RFORM(4)) RSNCA(H0VLC+I-1),RSNCA(HIVLC+I-1),
+ RSNCA(JAINC+I-1),RSNCA(COARG+I-1)
30 CONTINUE
C
DO 40 I=1,ISNCA(3)+1
READ(CHNL,RFORM(2)) RSNCA(PHPAS+I-1),RSNCA(VARGC+I-1)
40 CONTINUE
C
READ(CHNL,RFORM(2)) ZSNCA(1)
C
DO 50 I=1,ISNCA(4)
READ(CHNL,RFORM(4)) ZSNCA(BFSNC+I-1),ZSNCA(SOLNC+I-1)
50 CONTINUE
C
CLOSE(CHNL)
C
END
SUBROUTINE INPTCQ(IQUCA,ZQUCA,CHNL)
C
INTEGER CHNL
INTEGER IQUCA(*)
COMPLEX ZQUCA(*)
C
C ......................................................................
C
C 1. INPTCQ
C READS IN DATA.
C
C 2. PURPOSE
C TO READ IN THE DATA ARRAYS IQUCA AND ZQUCA FROM THE
C FILE cq PREVIOUSLY CREATED BY GQCANP. THE VALUE
C IS READ FROM THE FILE jbnm.
C
C 3. CALLING SEQUENCE
C CALL INPTCQ(IQUCA,ZQUCA,CHNL)
C
C PARAMETERS
C ON ENTRY
C CHNL - INTEGER
C DEFINES AN INPUT CHANNEL THAT MAY BE USED FOR
C READING THE FILE cq.
C
C ON EXIT
C IQUCA - INTEGER ARRAY
C THE INTEGER VECTOR IQUCA PRVIOUSLY SET UP BY
C GQCANP, READ FROM cq.
C
C ZQUCA - COMPLEX ARRAY
C THE COMPLEX VECTOR ZQUCA PRVIOUSLY SET UP BY
C GQCANP, READ FROM cq.
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER I,L,LQSBG,NPPQG,SW,WPPQG,ZPPQG
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(2)*9,JBNM*4,IFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(2)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE INPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
IFL=JBNM(1:L)//'cq'
OPEN(CHNL,FILE=IFL)
C
C**** SET UP REAL READ FORMATS
C
DO 5 I=1,2
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START INPUT
C
READ(CHNL,IFORM(4)) (IQUCA(I),I=1,4)
C
C**** SET UP POINTERS FOR IQUCA AND ZQUCA, AS IN GQCANP
C
LQSBG=5
NPPQG=IQUCA(3)+5
WPPQG=2
ZPPQG=IQUCA(4)+2
C
DO 10 I=1,IQUCA(2)
READ(CHNL,IFORM(2)) IQUCA(LQSBG+I-1),IQUCA(NPPQG+I-1)
10 CONTINUE
C
DO 20 I=1,IQUCA(1)
READ(CHNL,RFORM(2)) ZQUCA(WPPQG+I-1)
20 CONTINUE
C
DO 30 I=1,IQUCA(1)
READ(CHNL,RFORM(2)) ZQUCA(ZPPQG+I-1)
30 CONTINUE
C
READ(CHNL,RFORM(2)) ZQUCA(1)
C
CLOSE(CHNL)
C
END
SUBROUTINE INPTGM(IGEOM,RGEOM,CENTR,INTER,CHNL)
C
INTEGER CHNL
INTEGER IGEOM(*)
REAL RGEOM(*)
COMPLEX CENTR
LOGICAL INTER
C
C ......................................................................
C
C 1. INPTGM
C READS IN DATA.
C
C 2. PURPOSE
C TO READ IN THE DATA ARRAYS IGEOM, RGEOM AND THE SCALARS
C CENTR, INTER FROM THE FILE gm PREVIOUSLY CREATED
C BY JAPHYC. THE VALUE IS READ FROM THE FILE jbnm.
C
C 3. CALLING SEQUENCE
C CALL INPTGM(IGEOM,RGEOM,CENTR,INTER,CHNL)
C
C PARAMETERS
C ON ENTRY
C CHNL - INTEGER
C DEFINES AN INPUT CHANNEL THAT MAY BE USED FOR
C READING THE FILE gm.
C
C ON EXIT
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC, READ FROM gm.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC,
C READ FROM gm.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE; READ FROM gm.
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS TO BE
C MAPPED TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN.
C READ FROM gm.
C
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER HALEN,I,L,MIDPT,PARNT,SW,VTARG
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(2)*9,LFORM*7,JBNM*4,IFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(2)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/LFORM/'(1L1)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE INPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
IFL=JBNM(1:L)//'gm'
OPEN(CHNL,FILE=IFL)
C
C**** SET UP REAL READ FORMATS
C
DO 5 I=1,2
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START INPUT
C
READ(CHNL,IFORM(4)) (IGEOM(I), I=1,4)
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=IGEOM(4)+3
VTARG=2*IGEOM(4)+3
C
DO 10 I=1,IGEOM(3)
READ(CHNL,IFORM(1)) IGEOM(PARNT+I-1)
10 CONTINUE
C
READ(CHNL,RFORM(2)) (RGEOM(I), I=1,2)
C
DO 20 I=1,IGEOM(3)
READ(CHNL,RFORM(2)) RGEOM(HALEN+I-1),RGEOM(MIDPT+I-1)
20 CONTINUE
C
DO 30 I=1,IGEOM(3)+1
READ(CHNL,RFORM(1)) RGEOM(VTARG+I-1)
30 CONTINUE
C
READ(CHNL,RFORM(2)) CENTR
READ(CHNL,LFORM) INTER
C
CLOSE(CHNL)
C
END
SUBROUTINE INPTPH(ISNPH,RSNPH,CHNL)
INTEGER CHNL
INTEGER ISNPH(*)
REAL RSNPH(*)
C
C ......................................................................
C
C 1. INPTPH
C READS IN DATA.
C
C 2. PURPOSE
C TO READ IN THE DATA ARRAYS ISNPH, RSNPH FROM THE FILE
C ph PREVIOUSLY CREATED BY JAPHYC. THE VALUE IS
C READ FROM THE FILE jbnm.
C
C 3. CALLING SEQUENCE
C CALL INPTPH(ISNPH,RSNPH,CHNL)
C
C PARAMETERS
C ON ENTRY
C CHNL - INTEGER
C DEFINES AN INPUT CHANNEL THAT MAY BE USED FOR
C READING THE FILE ph.
C
C ON EXIT
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC, READ FROM ph.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC,
C READ FROM ph.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER ACOEF,BCOEF,AICOF,BICOF,DGPOL,JATYP,LOSUB,QUPTS,QUWTS,
+H0VAL,HIVAL,JACIN,ERARC,BCFSN,SOLUN
INTEGER I,L,NJIND,SW,TNGQP
REAL EPS,R1MACH
CHARACTER IFORM(6)*5,RFORM(6)*9,JBNM*4,IFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(6)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)','(5I6)','(6I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3','4','5','6'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE INPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
IFL=JBNM(1:L)//'ph'
OPEN(CHNL,FILE=IFL)
C
C**** SET UP REAL READ FORMATS
C
DO 5 I=1,6
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START INPUT
C
READ(CHNL,IFORM(6)) (ISNPH(I),I=1,6)
C
C**** SET UP POINTERS, AS IN JAPHYC
C
NJIND=ISNPH(1)+1
TNGQP=NJIND*ISNPH(2)
DGPOL=7
JATYP=ISNPH(5)+7
LOSUB=2*ISNPH(5)+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
ERARC=3*NJIND+6*TNGQP+1
BCFSN=ISNPH(5)+3*NJIND+6*TNGQP+1
SOLUN=ISNPH(6)+ISNPH(5)+3*NJIND+6*TNGQP+1
C
DO 10 I=1,ISNPH(3)
READ(CHNL,IFORM(3)) ISNPH(DGPOL+I-1),ISNPH(JATYP+I-1),
+ ISNPH(LOSUB+I-1)
10 CONTINUE
C
DO 20 I=1,TNGQP
READ(CHNL,RFORM(6)) RSNPH(ACOEF+I-1),RSNPH(BCOEF+I-1),
+ RSNPH(AICOF+I-1),RSNPH(BICOF+I-1),
+ RSNPH(QUPTS+I-1),RSNPH(QUWTS+I-1)
20 CONTINUE
C
DO 30 I=1,NJIND
READ(CHNL,RFORM(3)) RSNPH(H0VAL+I-1),RSNPH(HIVAL+I-1),
+ RSNPH(JACIN+I-1)
30 CONTINUE
C
DO 40 I=1,ISNPH(3)
READ(CHNL,RFORM(1)) RSNPH(ERARC+I-1)
40 CONTINUE
C
DO 50 I=1,ISNPH(4)
READ(CHNL,RFORM(2)) RSNPH(BCFSN+I-1),RSNPH(SOLUN+I-1)
50 CONTINUE
C
CLOSE(CHNL)
C
END
SUBROUTINE INPTPQ(IQUPH,RQUPH,ZQUPH,CHNL)
C
INTEGER CHNL
INTEGER IQUPH(*)
REAL RQUPH(*)
COMPLEX ZQUPH(*)
C
C ......................................................................
C
C 1. INPTPQ
C READS IN DATA.
C
C 2. PURPOSE
C TO READ IN THE DATA ARRAYS IQUPH, RQUPH AND ZQUPH FROM THE
C FILE pq PREVIOUSLY CREATED BY GQPHYC. THE VALUE
C IS READ FROM THE FILE jbnm.
C
C 3. CALLING SEQUENCE
C CALL INPTPQ(IQUPH,RQUPH,ZQUPH,CHNL)
C
C PARAMETERS
C ON ENTRY
C CHNL - INTEGER
C DEFINES AN INPUT CHANNEL THAT MAY BE USED FOR
C READING THE FILE pq.
C
C ON EXIT
C IQUPH - INTEGER ARRAY
C THE INTEGER VECTOR IQUPH PRVIOUSLY SET UP BY
C GQPHYC, READ FROM pq.
C
C RQUPH - REAL ARRAY
C THE REAL VECTOR RQUPH PRVIOUSLY SET UP BY
C GQPHYC, READ FROM pq.
C
C
C ZQUPH - COMPLEX ARRAY
C THE COMPLEX VECTOR ZQUPH PRVIOUSLY SET UP BY
C GQPHYC, READ FROM pq.
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 5 JUNE 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER FACTR,I,L,LQSBF,NPPQF,SW,TPPQF,TRRAD,WPPQF,ZPPQF
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(3)*9,JBNM*4,IFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(3)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE INPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
IFL=JBNM(1:L)//'pq'
OPEN(CHNL,FILE=IFL)
C
C**** SET UP REAL READ FORMATS
C
DO 5 I=1,3
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START INPUT
C
READ(CHNL,IFORM(4)) (IQUPH(I),I=1,4)
C
C**** SET UP QUADRATURE POINTERS, AS IN GQPHYC
C
LQSBF=5
NPPQF=IQUPH(3)+5
TPPQF=2
TRRAD=IQUPH(4)+2
WPPQF=2*IQUPH(4)+2
FACTR=1
ZPPQF=2
C
DO 10 I=1,IQUPH(2)
READ(CHNL,IFORM(2)) IQUPH(LQSBF+I-1),IQUPH(NPPQF+I-1)
10 CONTINUE
C
DO 20 I=1,IQUPH(1)
READ(CHNL,RFORM(3)) RQUPH(TPPQF+I-1),RQUPH(TRRAD+I-1),
+ RQUPH(WPPQF+I-1)
20 CONTINUE
C
READ(CHNL,RFORM(2)) ZQUPH(FACTR)
C
DO 30 I=1,IQUPH(1)
READ(CHNL,RFORM(2)) ZQUPH(ZPPQF+I-1)
30 CONTINUE
C
READ(CHNL,RFORM(1)) RQUPH(1)
C
CLOSE(CHNL)
C
END
SUBROUTINE INVJCO(SOLNC,A1COF,AA,ACOEF,ACOFC,B1COF,BB,BCFSN,BCOEF,
+BCOFC,BETA,BETAC,CENTR,CONST,DGPOC,DGPOL,H0VAL,H0VLC,H1VAL,HAANG,
+HALEN,IER,INTER,JACOF,JTYPC,MIDPT,NEWTL,NQUAD,PARNT,QUPTC,QUWTC,
+RHOVL,SJT,SJTC,SVAL,TOLIW,TVAL,WORK)
INTEGER DGPOC,DGPOL,IER,JTYPC,NQUAD,PARNT
REAL AA,BB,BETA,BETAC,CONST,H0VAL,H0VLC,H1VAL,HAANG,HALEN,MIDPT,
+NEWTL,SJT,SJTC,TOLIW
REAL A1COF(*),ACOEF(*),ACOFC(*),B1COF(*),BCFSN(*),BCOEF(*),
+BCOFC(*),JACOF(*),QUPTC(*),QUWTC(*),SVAL(*),TVAL(*),WORK(*)
COMPLEX CENTR
COMPLEX SOLNC(*),RHOVL(*)
LOGICAL INTER
C
C COMPUTES THE JACOBI COEFFICIENT VECTOR *SOLNC* FOR THE INVERSE
C DENSITY FUNCTION FOR THE PARTICULAR ARC SPECIFIED BY THE OTHER
C PARAMETERS AND USING THE *NQUAD* POINT RULE STORED IN *QUPTC* AND
C *QUWTS*.
C
C IER=0 - NORMAL EXIT
C
C LOCAL VARIABLES
C
INTEGER I,K
REAL LL,RRHS,UU
EXTERNAL BISNEW,RHOFN
C
DO 10 I=1,NQUAD
SVAL(I)=SJTC*QUPTC(I)
10 CONTINUE
C
C GET LOCAL PHYSICAL PARAMETER VALUES *TVAL* CORRESPONDING TO
C QUADRATURE PARAMETERS *SVAL* ON CIRCULAR ARC
C
DO 20 I=1,NQUAD
RRHS=CONST+HAANG*(1E+0+SJT*SVAL(I))
LL=AA
UU=BB
CALL BISNEW(IER,LL,TVAL(I),UU,A1COF,ACOEF,B1COF,BCFSN,BCOEF,
+ BETA,DGPOL,H0VAL,H1VAL,JACOF,NEWTL,SJT,RRHS,TOLIW)
IF (IER.GT.0) THEN
RETURN
ENDIF
20 CONTINUE
C
C GET VALUES OF DENSITY *RHOVL* CORRESPONDING TO *SVAL* AND
C *TVAL*
C
CALL RHOFN(IER,RHOVL,ACOEF,BCOEF,BETA,BETAC,CENTR,DGPOL,H0VAL,
+ HAANG,HALEN,INTER,MIDPT,NQUAD,PARNT,SJT,JACOF,SVAL,
+ TVAL)
C
IF (IER .GT. 0) THEN
RETURN
ENDIF
C
DO 30 I=1,1+DGPOC
SOLNC(I)=(0E+0,0E+0)
30 CONTINUE
C
WORK(1)=1E+0/SQRT(H0VLC)
DO 50 I=1,NQUAD
CALL JAPAR7(WORK,QUPTC(I),ACOFC,BCOFC,DGPOC)
DO 40 K=1,1+DGPOC
SOLNC(K)=SOLNC(K)+QUWTC(I)*RHOVL(I)*WORK(K)
40 CONTINUE
50 CONTINUE
C
IF (JTYPC .LT. 0) THEN
DO 60 K=2,1+DGPOC,2
SOLNC(K)=-SOLNC(K)
60 CONTINUE
ENDIF
C
C NORMAL EXIT
C
IER=0
C
END
SUBROUTINE IMTQLH(N,D,E,IERR)
C
INTEGER I,J,L,M,N,II,MML,IERR
REAL D(N),E(N)
REAL B,C,F,G,P,R,S,TST1,TST2,PYTHAG
C
C THIS SUBROUTINE IS A TRANSLATION OF THE ALGOL PROCEDURE IMTQL1,
C NUM. MATH. 12, 377-383(1968) BY MARTIN AND WILKINSON,
C AS MODIFIED IN NUM. MATH. 15, 450(1970) BY DUBRULLE.
C HANDBOOK FOR AUTO. COMP., VOL.II-LINEAR ALGEBRA, 241-248(1971).
C
C THIS SUBROUTINE FINDS THE EIGENVALUES OF A SYMMETRIC
C TRIDIAGONAL MATRIX BY THE IMPLICIT QL METHOD.
C
C ON INPUT
C
C N IS THE ORDER OF THE MATRIX.
C
C D CONTAINS THE DIAGONAL ELEMENTS OF THE INPUT MATRIX.
C
C E CONTAINS THE SUBDIAGONAL ELEMENTS OF THE INPUT MATRIX
C IN ITS LAST N-1 POSITIONS. E(1) IS ARBITRARY.
C
C ON OUTPUT
C
C D CONTAINS THE EIGENVALUES IN ASCENDING ORDER. IF AN
C ERROR EXIT IS MADE, THE EIGENVALUES ARE CORRECT AND
C ORDERED FOR INDICES 1,2,...IERR-1, BUT MAY NOT BE
C THE SMALLEST EIGENVALUES.
C
C E HAS BEEN DESTROYED.
C
C IERR IS SET TO
C ZERO FOR NORMAL RETURN,
C J IF THE J-TH EIGENVALUE HAS NOT BEEN
C DETERMINED AFTER 30 ITERATIONS.
C
C CALLS PYTHAG FOR SQRT(A*A + B*B) .
C
C QUESTIONS AND COMMENTS SHOULD BE DIRECTED TO BURTON S. GARBOW,
C MATHEMATICS AND COMPUTER SCIENCE DIV, ARGONNE NATIONAL LABORATORY
C
C THIS VERSION ORIGINALLY DATED AUGUST 1983; RENDERED INACCURATE
C AND TRANSLATED INTO SINGLE PRECISION BY DAVID HOUGH, ETH, ZUERICH
C OCTOBER, 1989.
C
C ------------------------------------------------------------------
C
IERR = 0
IF (N .EQ. 1) GO TO 1001
C
DO 100 I = 2, N
100 E(I-1) = E(I)
C
E(N) = 0.0E0
C
DO 290 L = 1, N
J = 0
C .......... LOOK FOR SMALL SUB-DIAGONAL ELEMENT ..........
105 DO 110 M = L, N
IF (M .EQ. N) GO TO 120
TST1 = ABS(D(M)) + ABS(D(M+1))
TST2 = TST1 + ABS(E(M))
IF (TST2 .EQ. TST1) GO TO 120
110 CONTINUE
C
120 P = D(L)
IF (M .EQ. L) GO TO 215
IF (J .EQ. 30) GO TO 1000
J = J + 1
C .......... FORM SHIFT ..........
G = (D(L+1) - P) / (2.0E0 * E(L))
R = PYTHAG(G,1.0E0)
G = D(M) - P + E(L) / (G + SIGN(R,G))
S = 1.0E0
C = 1.0E0
P = 0.0E0
MML = M - L
C .......... FOR I=M-1 STEP -1 UNTIL L DO -- ..........
DO 200 II = 1, MML
I = M - II
F = S * E(I)
B = C * E(I)
R = PYTHAG(F,G)
E(I+1) = R
IF (R .EQ. 0.0E0) GO TO 210
S = F / R
C = G / R
G = D(I+1) - P
R = (D(I) - G) * S + 2.0E0 * C * B
P = S * R
D(I+1) = G + P
G = C * R - B
200 CONTINUE
C
D(L) = D(L) - P
E(L) = G
E(M) = 0.0E0
GO TO 105
C .......... RECOVER FROM UNDERFLOW ..........
210 D(I+1) = D(I+1) - P
E(M) = 0.0E0
GO TO 105
C .......... ORDER EIGENVALUES ..........
215 IF (L .EQ. 1) GO TO 250
C .......... FOR I=L STEP -1 UNTIL 2 DO -- ..........
DO 230 II = 2, L
I = L + 2 - II
IF (P .GE. D(I-1)) GO TO 270
D(I) = D(I-1)
230 CONTINUE
C
250 I = 1
270 D(I) = P
290 CONTINUE
C
GO TO 1001
C .......... SET ERROR -- NO CONVERGENCE TO AN
C EIGENVALUE AFTER 30 ITERATIONS ..........
1000 IERR = L
1001 RETURN
END
C
C _________________________________________________________________
C
REAL FUNCTION PYTHAG(A,B)
REAL A,B
C
C FINDS SQRT(A**2+B**2) WITHOUT OVERFLOW OR DESTRUCTIVE UNDERFLOW
C
REAL P,R,S,T,U
P = MAX(ABS(A),ABS(B))
IF (P .EQ. 0.0E0) GO TO 20
R = (MIN(ABS(A),ABS(B))/P)**2
10 CONTINUE
T = 4.0E0 + R
IF (T .EQ. 4.0E0) GO TO 20
S = R/T
U = 1.0E0 + 2.0E0*S
P = U*P
R = (S/U)**2 * R
GO TO 10
20 PYTHAG = P
RETURN
END
SUBROUTINE JACANP(IBNDS,INTER,CENTR,IGEOM,RGEOM,ISNPH,RSNPH,IQUPH,
+RQUPH,ZQUPH,RWORK,CHNL,ISNCA,RSNCA,ZSNCA,IER)
C
INTEGER CHNL,IER
INTEGER IBNDS(*),ISNCA(*),ISNPH(*),IGEOM(*),IQUPH(*)
REAL RSNCA(*),RSNPH(*),RGEOM(*),RQUPH(*),RWORK
COMPLEX CENTR
COMPLEX ZSNCA(*),ZQUPH(*)
LOGICAL INTER
C
C ......................................................................
C
C 1. JACANP
C COMPUTATION OF PIECEWISE ORTHOGONAL JACOBI POLYNOMIAL
C APPROXIMATIONS TO THE COMPLEX BOUNDARY CORRESPONDENCE DERIV-
C ATIVE FOR THE MAP: CANONICAL--> PHYSICAL.
C
C 2. PURPOSE
C THE MAIN PURPOSE IS TO CALCULATE THE COEFFICIENTS IN THE
C PIECEWISE ORTHOGONAL JACOBI POLYNOMIAL APPROXIMATIONS TO THE
C COMPLEX BOUNDARY CORRESPONDENCE DERIVATIVE FOR THE CONFORMAL
C MAP OF THE CANONICAL DOMAIN ONTO THE SIMPLY-CONNECTED PHYS-
C ICAL DOMAIN.
C THE METHOD ATTEMPTS TO COMPUTE TRUNCATED FOURIER-JACOBI APP-
C ROXIMATIONS BY DIRECT QUADRATURE ESTIMATION OF THE FOURIER-
C JACOBI COEFFICIENTS. IF DECAY OF THESE COEFFICIENTS ISN'T
C SUFFICIENTLY RAPID ON A GIVEN SUB-ARC OF THE DISC, THEN
C THE SUB-ARC IS DIVIDED.
C A NUMBER OF DATA ARRAYS ASSOCIATED WITH THE POLYNOMIAL
C APPROXIMATIONS ARE ALSO COMPUTED AND MAY BE USED FOR SUBSE-
C QUENT PROCESSING. IN ADDITION TO BEING RETURNED AS
C PARAMETERS OF THE SUBROUTINE THESE ARE ALSO AUTOMATICALLY
C OUTPUT TO DATA FILES.
C
C 3. CALLING SEQUENCE
C CALL JACANP(IBNDS,INTER,CENTR,IGEOM,RGEOM,ISNPH,RSNPH,IQUPH,
C RQUPH,ZQUPH,RWORK,CHNL,ISNCA,RSNCA,ZSNCA,IER)
C
C PARAMETERS
C ON ENTRY
C IBNDS - INTEGER ARRAY
C INTEGER VECTOR OF SIZE AT LEAST 2.
C IBNDS(K), K=1,2 DEFINE VARIOUS UPPER LIMITS
C THAT HAVE BEEN SET IN THE CALLING PROGRAM AND
C WHICH CONTROL THE SIZES OF THE ARRAYS ISNCA,RSNCA,
C ZSNCA.
C IBNDS(1) - THE MAXIMUM NUMBER OF SUB-ARCS ALLOWED
C ON THE UNIT DISC.
C IBNDS(2) - THE MAXIMUM TOTAL NUMBER OF JACOBI CO-
C EFFICIENTS ALLOWED.
C (IBNDS(2) <= IBNDS(1)*NQPTS WHERE
C NQPTS = IGEOM(2))
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE. (AS PREVIOUSLY USED IN JAPHYC, GQPHYC)
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS TO BE
C MAPPED TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN. (AS PREV-
C IOUSLY USED IN JAPHYC, GQPHYC)
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNPH - INTEGER ARRAY
C THE INTEGER VECTOR ISNPH PREVIOUSLY SET UP BY
C JAPHYC.
C
C RSNPH - REAL ARRAY
C THE REAL VECTOR RSNPH PREVIOUSLY SET UP BY JAPHYC.
C
C IQUPH - INTEGER ARRAY
C THE INTEGER VECTOR IQUPH PREVIOUSLY SET UP BY
C GQPHYC.
C
C RQUPH - REAL ARRAY
C THE REAL ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C ZQUPH - COMPLEX ARRAY
C THE COMPLEX ARRAY PREVIOUSLY SET UP BY GQPHYC.
C
C RWORK - REAL ARRAY
C REAL WORKING VECTOR OF SIZE AT LEAST
C (NARCS + 1)*NQPTS
C WHERE NARCS, NQPTS ARE INPUT ARGUMENTS TO JAPHYC.
C (NOTE: NARCS=IGEOM(1), NQPTS=IGEOM(2))
C
C CHNL - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILES ca, cl.
C
C ON EXIT
C ISNCA - INTEGER ARRAY
C AN INTEGER VECTOR OF SIZE AT LEAST
C 4*IBNDS(1) + 6 ;
C ISNCA MAINLY STORES POINTERS TO ACCESS RSNCA AND
C ZSNCA.
C
C RSNCA - REAL ARRAY
C A REAL VECTOR OF SIZE AT LEAST
C 2*IBNDS(1) + (4 + 6*NQPTS)*(NARCS + 1) + 2,
C WHERE NARCS, NQPTS ARE INPUT ARGUMENTS TO JAPHYC.
C (NOTE: NARCS=IGEOM(1), NQPTS=IGEOM(2))
C STORES DATA RELATING TO THREE-TERM RECURRENCE
C SCHEMES, ELEMENTARY GAUSS-JACOBI QUADRATURE RULES,
C AND THE ARGUMENTS OF SUB-ARC ENDPOINTS ON THE UNIT
C DISC.
C
C CSNCA - COMPLEX ARRAY
C A COMPLEX VECTOR OF SIZE AT LEAST 2*IBNDS(2) + 1;
C STORES THE JACOBI COEFFICIENTS FOR THE COMPLEX
C (INVERSE) BOUNDARY CORRESPONDENCE FUNCTION AND
C ITS DERIVATIVE.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL AND THE
C LISTING FILE cl.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - NOTE THAT THIS ROUTINE CAN ONLY BE USED A F T E R THE
C ROUTINES JAPHYC AND GQPHYC HAVE SUCCESSFULLY EXECUTED,
C AND THAT SOME INPUT ARGUMENTS FOR JACANP ARE OUTPUT VALUES
C FROM JAPHYC AND GQPHYC.
C - THE DATA WHICH MAY BE REQUIRED FOR LATER PROCESSING BY
C OTHER CONFPACK ROUTINES IS WRITTEN ON THE FIEL ca,
C WHERE IS COLLECTED FROM THE FILE jbnm PREVIOUSLY
C CREATED BY JAPHYC.
C - A SUMMARY LISTING OF ACTIONS TAKEN IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 3 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
C
C**** POINTERS USED TO PROCESS ARRAYS
C
INTEGER ACOEF,ACOFC,AICOC,AICOF,BCFSN,BCOEF,BCOFC,BFSNC,BICOC,
+BICOF,COARG,DGPOC,DGPOL,ERARC,H0VAL,H0VLC,HALEN,HIVAL,HIVLC,JACIN,
+JAINC,JATYP,JTYPC,LOSUB,LQSBF,LSUBC,MIDPT,NPPQF,PARNT,PHPAS,PRNSA,
+QUPTC,QUPTS,QUWTC,QUWTS,SOLNC,SOLUN,TPPQF,TRRAD,VARGC,VTARG,WPPQF,
+ZPPQF
C
C**** OTHER SCALAR VARIABLES
C
INTEGER I,MNCOF,MNEQN,MNSUA,MNSUC,MQUPH,NARCS,NEQNS,NJIND,
+NJCOG,NQPTS,PT,TNGQP,TNSUA,TNSUC
REAL COLSC,INNRAD,LGTOL,PI,R1MACH,SUPER,THET0,NEWTL
COMPLEX DCAP0,FACTR,CINRAD
C
EXTERNAL BCFSNG,CINRAD,IGNLVL,JCFIM5,OPQUD1,R1MACH,OUPTCA,OUPTCL,
+WRHEAD,WRTAIL
C
PARAMETER (COLSC=-1E+0)
C
C**** OUTPUT CONFPACK HEADING
C
CALL WRHEAD(3,0)
C
C**** DEFINE SOME OUTPUT FORMATS
C
1 FORMAT(A45)
2 FORMAT(A45,E16.8)
C
NEWTL=SQRT(R1MACH(4))
PI=4E+0*ATAN(1E+0)
C
NARCS=IGEOM(1)
NQPTS=IGEOM(2)
MNSUA=IGEOM(4)
TNSUA=ISNPH(3)
NEQNS=ISNPH(4)
MNEQN=ISNPH(6)
SUPER=RGEOM(1)
LGTOL=RGEOM(2)
MNCOF=IBNDS(2)
MNSUC=IBNDS(1)
MQUPH=IQUPH(4)
NJIND=NARCS+1
TNGQP=NQPTS*NJIND
C
C**** ASSIGN FIXED DATA TO ISNCA, RSNCA
C
ISNCA(1)=NARCS
ISNCA(2)=NQPTS
ISNCA(5)=MNSUC
ISNCA(6)=MNCOF
RSNCA(1)=LGTOL
C
C**** SET UP POINTERS TO IGEOM AND RGEOM, AS IN JAPHYC
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP POINTERS TO ELEMENTS IN ISNPH AND RSNPH,AS IN JAPHYC
C
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
ERARC=3*NJIND+6*TNGQP+1
BCFSN=MNSUA+3*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
C**** SET UP POINTERS TO ELEMENTS IN IQUPH AND RQUPH, AS IN GQPHYC
C
LQSBF=5
NPPQF=MNSUA+5
TPPQF=2
TRRAD=MQUPH+2
WPPQF=2*MQUPH+2
ZPPQF=2
C
C**** SET UP POINTERS TO ELEMENTS IN ISNCA, RSNCA AND ZSNCA
C
DGPOC=7
JTYPC=MNSUC+7
LSUBC=2*MNSUC+7
PRNSA=3*MNSUC+7
ACOFC=2
BCOFC=TNGQP+2
AICOC=2*TNGQP+2
BICOC=3*TNGQP+2
QUPTC=4*TNGQP+2
QUWTC=5*TNGQP+2
H0VLC=6*TNGQP+2
HIVLC=NJIND+6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
COARG=3*NJIND+6*TNGQP+2
PHPAS=4*NJIND+6*TNGQP+2
VARGC=MNSUC+4*NJIND+6*TNGQP+2
BFSNC=2
SOLNC=MNCOF+2
C
C INITIALISE JACOBI INDECES *JAINC* FOR THE INVERSE MAP
C
DO 10 I=1,NARCS
RSNCA(JAINC+I-1)=-RSNPH(JACIN+I-1)/(1E+0+RSNPH(JACIN+I-1))
10 CONTINUE
RSNCA(JAINC+NJIND-1)=0E+0
C
C SET UP GAUSS-JACOBI QUADRATURE DATA FOR INVERSE MAP AND STORE IN
C ARRAYS *QUPTC* AND *QUWTC*. SET THE CORRESPONDING THREE TERM
C RECURRENCE COEFFICIENTS AND STORE IN *ACOFC*, *BCOFC*. DETERMINE
C THE ZEROTH MOMENTS OF THE JACOBI DISTRIBUTIONS AND STORE IN
C *H0VLC*. ALSO SET UP THE DATA *AICOC*,*BICOC* AND *HICOC* FOR THE
C INTEGRATED POLYNOMIALS NEEDED FOR PROCESSING AFTER THIS MODULE.
C
CALL OPQUD1(NJIND,NQPTS,RSNCA(JAINC),RSNCA(ACOFC),RSNCA(BCOFC),
+RSNCA(H0VLC),RSNCA(AICOC),RSNCA(BICOC),RSNCA(HIVLC),RSNCA(QUPTC),
+RSNCA(QUWTC),RWORK,IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'BASIC GAUSS QUADRATURE DATA DONE:'
C
C SET UP THE ARRAY *RWORK* OF REFERENCE IGNORE LEVELS.
C
CALL IGNLVL(RWORK,COLSC,RSNCA(ACOFC),RSNCA(BCOFC),RSNCA(H0VLC),
+RSNCA(JAINC),NJIND,NQPTS,IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
C INITIALISE THE DATA RELATING TO THE DESCRIPTION OF THE DISCRET-
C ISATION AND SOLUTION HOUSEKEEPING ON THE UNIT CIRCLE
C
TNSUC=TNSUA
C
DO 20 I=1,TNSUA
ISNCA(DGPOC+I-1)=NQPTS-1
ISNCA(JTYPC+I-1)=ISNPH(JATYP+I-1)
RSNCA(PHPAS+I-1)=-1E+0
ISNCA(PRNSA+I-1)=I
RSNCA(VARGC+I-1)=RGEOM(VTARG+I-1)
20 CONTINUE
RSNCA(VARGC+TNSUA)=RGEOM(VTARG+TNSUA)
RSNCA(PHPAS+TNSUA)=-1E+0
RSNCA(COARG)=RSNCA(VARGC)
PT=1
DO 30 I=2,TNSUA
IF (IGEOM(PARNT+I-1) .NE. PT) THEN
PT=IGEOM(PARNT+I-1)
RSNCA(COARG+PT-1)=RSNCA(VARGC+I-1)
ENDIF
30 CONTINUE
RSNCA(COARG+NARCS)=RSNCA(COARG)+2E+0*PI
C
C SET UP THE JACOBI COEFFICIENTS OF THE COMPLEX DENSITY FOR
C THE INVERSE MAP
C
CALL JCFIM5(ISNCA(DGPOC),IER,ISNCA(JTYPC),ISNCA(LSUBC),
+RSNCA(PHPAS),ISNCA(PRNSA),ZSNCA(SOLNC),TNSUC,RSNCA(VARGC),
+RSNPH(AICOF),RSNPH(ACOEF),RSNCA(ACOFC),RSNPH(BICOF),RSNPH(BCFSN),
+RSNPH(BCOEF),RSNCA(BCOFC),CENTR,ISNPH(DGPOL),RSNPH(ERARC),
+RSNPH(H0VAL),RSNCA(H0VLC),RSNPH(HIVAL),RGEOM(HALEN),INTER,
+RSNPH(JACIN),RSNCA(JAINC),ISNPH(JATYP),LGTOL,ISNPH(LOSUB),
+RGEOM(MIDPT),MNCOF,MNSUC,NJIND,NQPTS,IGEOM(PARNT),RSNCA(QUPTC),
+RSNCA(QUWTC),RWORK,RSNPH(SOLUN),NEWTL,RGEOM(VTARG))
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
NJCOG=ISNCA(LSUBC+TNSUC-1)+ISNCA(DGPOC+TNSUC-1)
ISNCA(3)=TNSUC
ISNCA(4)=NJCOG
WRITE(*,1) 'JACOBI COEFFICIENTS DONE:'
C
C COMPUTE THE COMPLEX INNER RADIUS FOR INTERIOR DOMAINS OR THE
C COMPLEX CAPACITY FOR EXTERIOR DOMAINS, STORING RELEVANT VALUE
C IN *DCAP0*
C
THET0=RGEOM(VTARG)
FACTR=CMPLX(COS(THET0),SIN(THET0))
DCAP0=CINRAD(NARCS,NQPTS,TNSUA,ISNPH(DGPOL),ISNPH(JATYP),
+ISNPH(LOSUB),IQUPH(LQSBF),IQUPH(NPPQF),IGEOM(PARNT),RSNPH(ACOEF),
+RSNPH(BCOEF),RSNPH(H0VAL),RGEOM(HALEN),RSNPH(JACIN),LGTOL,
+RGEOM(MIDPT),RSNPH(QUPTS),RSNPH(QUWTS),RSNPH(SOLUN),RQUPH(TPPQF),
+RQUPH(TRRAD),RQUPH(WPPQF),CENTR,FACTR,ZQUPH(ZPPQF),IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
IF (INTER) THEN
INNRAD=ABS(DCAP0)
WRITE(*,2) 'INNER RADIUS:',INNRAD
ELSE
DCAP0=EXP(-RSNPH(SOLUN+NEQNS-1))*DCAP0/ABS(DCAP0)
ENDIF
ZSNCA(1)=DCAP0
C
C GET THE COEFFICIENTS BFSNC FOR THE COMPLEX BOUNDARY CORRESPONDENCE
C FUNCTION FOR THE INVERSE MAP.
C
CALL BCFSNG(TNSUC,ISNCA(DGPOC),ISNCA(JTYPC),ISNCA(LSUBC),
+RSNCA(H0VLC),RSNCA(JAINC),ZSNCA(BFSNC),ZSNCA(SOLNC))
C
CALL OUPTCL(ISNCA(DGPOC),ISNCA(JTYPC),LGTOL,ISNCA(LSUBC),NQPTS,
+CHNL,IGEOM(PARNT),ISNCA(PRNSA),RWORK,ZSNCA(SOLNC),TNSUC,INTER,
+INNRAD,IER)
C
C OUTPUT ALL RESULTS REQUIRED FOR SUBSEQUENT PROCESSING
C
CALL OUPTCA(ISNCA,RSNCA,ZSNCA,CHNL)
C
999 CONTINUE
C
CALL WRTAIL(3,0,IER)
C
END
COMPLEX FUNCTION JACSUC(X,N,A,B,H,CO)
INTEGER N
REAL A(*),B(*),H,X
COMPLEX CO(*)
C ..TO CALCULATE SUMMATION{CO(K+1)*P(K,X)},K=0(1)N, WHERE P(K,X)
C ..DENOTES THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE K
C ..EVALUATED AT X, ARRAY CO STORES A GIVEN SET OF COEFFICIENTS,
C ..ARRAYS A,B STORE THE COEFFICIENTS IN THE THREE-TERM
C ..RECURRENCE FORMULA FOR THE JACOBI POLYNOMIALS (SEE ASONJ7)
C ..AND H IS THE SQUARED 2-NORM OF UNITY.
COMPLEX PREV,CURR,NEXT
INTEGER K
C
IF (N .EQ. 0) THEN
JACSUC=CO(1)/SQRT(H)
ELSE IF (N .GT. 0) THEN
PREV=CO(N+1)
CURR=CO(N)+(X-B(N))*PREV/A(N)
DO 10 K=N-2,0,-1
NEXT=CO(K+1)+(X-B(K+1))*CURR/A(K+1)-A(K+1)*PREV/A(K+2)
PREV=CURR
CURR=NEXT
10 CONTINUE
JACSUC=CURR/SQRT(H)
ELSE
JACSUC=(0E+0,0E+0)
ENDIF
C
END
REAL FUNCTION JACSUM(X,N,A,B,H,CO)
INTEGER N
REAL X,A(*),B(*),H,CO(*)
C ..TO CALCULATE SUMMATION{CO(K+1)*P(K,X)},K=0(1)N, WHERE P(K,X)
C ..DENOTES THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE K
C ..EVALUATED AT X, ARRAY CO STORES A GIVEN SET OF COEFFICIENTS,
C ..ARRAYS A,B STORE THE COEFFICIENTS IN THE THREE-TERM
C ..RECURRENCE FORMULA FOR THE JACOBI POLYNOMIALS (SEE ASONJ7)
C ..AND H IS THE SQUARED 2-NORM OF UNITY.
REAL PREV,CURR,NEXT
INTEGER K
C
IF (N .EQ. 0) THEN
JACSUM=CO(1)/SQRT(H)
ELSE IF (N .GT. 0) THEN
PREV=CO(N+1)
CURR=CO(N)+(X-B(N))*PREV/A(N)
DO 10 K=N-2,0,-1
NEXT=CO(K+1)+(X-B(K+1))*CURR/A(K+1)-A(K+1)*PREV/A(K+2)
PREV=CURR
CURR=NEXT
10 CONTINUE
JACSUM=CURR/SQRT(H)
ELSE
JACSUM=0E+0
ENDIF
C
END
SUBROUTINE JAPAR7(PP,X,AA,BB,N)
INTEGER N
REAL X,PP(*),AA(*),BB(*)
C
C ..................................................................
C
C 1. JAPAR7
C EVALUATES ORTHONORMAL JACOBI POLYNOMIALS.
C
C
C 2. PURPOSE
C TO COMPUTE PP(I), I=1,..,N+1, GIVEN PP(1) ON ENTRY, WHERE PP(I)
C STORES THE VALUE OF THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE
C I-1 AT THE GIVEN PARAMETER VALUE X.
C
C
C 3. CALLING SEQUENCE
C CALL JAPAR7(PP,X,AA,BB,N)
C
C PARAMETERS (SEE DECLARATIONS ABOVE FOR TYPES)
C ON ENTRY:
C PP(1) - THE VALUE OF THE POLYNOMIAL OF DEGREE ZERO.
C
C X - THE REAL NUMBER AT WHICH THE POLYNOMIALS ARE TO BE
C EVALUATED.
C
C AA - ARRAY OF COEFFICIENTS IN THE 3-TERM RECURRENCE
C AA(I)*PP(I+1)=(X-BB(I))*PP(I)-AA(I-1)*PP(I-1),
C I=1,..,N, WITH "PP(0)" = 0.
C
C BB - ARRAY OF COEFFICIENTS IN THE 3-TERM RECURRENCE ABOVE.
C
C N - THE LARGEST DEGREE OF POLYNOMIAL REQUIRING EVALUATION.
C
C ON EXIT:
C PP - PP(I) IS THE VALUE OF THE POLYNOMIAL OF DEGREE I-1 AT
C X, I=1,..,N+1.
C
C
C 4. NO SUBROUTINES OR FUNCTIONS NEEDED
C
C ..................................................................
C
INTEGER I
IF (N.GT.0) THEN
PP(2)=(X-BB(1))*PP(1)/AA(1)
DO 10 I=2,N
PP(I+1)=((X-BB(I))*PP(I)-AA(I-1)*PP(I-1))/AA(I)
10 CONTINUE
ENDIF
END
SUBROUTINE JAPHYC(JBNM,HEAD,MAXER,INTER,NARCS,ISYGP,NQPTS,INCST,
+RFARC,RFARG,CENTR,TSTNG,OULVL,IBNDS,MNEQN,MATRX,IWORK,RWORK,
+ZWORK,LWORK,OCH,IGEOM,RGEOM,ISNPH,RSNPH,IER)
C
INTEGER NARCS,ISYGP,NQPTS,RFARC,TSTNG,OULVL,MNEQN,OCH,IER
INTEGER IBNDS(*),IGEOM(*),ISNPH(*),IWORK(*)
REAL MAXER,RFARG
REAL RGEOM(*),MATRX(MNEQN,MNEQN,2),RSNPH(*),RWORK(*)
COMPLEX CENTR
COMPLEX ZWORK(*)
LOGICAL INTER,INCST
LOGICAL LWORK(*)
CHARACTER JBNM*4,HEAD*72
C
C ......................................................................
C
C 1. JAPHYC
C COMPUTATION OF PIECEWISE ORTHOGONAL JACOBI POLYNOMIAL
C APPROXIMATIONS TO THE BOUNDARY CORRESPONDENCE DERIVATIVE FOR
C THE MAP:PHYSICAL --> CANONICAL.
C
C 2. PURPOSE
C THE MAIN PURPOSE IS TO CALCULATE THE COEFFICIENTS IN THE
C PIECEWISE ORTHOGONAL JACOBI POLYNOMIAL APPROXIMATIONS TO THE
C BOUNDARY CORRESPONDENCE DERIVATIVE FOR THE CONFORMAL MAP OF
C A GIVEN SIMPLY CONNECTED PHYSICAL DOMAIN (WITH PIECEWISE
C ANALYTIC BOUNDARY) ONTO A CANONICAL DOMAIN (WITH UNIT CIRCLE
C AS BOUNDARY). AN INTERIOR PHYSICAL DOMAIN IS MAPPED TO THE
C UNIT DISC, AN EXTERIOR PHYSICAL DOMAIN TO THE COMPLEMENT OF
C THE CLOSED UNIT DISC.
C THE METHOD USED IS AN ADAPTIVE COLLOCATION SOLUTION OF
C SYMM'S INTEGRAL EQUATION.
C A NUMBER OF DATA ARRAYS ASSOCIATED WITH THE POLYNOMIAL
C APPROXIMATIONS ARE ALSO COMPUTED AND MAY BE USED FOR SUBSE-
C QUENT PROCESSING. IN ADDITION TO BEING RETURNED AS
C PARAMETERS OF THE SUBROUTINE THESE ARE ALSO AUTOMATICALLY
C OUTPUT TO DATA FILES.
C
C 3. CALLING SEQUENCE
C CALL JAPHYC(JBNM,HEAD,MAXER,INTER,NARCS,ISYGP,NQPTS,INCST,
C RFARC,RFARG,CENTR,TSTNG,OULVL,IBNDS,MATRX,IWORK,
C RWORK,ZWORK,LWORK,OCH,IGEOM,RGEOM,ISNPH,RSNPH,
C IER)
C
C PARAMETERS
C ON ENTRY
C JBNM - CHARACTER*4
C THE JOB NAME. THIS IS USED TO CREATE THREE OUT-
C PUT FILES WITH FILENAMES
C
C pl, gm, ph,
C
C WHERE DENOTES THE VALUE OF VARIABLE JBNM
C WITH ANY TRAILING SPACES DELETED. THE FIRST OF
C THESE IS A LISTING FILE RECORDING THE PROGRESS
C AND RESULTS OF THE CALCULATION FOR LATER READING
C BY THE USER. THE TWO FILES gm AND ph
C ARE DATA FILES, NOT REALLY INTENDED TO BE READ
C BY THE USER.
C THE VALUE OF JBNM IS ALSO THE ONLY ITEM IN A
C FOURTH OUTPUT FILE NAMED (LITERALLY) jbnm.
C
C HEAD - CHARACTER*72
C A HEADING FOR THE PROBLEM, TO APPEAR ON THE
C LISTING FILE pl.
C
C MAXER - REAL
C RELATIVE ACCURACY REQUESTED FOR THE CONFORMAL MAP;
C THIS IS THE SAME AS THE ABSOLUTE ACCURACY ON THE
C BOUNDARY OF THE PHYSICAL DOMAIN.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE.
C
C NARCS - INTEGER
C THE NUMBER OF ANALYTIC ARCS THAT MAKE UP THE
C W H O L E BOUNDARY OF THE PHYSICAL DOMAIN.
C
C ISYGP - INTEGER
C THE MAGNITUDE OF ISYGP IS THE ORDER OF THE
C SYMMETRY GROUP OF THE PHYSICAL DOMAIN.
C ISYGP.EQ.1 -THE SYMMETRY GROUP HAS ONLY ONE ELE-
C MENT,THE IDENTITY TRANSFORMATION; IN
C OTHER WORDS, THE DOMAIN HAS 'NO
C SYMMETRY'.
C ISYGP.GT.1 -THE SYMMETRY GROUP CONTAINS ONLY
C PROPER (IN-PLANE) ROTATIONS; IN OTHER
C WORDS, THE DOMAIN HAS ONLY ROTATIONAL
C SYMMETRIES.
C ISYGP.LT.-1 -THE SYMMETRY GROUP CONTAINS IMPROPER
C (OUT-OF-PLANE) ROATIONS; IN OTHER
C WORDS, THE DOMAIN HAS REFLECTIONAL
C SYMMETRY AND MAY ALSO HAVE ROTATIONAL
C SYMMETRIES.
C AN INPUT VALUE OF -1 OR 0 IS TREATED AS IF IT WERE
C 1.
C
C NQPTS - INTEGER
C PLAYS TWO ROLES.
C 1. THE NUMBER OF QUADRATURE POINTS TO BE USED IN
C AN ELEMENTARY GAUSS-JACOBI RULE; COMPOSITE
C RULES ARE CONSTRUCTED FROM PANELS OF NQPTS-
C POINT RULES.
C 2. THE MAXIMUM DEGREE OF POLYNOMIAL APPROXIMATION
C IS FIXED AT NQPTS-1.
C NQPTS SHOULD BE REASONABLY LARGE; A PRACTICAL RULE
C OF THUMB IS THAT IF MACHINE PRECISION IS X*1E-N,
C 1pl.
C OULVL=0 - OUTPUT A SOLUTION SUMMARY AT EACH STAGE
C IN THE ADAPTIVE PROCESS AND A SHORT
C SUMMARY OF THE ERRORS IN MODULUS.
C OULVL=1 - AS 0, BUT ALSO OUTPUT A DETAILED LIST OF
C THE ERRORS IN MODULUS.
C OULVL=2 - AS 0, BUT ALSO OUTPUT FULL DETAILS OF
C THE FINAL COMPUTED JACOBI COEFFICIENTS
C ON SUCCESSFUL COMPLETION.
C OULVL=3 - AS 2, BUT ALSO OUTPUT A DETAILED LIST OF
C THE ERRORS IN MODULUS.
C OULVL=4 - OUTPUT FULL DETAILS OF THE OF THE COMPU-
C TED JACOBI COEFFICIENTS AT EVERY STAGE
C IN THE ADAPTIVE PROCESS AND A SHORT
C SUMMARY OF THE ERRORS IN MODULUS.
C OULVL=5 - AS 4, BUT ALSO OUTPUT A DETAILED LIST OF
C THE ERRORS IN MODULUS.
C
C IBNDS - INTEGER ARRAY
C INTEGER VECTOR OF SIZE AT LEAST 5.
C IBNDS(K), K=1,2,3,4,5, DEFINE VARIOUS UPPER LIMITS
C THAT HAVE BEEN SET IN THE CALLING PROGRAM AND
C WHICH CONTROL THE SIZES OF THE ARRAYS IGEOM,RGEOM,
C MATRX,ISNPH,RSNPH,IWORK,RWORK,ZWORK,LWORK.
C THEIR MEANINGS ARE AS FOLLOWS:
C IBNDS(1) - THE MAXIMUM NUMBER OF SUB-ARCS ALLOWED.
C IBNDS(2) - THE MAXIMUM NUMBER OF JACOBI INDECES
C ALLOWED (WHICH IS ALSO THE 1 + THE
C MAXIMUM NUMBER OF CORNERS ALLOWED ON
C PHYSICAL BOUNDARY).
C IBNDS(3) - 1 + THE MAXIMUM NUMBER OF PANELS
C ALLOWED IN A SINGLE COMPOSITE GAUSSIAN
C RULE.
C IBNDS(4) - THE MAXIMUM TOTAL NUMBER OF QUADRATURE
C POINTS ALLOWED OVER ALL COMPOSITE
C GAUSSIAN RULES.
C (IBNDS(4)<=(IBNDS(3)-1)*IBNDS(2)*NQPTS)
C
C MNEQN - INTEGER
C THE MAXIMUM NUMBER OF EQUATIONS ALLOWED IN THE
C LINEAR ALGEBRAIC SYSTEM RESULTING FROM THE
C COLLOCATION METHOD. (MNEQN <= 1+IBNDS(1)*NQPTS)
C
C MATRX - REAL ARRAY
C A 3-DIMENSIONAL MATRIX OF SIZE
C MNEQN X MNEQN X 2 .
C (IN THE ADAPTIVE PROCESS, MATRX(*,*,2) WILL STORE
C THE COEFFICIENT MATRIX OF THE CURRENT COLLOCATION
C SYSTEM AND MATRX(*,*,1) WILL STORE THE COEFFICIENT
C MATRIX OF THE PREVIOUS SYSTEM)
C
C IWORK - INTEGER ARRAY
C A WORKING VECTOR OF SIZE AT LEAST
C 8*IBNDS(1)+MNEQN+2*IBNDS(2) .
C
C RWORK - REAL ARRAY
C A WORKING VECTOR OF SIZE AT LEAST
C (4 + 3*NQPTS + 5*IBNDS(2))*NQPTS + 2*IBNDS(1) +
C 2*MNEQN + IBNDS(3) + 5*IBNDS(2) + 2*IBNDS(4)
C
C ZWORK - COMPLEX ARRAY
C A WORKING VECTOR OF SIZE AT LEAST
C MNEQN + 2*IBNDS(2)
C
C LWORK - LOGICAL ARRAY
C A WORKING VECTOR OF SIZE AT LEAST
C 3*IBNDS(1) + IBNDS(2)
C
C OCH - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILES pl, gm, ph.
C
C ON EXIT
C RFARG - REAL
C EXIT VALUE IS PI*(ENTRY VALUE)
C
C IGEOM - INTEGER ARRAY
C A VECTOR OF SIZE AT LEAST
C IBNDS(1) + 4;
C STORES DATA RELATING TO THE ARC SUBDIVISIONS THAT
C HAVE TAKEN PLACE.
C
C RGEOM - REAL ARRAY
C A VECTOR OF SIZE AT LEAST
C 3*IBNDS(1)+2;
C STORES DATA RELATING TO THE ARC SUBDIVISIONS THAT
C HAVE TAKEN PLACE AND THE ARGUMENTS OF SUB-ARC END
C POINTS ON THE UNIT DISC.
C
C ISNPH - INTEGER ARRAY
C A SOLUTION VECTOR OF SIZE AT LEAST
C 3*IBNDS(1)+6;
C STORES DATA DEFINING THE FINAL POLYNOMIAL DEGREES
C ON THE SUB-ARCS, THE JACOBI INDEX FOR EACH SUB-ARC
C AND POINTERS TO THE SOLUTIONS STORED IN RSNPH.
C
C RSNPH - REAL ARRAY
C A SOLUTION VECTOR OF SIZE AT LEAST
C IBNDS(1)+2*MNEQN+3*IBNDS(2)*(1+2*NQPTS);
C STORES DATA DEFINING THREE-TERM RECURRENCE
C SCHEMES, ELEMENTARY GAUSS-JACOBI QUADRATURE RULES,
C THE JACOBI COEFFICIENTS FOR THE BOUNDARY
C CORRESPONDENCE FUNCTION AND ITS DERIVATIVE AND
C THE ERRORS IN MODULUS ON EACH SUB-ARC.
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL AND THE
C LISTING FILE pl.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH, WHICH IS A MACHINE CONSTANTS
C ROUTINE OBTAINED FROM THE PORT LIBRARY.
C IT MUST BE ADJUSTED TO SUIT EACH PARTICULAR MACHINE.
C IF YOUR MACHINE ISN'T LISTED IN R1MACH THEN YOU'LL
C HAVE TO WRITE YOUR OWN VERSION, BUT NOTE THAT CONFPACK
C ONLY USES R1MACH(1), R1MACH(2) AND R1MACH(4).
C - THE FOLLOWING LINPACK ROUTINES:
C ISAMAX SASUM SAXPY SDOT SGECO
C SGEFA SGEDI SGESL SSCAL SSWAP
C - THE FOLLOWING QUADPACK ROUTINES:
C QAWS QAWSE QC25S QCHEB QK15W
C QMAC QMOMO QSORT QWGTS
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN
C WHICH DEFINE THE PARAMETRIC FUNCTION FOR THE PHYSICAL
C BOUNDARY AND THE DERIVATIVE OF THE PARAMETRIC FUNCTION.
C THE PARAMETRIC FUNCTION DEFINING THE K'TH ANALYTIC ARC
C SHOULD HAVE THE SUBROUTINE HEADING
C
C COMPLEX FUNCTION PARFUN(K,T)
C INTEGER K
C COMPLEX T
C
C WITH THE REAL PARAMETER INTERVAL -1 < REAL(T) < +1
C BEING MAPPED TO THE PHYSICAL ARC. A SIMILAR HEADING
C SHOULD BE GIVEN FOR THE DERIVATIVE DPARFN. THE PRE-
C PROCESSING PROGRAM PARGEN IS AVAILABLE TO HELP WITH
C THE CREATION OF PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C A SUMMARY LISTING OF ACTIONS TAKEN IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 15 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
C**** POINTERS FOR IGEOM,RGEOM,ISNPH,RSNPH
C
INTEGER ACOEF,AICOF,BCFSN,BCOEF,BICOF,DGPOL,ERARC,H0VAL,HALEN,
+HIVAL,JACIN,JATYP,LOSUB,MIDPT,PARNT,QUPTS,QUWTS,SOLUN,VTARG
C
C**** POINTERS FOR IWORK,RWORK,ZWORK,LWORK
C
INTEGER A1COF,AQCOF,AXION,B1COF,BQCOF,COLPR,COLSC,CQCOF,DIAG,
+HIOLD,HISUB,HITES,ICOPY,IPIVT,LCOPY,LNSEG,LOOLD,LOQSB,LOTES,NEWDG,
+NEWHL,NEWQU,NQUAD,PNEWQ,QCOMW,QCOMX,RCOPY,RIGLL,SDIAG,TOLOU,WORK2,
+WORKQ,WORK,WORKT,XENPT,XIDST,XIVAL,ZCOLL
C
C**** OTHER LOCAL VARIABLES
C
INTEGER I,IMXER,INDEG,J,L,MDGPO,MNJXS,MNQUA,MNSUA,MQIN1,NCOLL,
+NEFF,NEQNS,NJIND,NROWS,NTEST,QIERC(0:6),QIERR(0:6),SOLCO,
+TNSUA,TNGQP,ORDSG
C
REAL AQTOL,CONST,EPS,GAQTL,GLGTL,GRQTL,GSUPE,GTGTE,LGTOL,ESTOL,
+MCHEP,MCQER,MQERR,MXERM,PI,QFACT,R1MACH,RCOND,RQTOL,SFACT,SSUPE,
+TGTER,TOLNR
C
COMPLEX ZMXER
C
LOGICAL ACCPT,GACPT,INIBT,NUQTL,REFLN
C
CHARACTER OFL*6
C
PARAMETER(SFACT=8E-1,QFACT=1E-1,INIBT=.TRUE.)
C
EXTERNAL AXION1,ANGLE7,ASQUC7,BCFVTF,CPJAC3,CSCAL3,ICOQR1,IGNLVL,
+LINSEG,LNSY11,OPQUD1,OUPTGM,OUPTPH,R1MACH,RECON,RESCAL,RSLT80,
+RSLT71,RSLT72,RSLT83,RSLT84,SETIGL,SGECO,SGEDI,SGESL,TESMD9,
+TSJAC3,UPCOQ1,UPJAC1,WRHEAD,WRTAIL
C
C**** INITIALISE DATA
C
DATA QIERC/7*0E+0/
C
C**** DEFINE SOME OUTPUT FORMATS
C
1 FORMAT(A45)
3 FORMAT(A45,2X,E9.2)
C
C**** NAME AND OPEN THE MAIN LISTING FILE AND OUTPUT THE JOBNAME TO FILE
C**** jbnm.
C
OPEN(OCH,FILE='jbnm')
WRITE(OCH,'(A4)') JBNM
CLOSE(OCH)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'pl'
OPEN(OCH,FILE=OFL)
C
C**** OUTPUT CONFPACK HEADING
C
CALL WRHEAD(1,0)
CALL WRHEAD(1,OCH)
C
IF (NQPTS .LT. 1) THEN
IER=3
GOTO 999
ENDIF
C
C**** INITIALISE SOME VARIABLES
C
IF (ISYGP.EQ.0 .OR. ISYGP.EQ.-1) THEN
ORDSG=1
REFLN=.FALSE.
ELSE
ORDSG=ABS(ISYGP)
REFLN=(ISYGP.LT.-1)
ENDIF
C
IF (MOD(NARCS,ORDSG).NE.0) THEN
IER=55
GOTO 999
ENDIF
C
SOLCO=0
NEFF=0
MCHEP=R1MACH(4)
TOLNR=SQRT(MCHEP)
NJIND=NARCS+1
TNGQP=NQPTS*NJIND
MDGPO=NQPTS-1
MNSUA=IBNDS(1)
MNJXS=IBNDS(2)
MQIN1=IBNDS(3)
MNQUA=IBNDS(4)
IF (2*NARCS .GT. MNSUA) THEN
IER=1
GOTO 999
ENDIF
IF (NARCS+1 .GT. MNJXS) THEN
IER=2
GOTO 999
ENDIF
IF (TSTNG .NE. 1) THEN
TSTNG=0
ENDIF
GSUPE=MAXER
GTGTE=GSUPE*SFACT
GAQTL=QFACT*GTGTE
IF (GAQTL .LT. 5E+0*MCHEP) THEN
GAQTL=5E+0*MCHEP
GTGTE=GAQTL/QFACT
GSUPE=GTGTE/SFACT
ENDIF
GLGTL=LOG(1E+0+GTGTE)
GRQTL=GAQTL
IGEOM(1)=NARCS
IGEOM(2)=NQPTS
IGEOM(4)=MNSUA
ISNPH(1)=NARCS
ISNPH(2)=NQPTS
ISNPH(5)=MNSUA
ISNPH(6)=MNEQN
RGEOM(1)=GSUPE
RGEOM(2)=GLGTL
C
C**** SET UP THE POINTERS TO ELEMENTS IN ARRAYS IGEOM AND RGEOM
C
PARNT=5
HALEN=3
MIDPT=MNSUA+3
VTARG=2*MNSUA+3
C
C**** SET UP THE POINTERS TO ELEMENTS IN ARRAYS ISNPH AND RSNPH
C
DGPOL=7
JATYP=MNSUA+7
LOSUB=2*MNSUA+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
ERARC=3*NJIND+6*TNGQP+1
BCFSN=MNSUA+3*NJIND+6*TNGQP+1
SOLUN=MNEQN+MNSUA+3*NJIND+6*TNGQP+1
C
C**** SET UP THE POINTERS TO ELEMENTS IN ARRAYS IWORK,RWORK,ZWORK AND
C**** LWORK
C
IPIVT=1
LOQSB=MNEQN+1
NQUAD=MNJXS+MNEQN+1
HISUB=2*MNJXS+MNEQN+1
LOTES=MNSUA+2*MNJXS+MNEQN+1
HITES=2*MNSUA+2*MNJXS+MNEQN+1
AXION=3*MNSUA+2*MNJXS+MNEQN+1
NEWDG=4*MNSUA+2*MNJXS+MNEQN+1
ICOPY=5*MNSUA+2*MNJXS+MNEQN+1
LOOLD=6*MNSUA+2*MNJXS+MNEQN+1
HIOLD=7*MNSUA+2*MNJXS+MNEQN+1
WORK2=1
COLPR=MNEQN+1
A1COF=2*MNEQN+1
B1COF=MNJXS+2*MNEQN+1
TOLOU=2*MNJXS+2*MNEQN+1
XIDST=3*MNJXS+2*MNEQN+1
XENPT=5*MNJXS+2*MNEQN+1
QCOMX=MQIN1+5*MNJXS+2*MNEQN+1
QCOMW=MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
RCOPY=2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
NEWHL=MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
AQCOF=2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
BQCOF=TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
CQCOF=2*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
COLSC=3*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
RIGLL=4*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
WORK=5*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
DIAG=2*NQPTS+5*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
SDIAG=3*NQPTS+5*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
WORKT=4*NQPTS+5*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+2*MNEQN+1
WORKQ=2*NQPTS*NQPTS+4*NQPTS+5*TNGQP+2*MNSUA+2*MNQUA+MQIN1+5*MNJXS+
+ 2*MNEQN+1
ZCOLL=1
XIVAL=MNEQN+1
NEWQU=1
LCOPY=MNJXS+1
PNEWQ=MNSUA+MNJXS+1
LNSEG=2*MNSUA+MNJXS+1
C
C**** ASSIGN THE JACOBI INDECES FOR EACH ARC.
C
CALL ANGLE7(RSNPH(JACIN),NARCS,INTER)
RSNPH(JACIN+NJIND-1)=0E+0
C
C**** SET SUB-TOLERANCES AND INDEG
C
IF (INCST .AND. GSUPE.LE.3.16E-2) THEN
C
C**** FOLLOW INCREMENTAL STRATEGY
C
SSUPE=1E-1
TGTER=SSUPE*SFACT
AQTOL=TGTER*QFACT
LGTOL=LOG(1E+0+TGTER)
RQTOL=AQTOL
INDEG=MIN(3,NQPTS-1)
ELSE
C
C**** SUB-TOLERANCES SAME AS GLOBAL TOLERANCES, INDEG DETERMINED
C**** ACCORDING TO ACCURACY REQUESTED
C
SSUPE=GSUPE
TGTER=GTGTE
AQTOL=GAQTL
LGTOL=GLGTL
RQTOL=GRQTL
INDEG=NINT(-LOG10(TGTER))+2
INDEG=MIN(INDEG,NQPTS-1)
ENDIF
C
C**** ASSIGN THE LOGICAL LINE SEGMENT TYPE TO EACH ARC.
C
CALL LINSEG(LWORK(LNSEG),NARCS)
C
C**** LIST THE INPUT ARGUMENTS AND ASSOCIATED QUANTITIES
C
CALL RSLT80(JBNM,HEAD,GSUPE,MAXER,GAQTL,INTER,NARCS,ORDSG,NQPTS,
+INCST,INDEG,RFARC,RFARG,CENTR,RSNPH(JACIN),LWORK(LNSEG),
+TSTNG,OULVL,IBNDS,MNEQN,OCH)
PI=4E+0*ATAN(1E+0)
RFARG=RFARG*PI
C
C**** SET UP THE GAUSS-JACOBI AND GAUSS-LEGENDRE QUADRATURE DATA AND
C**** STORE IN ARRAYS QUPTS AND QUWTS. SET UP THREE TERM RECURRENCE
C**** COEFFICIENTS AND STORE IN ACOEF, BCOEF. DETERMINE ZEROTH
C**** MOMENTS OF JACOBI DISTRIBUTIONS AND STORE IN H0VAL.
C**** ALSO SET UP THREE TERM RECURRENCE COEFFICIENTS AND ZEROTH MOMENTS
C**** FOR THE INTEGRATED POLYNOMIALS, STORING RESULTS IN AICOF,BICOF
C**** AND HIVAL.
C
CALL OPQUD1(NJIND,NQPTS,RSNPH(JACIN),RSNPH(ACOEF),RSNPH(BCOEF),
+RSNPH(H0VAL),RSNPH(AICOF),RSNPH(BICOF),RSNPH(HIVAL),RSNPH(QUPTS),
+RSNPH(QUWTS),RWORK(WORK),IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
J=1-NQPTS
DO 10 I=1,NJIND
J=J+NQPTS
RWORK(A1COF+I-1)=RSNPH(ACOEF+J-1)
RWORK(B1COF+I-1)=RSNPH(BCOEF+J-1)
10 CONTINUE
WRITE(*,1) 'BASIC GAUSS QUADRATURE DATA DONE:'
C
C**** SET UP THE COEFFICIENTS IN THE THREE TERM RECURRENCE FORMULAE
C**** FOR THE PRINCIPAL SINGULAR INTEGRALS ASSOCIATED WITH THE VARIOUS
C**** JACOBI WEIGHT FUNCTIONS AND THEIR ORTHONORMAL POLYNOMIALS; STORE
C**** THESE COEFFICIENTS IN AQCOF, BQCOF AND CQCOF
C
CALL ASQUC7(RWORK(AQCOF),RWORK(BQCOF),RWORK(CQCOF),RSNPH(JACIN),
+NJIND,NQPTS)
WRITE(*,1) 'DATA FOR SINGULAR INTEGRALS DONE:'
C
C**** SET UP THE A PRIORI COLUMN SCALE FACTORS, STORED IN COLSC.
C
CALL CSCAL3(RWORK(COLSC),NQPTS,NJIND,RSNPH(ACOEF),RSNPH(BCOEF),
+RSNPH(H0VAL),RSNPH(QUPTS),RSNPH(QUWTS),RSNPH(JACIN),RWORK(WORK),
+RWORK(WORKT),RWORK(WORKQ))
C
C**** SET UP THE ARRAY RIGLL OF REFERENCE IGNORE LEVELS.
C
CALL IGNLVL(RWORK(RIGLL),RWORK(COLSC),RSNPH(ACOEF),RSNPH(BCOEF),
+RSNPH(H0VAL),RSNPH(JACIN),NJIND,NQPTS,IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
C**** SET UP THE ARRAY OF COLLOCATION POINTS PARAMETER VALUES, COLPR,
C**** THE ARRAY OF COLLOCATION POINTS ZCOLL AND THE ARRAYS LOSUB AND
C**** HISUB NEEDED TO ACCESS COLPR AND ZCOLL CORRECTLY. INITIALISE
C**** DGPOL AND UPDATE LNSEG FOR ARC HALVING.
C
CALL CPJAC3(NARCS,NQPTS,INDEG,ISNPH(DGPOL),RSNPH(JACIN),
+RSNPH(ACOEF),RSNPH(BCOEF),RWORK(DIAG),RWORK(SDIAG),TNSUA,
+ISNPH(LOSUB),IWORK(HISUB),ISNPH(JATYP),IGEOM(PARNT),RGEOM(MIDPT),
+RGEOM(HALEN),RWORK(COLPR),ZWORK(ZCOLL),LWORK(LNSEG),IWORK(LOOLD),
+IWORK(HIOLD),EPS,IER,INIBT)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
NCOLL=IWORK(HISUB+TNSUA-1)
NEQNS=NCOLL+1
NROWS=NCOLL/ORDSG+1
IF (NEQNS .GT. MNEQN) THEN
IER=8
GOTO 999
ENDIF
WRITE(*,1) 'COLLOCATION POINT CHOICE DONE:'
C
C**** SET UP THE COMPOSITE GAUSSIAN QUADRATURE RULES, STORING ABSCISSAE
C**** AND WEIGHTS IN QCOMX AND QCOMW. SET UP ARRAYS NQUAD,LOQSB
C**** NEEDED TO ACCESS THESE DATA. RECORD MAXIMUM QUADRATURE ERRORS
C**** FOR COLUMN SCALED INTEGRALS IN ARRAY TOLOU.
C
CALL ICOQR1(NARCS,NJIND,NQPTS,MDGPO,MQIN1,AQTOL,RSNPH(QUPTS),
+RSNPH(QUWTS),RSNPH(JACIN),RGEOM(MIDPT),RGEOM(HALEN),RSNPH(ACOEF),
+RSNPH(BCOEF),RSNPH(H0VAL),RWORK(COLSC),IWORK(NQUAD),IWORK(LOQSB),
+RWORK(QCOMX),RWORK(QCOMW),MNQUA,RWORK(TOLOU),MCQER,RWORK(XENPT),
+ZWORK(XIVAL),RWORK(XIDST),IER)
NUQTL=.FALSE.
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'COMPOSITE GAUSSIAN RULES DONE:'
C
C**** SET UP LINEAR ALGEBRAIC SYSTEM.
C
23 CONTINUE
SOLCO=SOLCO+1
WRITE(*,24) '********SOLUTION',SOLCO,'********',NROWS,'EQUATIONS'
24 FORMAT(/,T18,A,1X,I2,1X,A,/,T25,I3,1X,A)
C
CALL LNSY11(MATRX,RSNPH(SOLUN),MNEQN,NCOLL,ORDSG,REFLN,NQPTS,
+TNSUA,ISNPH(JATYP),IGEOM(PARNT),ISNPH(DGPOL),ISNPH(LOSUB),
+IWORK(HISUB),IWORK(NQUAD),IWORK(LOQSB),TOLNR,RGEOM(MIDPT),
+RGEOM(HALEN),RSNPH(H0VAL),RWORK(COLSC),RSNPH(ACOEF),RSNPH(BCOEF),
+RWORK(COLPR),RWORK(QCOMX),RWORK(QCOMW),CENTR,ZWORK(ZCOLL),INTER,
+LWORK(LNSEG),RWORK(WORK),QIERR,MQERR,RSNPH(JACIN),RWORK(A1COF),
+RWORK(B1COF),AQTOL,RQTOL,RWORK(AQCOF),RWORK(BQCOF),RWORK(CQCOF),
+IWORK(LOOLD),IWORK(HIOLD))
C
DO 25 I=0,6
QIERC(I)=QIERC(I)+QIERR(I)
25 CONTINUE
WRITE(*,1) 'LINEAR SYSTEM SET UP DONE:'
C
C**** SOLVE LINEAR SYSTEM BY GAUSSIAN ELIMINATION USING LINPACK
C
CALL SGECO(MATRX(1,1,2),MNEQN,NROWS,IWORK(IPIVT),RCOND,
+RWORK(WORK2))
IF (RCOND .EQ. 0E+0) THEN
IER=15
SOLCO=SOLCO-1
GOTO 999
ENDIF
CALL SGESL(MATRX(1,1,2),MNEQN,NROWS,IWORK(IPIVT),RSNPH(SOLUN),0)
NEFF=NEFF+NROWS**3
WRITE(*,1) 'LINEAR SYSTEM SOLUTION DONE:'
C
C**** RECONSTITUTE FULL SOLUTION VECTOR
C
IF (ORDSG.GT.1) THEN
CALL RECON(ORDSG,REFLN,NCOLL,TNSUA,ISNPH(LOSUB),IWORK(HISUB),
+ RSNPH(SOLUN))
ENDIF
CONST=RSNPH(SOLUN+NEQNS-1)
C
C**** SET UP THE ARRAY WORK2 OF ACTUAL COEFFICIENT IGNORE LEVELS
C
CALL SETIGL(RWORK(WORK2),IWORK(HISUB),ISNPH(JATYP),ISNPH(LOSUB),
+NQPTS,RWORK(RIGLL),TNSUA)
C
C**** DETERMINE THE ACTIONS THAT HAVE TO BE TAKEN ON EACH ARC
C
CALL AXION1(IWORK(AXION),IWORK(NEWDG),RSNPH(SOLUN),MDGPO,TNSUA,
+ISNPH(DGPOL),ISNPH(LOSUB),IWORK(HISUB),RWORK(RIGLL),LGTOL,ACCPT,
+RSNPH(JACIN),ISNPH(JATYP),NJIND,RWORK(NEWHL),ESTOL,IER)
ESTOL=ESTOL/SFACT
IF (IER.GT.0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'DECISIONS FOR EACH ARC DONE:'
WRITE(*,3) 'EFFECTIVE STOPPING TOLERANCE:',ESTOL
IF (ACCPT .AND. ESTOL.LE.GSUPE) THEN
GACPT=.TRUE.
ELSE
GACPT=.FALSE.
ENDIF
C
IF (GACPT) THEN
C
C**** OUTPUT RESULTS
C
IF (OULVL .LT. 4) THEN
CALL RSLT72(QIERC,RCOND,CONST,NROWS,ISNPH(DGPOL),ISNPH(JATYP),
+ IGEOM(PARNT),TNSUA,INTER,MQERR,MCQER,IWORK(AXION),
+ IWORK(NEWDG),NJIND,IWORK(NQUAD),RWORK(TOLOU),
+ LGTOL,SOLCO,OCH)
ELSE
CALL RSLT71(QIERC,RCOND,RSNPH(SOLUN),NEQNS,ISNPH(LOSUB),
+ IWORK(HISUB),RWORK(COLSC),NQPTS,ISNPH(JATYP),
+ IGEOM(PARNT),TNSUA,INTER,MQERR,MCQER,RWORK(WORK2),
+ IWORK(AXION),IWORK(NEWDG),NJIND,RSNPH(JACIN),
+ IWORK(NQUAD),RWORK(TOLOU),LGTOL,SOLCO,OCH)
ENDIF
WRITE(OCH,*) 'EFFECTIVE STOPPING TOLERANCE :',ESTOL
NEFF=NINT(REAL(NEFF)**3.3333333E-1)
WRITE(*,54) '****THE SOLUTION IS ACCEPTED****'
WRITE(*,55) 'EFFECTIVE SIZE OF ALL SYSTEMS:',NEFF
IF (INTER) THEN
WRITE(*,3) 'ZERO:',CONST
ELSE
WRITE(*,56) 'CAPACITY:',EXP(-CONST)
ENDIF
54 FORMAT(/,T17,A)
55 FORMAT(/,A45,I4)
56 FORMAT(A45,E16.8)
WRITE(OCH,*)
WRITE(OCH,*) '****THE SOLUTION IS ACCEPTED****'
WRITE(OCH,*) 'EFFECTIVE SIZE OF ALL SYSTEMS : ',NEFF
WRITE(OCH,*)
ELSE
IF (ACCPT .OR. ESTOL.LE.SSUPE) THEN
C
C**** SOLUTION AT INTERMEDIATE ACCURACY IS ACCEPTED; SET TOLERANCES
C**** FOR GREATER ACCURACY AND RE-ASSESS UPDATING ACTIONS BEFORE
C**** CONTINUING
C
SSUPE=1E-1*MIN(SSUPE,ESTOL)
TGTER=SFACT*SSUPE
IF (TGTER .LE. 2E+0*GTGTE) THEN
TGTER=GTGTE
ENDIF
AQTOL=TGTER*QFACT
NUQTL=.TRUE.
LGTOL=LOG(1E+0+TGTER)
RQTOL=AQTOL
I=NINT(-LOG10(TGTER))+2
INDEG=MIN(I,MDGPO)
C
C**** DETERMINE THE ACTIONS THAT HAVE TO BE TAKEN ON EACH ARC
C
CALL AXION1(IWORK(AXION),IWORK(NEWDG),RSNPH(SOLUN),MDGPO,
+ TNSUA,ISNPH(DGPOL),ISNPH(LOSUB),IWORK(HISUB),
+ RWORK(RIGLL),LGTOL,ACCPT,RSNPH(JACIN),
+ ISNPH(JATYP),NJIND,RWORK(NEWHL),ESTOL,IER)
ESTOL=ESTOL/SFACT
IF (IER.GT.0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'DECISIONS FOR EACH ARC RE-DONE:'
ENDIF
C
C**** OUTPUT RESULTS
C
IF (OULVL .LT. 4) THEN
CALL RSLT72(QIERC,RCOND,CONST,NROWS,ISNPH(DGPOL),ISNPH(JATYP),
+ IGEOM(PARNT),TNSUA,INTER,MQERR,MCQER,IWORK(AXION),
+ IWORK(NEWDG),NJIND,IWORK(NQUAD),RWORK(TOLOU),
+ LGTOL,SOLCO,OCH)
ELSE
CALL RSLT71(QIERC,RCOND,RSNPH(SOLUN),NEQNS,ISNPH(LOSUB),
+ IWORK(HISUB),RWORK(COLSC),NQPTS,ISNPH(JATYP),
+ IGEOM(PARNT),TNSUA,INTER,MQERR,MCQER,RWORK(WORK2),
+ IWORK(AXION),IWORK(NEWDG),NJIND,RSNPH(JACIN),
+ IWORK(NQUAD),RWORK(TOLOU),LGTOL,SOLCO,OCH)
ENDIF
WRITE(OCH,*) 'EFFECTIVE STOPPING TOLERANCE :',ESTOL
IF (RCOND .LT. 5E+0*MCHEP) THEN
IER=16
GOTO 999
ELSE IF (RCOND .LT. AQTOL) THEN
NUQTL=.TRUE.
AQTOL=1E-1*RCOND
IF (AQTOL .LT. 5E+0*MCHEP) AQTOL=5E+0*MCHEP
ENDIF
C
C**** IMPLEMENT UPDATING PROCEDURES.
C**** FIRST UPDATE THE COLLOCATION PARAMETERS AND OTHER DATA
C**** RELATING TO SUB-ARC DEFINITIONS.
C
CALL UPJAC1(NQPTS,NJIND,INDEG,IWORK(AXION),ISNPH(DGPOL),
+ IWORK(NEWDG),RSNPH(ACOEF),RSNPH(BCOEF),RWORK(DIAG),
+ RWORK(SDIAG),TNSUA,MNSUA,ISNPH(LOSUB),IWORK(HISUB),
+ ISNPH(JATYP),IGEOM(PARNT),RGEOM(MIDPT),RGEOM(HALEN),
+ RWORK(COLPR),ZWORK(ZCOLL),LWORK(LNSEG),LWORK(PNEWQ),EPS,IER,
+ RWORK(WORK),RWORK(NEWHL),RWORK(RCOPY),IWORK(ICOPY),
+ LWORK(LCOPY),IWORK(LOOLD),IWORK(HIOLD))
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'ARC REFINEMENTS DONE:'
NCOLL=IWORK(HISUB+TNSUA-1)
NEQNS=NCOLL+1
NROWS=NCOLL/ORDSG+1
IF (NEQNS .GT. MNEQN) THEN
IER=18
GOTO 999
ENDIF
C
C**** NEXT UPDATE THE COMPOSITE QUADRATURE RULES
C
CALL UPCOQ1(NARCS,NJIND,NQPTS,MDGPO,MQIN1,AQTOL,RSNPH(QUPTS),
+ RSNPH(QUWTS),RSNPH(JACIN),RGEOM(MIDPT),RGEOM(HALEN),
+ RSNPH(ACOEF),RSNPH(BCOEF),RSNPH(H0VAL),RWORK(COLSC),
+ IWORK(NQUAD),IWORK(LOQSB),RWORK(QCOMX),RWORK(QCOMW),
+ MNQUA,RWORK(TOLOU),MCQER,RWORK(XENPT),ZWORK(XIVAL),
+ RWORK(XIDST),TNSUA,LWORK(PNEWQ),LWORK(NEWQU),ISNPH(JATYP),
+ IGEOM(PARNT),NUQTL,IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
WRITE(*,1) 'QUADRATURE UPDATES DONE:'
GOTO 23
ENDIF
C
IF (OULVL.EQ.2 .OR. OULVL.EQ.3) THEN
CALL RSLT71(QIERC,RCOND,RSNPH(SOLUN),NEQNS,ISNPH(LOSUB),
+ IWORK(HISUB),RWORK(COLSC),NQPTS,ISNPH(JATYP),IGEOM(PARNT),TNSUA,
+ INTER,MQERR,MCQER,RWORK(WORK2),IWORK(AXION),IWORK(NEWDG),NJIND,
+ RSNPH(JACIN),IWORK(NQUAD),RWORK(TOLOU),LGTOL,SOLCO,OCH)
ENDIF
C
C**** ESTIMATE MAXIMUM ERROR IN MODULUS.
C
WRITE(*,*)
WRITE(*,1) 'ERRORS IN MODULUS STARTED:'
C
CALL TSJAC3(IWORK(LOTES),IWORK(HITES),RWORK(COLPR),ZWORK(ZCOLL),
+NQPTS,NTEST,ORDSG,TNSUA,TSTNG,ISNPH(DGPOL),ISNPH(JATYP),
+IGEOM(PARNT),RSNPH(AICOF),RSNPH(BICOF),RWORK(DIAG),RGEOM(HALEN),
+RSNPH(JACIN),RGEOM(MIDPT),RWORK(SDIAG),IER)
IF (IER .GT. 0) THEN
GOTO 999
ENDIF
C
CALL TESMD9(RWORK(WORK2),MATRX(1,1,2),RSNPH(SOLUN),MNEQN,NCOLL,
+NTEST,NQPTS,TNSUA,ISNPH(JATYP),IGEOM(PARNT),ISNPH(DGPOL),
+ISNPH(LOSUB),IWORK(HISUB),IWORK(LOTES),IWORK(HITES),IWORK(NQUAD),
+IWORK(LOQSB),TOLNR,RGEOM(MIDPT),RGEOM(HALEN),RSNPH(H0VAL),
+RWORK(COLSC),RSNPH(ACOEF),RSNPH(BCOEF),RWORK(COLPR),RWORK(QCOMX),
+RWORK(QCOMW),CENTR,ZWORK(ZCOLL),INTER,LWORK(LNSEG),RWORK(WORK),
+QIERR,MQERR,RSNPH(JACIN),RWORK(A1COF),RWORK(B1COF),AQTOL,RQTOL,
+RWORK(AQCOF),RWORK(BQCOF),RWORK(CQCOF),MXERM,IMXER,ZMXER,
+RSNPH(ERARC),ORDSG,REFLN)
C
WRITE(*,1) 'ERRORS IN MODULUS DONE:'
WRITE(*,3) 'MAXIMUM ERROR AT TEST POINTS:',MXERM
DO 60 I=0,6
QIERC(I)=QIERC(I)+QIERR(I)
60 CONTINUE
IF (MOD(OULVL,2) .EQ. 1) THEN
CALL RSLT84(RWORK(WORK2),TNSUA,MXERM,ZMXER,IMXER,IWORK(LOTES),
+ IWORK(HITES),QIERC,IGEOM(PARNT),ORDSG,OCH)
ELSE
CALL RSLT83(RSNPH(ERARC),TNSUA,MXERM,ZMXER,IMXER,QIERC,
+ IGEOM(PARNT),ORDSG,OCH)
ENDIF
C
C**** RESCALE SOLUTIONS TO OBTAIN STANDARD JACOBI COEFFICIENTS
CALL RESCAL(NQPTS,TNSUA,ISNPH(LOSUB),IWORK(HISUB),ISNPH(JATYP),
+RSNPH(SOLUN),RWORK(COLSC))
999 CONTINUE
C
CALL WRTAIL(1,OCH,IER)
CLOSE(OCH)
C
IF (SOLCO .GE. 1) THEN
C
C**** COMPUTE THE BOUNDARY CORRESPONDENCE COEFFICIENTS BCFSN AND THE
C**** ARGUMENTS OF ALL SUBARC END POINTS ON THE UNIT DISC,
C**** AS REQUIRED BY SUBSEQUENT PROCESSING ROUTINES.
C
CALL BCFVTF(RSNPH(BCFSN),RGEOM(VTARG),ISNPH(DGPOL),ISNPH(JATYP),
+ ISNPH(LOSUB),IGEOM(PARNT),RFARC,TNSUA,RSNPH(H0VAL),RSNPH(JACIN),
+ RFARG,RSNPH(SOLUN))
C
C**** OUTPUT DATA REQUIRED FOR POST-PROCESSING.
C
IGEOM(3)=TNSUA
ISNPH(3)=TNSUA
ISNPH(4)=NEQNS
C
OFL=JBNM(1:L)//'gm'
OPEN(OCH,FILE=OFL)
CALL OUPTGM(IGEOM,RGEOM,CENTR,INTER,OCH)
CLOSE(OCH)
C
OFL=JBNM(1:L)//'ph'
OPEN(OCH,FILE=OFL)
CALL OUPTPH(ISNPH,RSNPH,OCH)
CLOSE(OCH)
ENDIF
C
CALL WRTAIL(1,0,IER)
C
END
SUBROUTINE JCFIM5(DGPOC,IER,JTYPC,LSUBC,PHPAS,PRNSA,SOLNC,TNSUC,
+VARGC,AICOF,ACOEF,ACOFC,BICOF,BCFSN,BCOEF,BCOFC,CENTR,DGPOL,ERARC,
+H0VAL,H0VLC,HIVAL,HALEN,INTER,JACIN,JAINC,JATYP,LGTOL,LOSUB,MIDPT,
+MNCOF,MNSUC,NJIND,NQPTS,PARNT,QUPTC,QUWTC,RIGLL,SOLUN,NEWTL,VTARG)
C
INTEGER DGPOC(*),DGPOL(*),IER,JATYP(*),JTYPC(*),LOSUB(*),LSUBC(*),
+MNCOF,MNSUC,NJIND,NQPTS,PARNT(*),PRNSA(*),TNSUC
REAL AICOF(*),ACOEF(*),ACOFC(*),BICOF(*),BCFSN(*),BCOEF(*),
+BCOFC(*),ERARC(*),H0VAL(*),H0VLC(*),HIVAL(*),HALEN(*),JACIN(*),
+JAINC(*),LGTOL,MIDPT(*),QUPTC(*),QUWTC(*),PHPAS(*),RIGLL(*),
+SOLUN(*),NEWTL,VARGC(*),VTARG(*)
COMPLEX CENTR,SOLNC(*)
LOGICAL INTER
C
C TO CARRY OUT A DYNAMIC ESTIMATION OF THE JACOBI COEFFICIENTS OF
C THE INVERSE COMPLEX DENSITY FUNCTIONS *RHO*; SEE #50 p115 et seq.
C
C IER=0 - NORMAL EXIT
C IER=30 - LOCAL PARAMETER *MNDG* BELOW NEEDS INCREASING
C IER=31 - LOCAL PARAMETER *MNQD* BELOW NEEDS INCREASING
C IER=32 - THE SUBROUTINE PARAMETER *TNSUC* HAS REACHED ITS MAXIMUM
C PERMITTED VALUE *MNSUC*; *MNSUC* SHOULD BE INCREASED IN
C CALLING PROGRAM
C IER=33 - THE REQUIRED TOTAL NUMBER OF JACOBI COEFFICIENTS FOR THE
C INVERSE BOUNDARY DENSITY EXCEEDS THE LIMIT *MNCOF*;
C *MNCOF* SHOULD BE INCREASED IN THE CALLING PROGRAM.
C
C LOCAL VARIABLES
C
INTEGER AJT,AJTC,DG,DGC,I,I1,IC,JT,JTC,K,K1,LOD,LODC,LOL,LOM,
+LOS,MNDG,MNQD,NQUAD,PSA,PT,QINTS
REAL AA,BB,BC1,BETA,BETAC,CONST,H0,H0C,H1,HA,HB1,HL,LL,MD,MXPT,
+QHLEN,R1MACH,RFAC,RRHS,RSLN,SJT,SJTC,TERM,TOLIW,TT,UU,XX
PARAMETER (MNDG=20,MNQD=128,RFAC=1E+1)
REAL JACOF(MNDG),QAB(MNQD),QWT(MNQD),SVAL(MNQD),TVAL(MNQD),
+WORK(MNDG)
COMPLEX NEW(MNDG),OLD(MNDG),RHOVL(MNQD)
EXTERNAL BISNEW,INVJCO,R1MACH
C
TOLIW=1E+1*R1MACH(4)
LOL=(NJIND-1)*NQPTS+1
IC=1
LOS=1
C
10 CONTINUE
C
IF (IC .GT. TNSUC) THEN
C
C NORMAL EXIT
C
IER=0
RETURN
ENDIF
C
C INITIALISATION FOR PARENT PHYSICAL SUBARC
C
PSA=PRNSA(IC)
DG=DGPOL(PSA)
JT=JATYP(PSA)
AJT=ABS(JT)
SJT=REAL(SIGN(1,JT))
LOD=(AJT-1)*NQPTS+1
BETA=JACIN(AJT)
H0=H0VAL(AJT)
H1=HIVAL(AJT)
LOM=LOSUB(PSA)
HL=HALEN(PSA)
MD=MIDPT(PSA)
PT=PARNT(PSA)
DO 20 I=1,DG+1
JACOF(I)=SOLUN(I+LOM-1)
20 CONTINUE
DO 30 I=2,DG+1,2
JACOF(I)=SJT*JACOF(I)
30 CONTINUE
C
C INITIALISATION FOR ARC NUMBER IC ON CIRCLE
C
40 CONTINUE
DO 50 I=1,NQPTS
OLD(I)=0E+0
50 CONTINUE
QINTS=1
QHLEN=1E+0
NQUAD=NQPTS
DGC=NQPTS-1
IF (DGC+1 .GT. MNDG) THEN
IER=30
RETURN
ENDIF
JTC=JTYPC(IC)
AJTC=ABS(JTC)
SJTC=REAL(SIGN(1,JTC))
LODC=(AJTC-1)*NQPTS+1
BETAC=JAINC(AJTC)
H0C=H0VLC(AJTC)
HA=(VARGC(IC+1)-VARGC(IC))*5E-1
RSLN=HA/ERARC(PSA)
MXPT=RSLN/RFAC
BC1=BETAC+1E+0
HB1=1E+0
C
C SET UP RIGHT HAND SIDE *CONST* FOR THE BOUNDARY CORRESPONDENCE
C EQUATION THAT WILL BE USED TO COMPUTE PHYSICAL PARAMETERS
C CORRESPONDING TO GIVEN POINTS ON THE CIRCLE.
C
IF (JT .LT. 0) THEN
CONST=VTARG(PSA+1)-VARGC(IC+1)
ELSE
CONST=VARGC(IC)-VTARG(PSA)
ENDIF
C
C SET UP AA,BB WHERE THE PHYSICAL ARC IS CORRESPONDS TO THE
C PARAMETER INTERVAL [AA,BB].
C
IF (PHPAS(IC+1) .LE. PHPAS(IC)) THEN
BB=1E+0
ELSE
BB=PHPAS(IC+1)
ENDIF
AA=PHPAS(IC)
60 CONTINUE
C
C SET UP THE (POSSIBLY) COMPOSITE QUADRATURE RULE BASED ON *QINTS*
C SUBINTERVALS
C
IF (NQUAD .GT. MNQD) THEN
IER=31
RETURN
ENDIF
DO 70 K1=1,NQPTS
I1=LODC+K1-1
QWT(K1)=HB1*QUWTC(I1)
QAB(K1)=-1E+0+QHLEN*(1E+0+QUPTC(I1))
70 CONTINUE
K1=NQPTS
DO 90 K=2,QINTS
DO 80 I=1,NQPTS
K1=K1+1
I1=LOL+I-1
XX=2E+0*K-1E+0+QUPTC(I1)
QWT(K1)=HB1*XX**BETAC*QUWTC(I1)
QAB(K1)=-1E+0+QHLEN*XX
80 CONTINUE
90 CONTINUE
C
C ESTIMATE THE JACOBI COEFFICIENTS FOR THE INVERSE DENSITY FOR
C ARC NUMBER IC ON THE CIRCLE.
C
CALL INVJCO(NEW,AICOF(LOD),AA,ACOEF(LOD),ACOFC(LODC),
+ BICOF(LOD),BB,BCFSN(LOM),BCOEF(LOD),BCOFC(LODC),BETA,BETAC,
+ CENTR,CONST,DGC,DG,H0,H0C,H1,HA,HL,IER,INTER,JACOF,JTC,MD,
+ NEWTL,NQUAD,PT,QAB,QWT,RHOVL,SJT,SJTC,SVAL,TOLIW,TVAL,WORK)
C
C CHECK THAT THE SIZE OF THE HIGHEST DEGREE COEFFICIENT IS SMALL
C ENOUGH.
C
TERM=ABS(NEW(NQPTS))*RIGLL(LODC+NQPTS-1)/LGTOL
IF (TERM .GT. 1E+0) THEN
C
C COEFFICIENT IS TOO LARGE - SUBDIVIDE CIRCULAR ARC AND RESTART.
C
C FIRST FIND THE LOCAL PHYSICAL PARAMETER *TT* CORRESPONDING TO
C THE MIDPOINT OF THE CURRENT CIRCULAR ARC NUMBER IC.
C
RRHS=CONST+HA
LL=AA
UU=BB
CALL BISNEW(IER,LL,TT,UU,AICOF(LOD),ACOEF(LOD),BICOF(LOD),
+ BCFSN(LOM),BCOEF(LOD),BETA,DG,H0,H1,JACOF,NEWTL,SJT,
+ RRHS,TOLIW)
IF (IER.GT.0) THEN
RETURN
ENDIF
C
C NEXT UPDATE VARIOUS DATA ITEMS TO DESCRIBE THE NEW SUBDIVISION
C OF THE CIRCLE.
C
DO 100 I=TNSUC+1,IC+1,-1
PHPAS(I+1)=PHPAS(I)
VARGC(I+1)=VARGC(I)
100 CONTINUE
PHPAS(IC+1)=TT
VARGC(IC+1)=(VARGC(IC+1)+VARGC(IC))*5E-1
DO 110 I=TNSUC,IC,-1
PRNSA(I+1)=PRNSA(I)
110 CONTINUE
DO 120 I=TNSUC,IC+1,-1
JTYPC(I+1)=JTYPC(I)
120 CONTINUE
IF (JTC .GT. 0) THEN
JTYPC(IC+1)=NJIND
ELSE
JTYPC(IC+1)=JTC
JTYPC(IC)=NJIND
ENDIF
TNSUC=TNSUC+1
IF (TNSUC .GE. MNSUC) THEN
IER=32
RETURN
ENDIF
C
C START AGAIN WITH THE NEW REFINED ARC NUMBER IC
C
GOTO 40
ENDIF
C
C ARC REFINEMENT DOES NOT SEEM TO BE REQUIRED. EXAMINE THE
C JACOBI COEFFICIENTS TO ESTIMATE THE DEGREE OF POLYNOMIAL
C APPROXIMATION REQUIRED AND ALSO TEST FOR CONVERGENCE OF THE
C SIGNIFICANT COEFFICIENTS.
C
130 CONTINUE
DGC=DGC-1
IF (DGC .LT. 0) THEN
C
C ACCEPT THAT A POLYNOMIAL APPROXIMATION OF DEGREE ZERO WILL
C DO FOR THIS ARC AND MOVE ON TO THE NEXT ARC.
C
DGPOC(IC)=0
LSUBC(IC)=LOS
IF (LOS .GT. MNCOF) THEN
IER=33
RETURN
ENDIF
SOLNC(LOS)=NEW(1)
LOS=LOS+1
IC=IC+1
GOTO 10
ENDIF
C
TERM=ABS(NEW(DGC+1))*RIGLL(LODC+DGC)/LGTOL
IF (TERM .LE. 1E+0) THEN
C
C THIS COEFFICIENT MAY BE IGNORED - CONSIDER THE COEFFICIENT FOR
C NEXT LOWER DEGREE POLYNOMIAL.
C
GOTO 130
ENDIF
C
C THE DEGREE IS POSSIBLY DGC+1; CHECK FOR CONVERGENCE OF THESE
C COEFFICIENTS.
C
I=DGC
140 CONTINUE
TERM=ABS(NEW(I+1)-OLD(I+1))*RIGLL(LODC+I)/LGTOL
IF (TERM .LE. 1E+0) THEN
C
C CONVERGENCE FOR THIS TERM
C
I=I-1
IF (I .GT. 0) THEN
C
C TAKE COEFFICIENT OF NEXT LOWER DEGREE.
C
GOTO 140
ELSE
C
C ALL COEFFICIENTS HAVE CONVERGED.
C
DGPOC(IC)=DGC+1
LSUBC(IC)=LOS
IF (LOS+DGC .GE. MNCOF) THEN
IER=33
RETURN
ENDIF
DO 150 I=1,DGC+2
SOLNC(LOS+I-1)=NEW(I)
150 CONTINUE
LOS=LOS+DGC+2
IC=IC+1
GOTO 10
ENDIF
ELSE
C
C THIS TERM HASN'T CONVERGED - TRY AGAIN WITH REFINED QUADRATURE
C RULE, IF RESOLUTION PERMITS.
C
QINTS=QINTS*2
NQUAD=QINTS*NQPTS
IF (NQUAD .GE. MXPT) THEN
C
C FURTHER REFINEMENT IS PRACTICALLY UNACCEPTABLE DUE TO LOCAL
C CROWDING - ACCEPT CURRENT SOLUTION
C
DGPOC(IC)=DGC+1
LSUBC(IC)=LOS
IF (LOS+DGC .GE. MNCOF) THEN
IER=33
RETURN
ENDIF
DO 160 I=1,DGC+2
SOLNC(LOS+I-1)=NEW(I)
160 CONTINUE
LOS=LOS+DGC+2
IC=IC+1
GOTO 10
ENDIF
QHLEN=QHLEN*5E-1
HB1=QHLEN**BC1
DGC=NQPTS-1
DO 170 I=1,NQPTS
OLD(I)=NEW(I)
170 CONTINUE
GOTO 60
ENDIF
C
END
SUBROUTINE LEVCUR(NCONT,RADII,NARGS,THETA,RAD1,RAD2,PSD,MINPD,
+MAXPD,INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,ZSNCA,IQUCA,ZQUCA,NEWD,
+CHNL,IER)
C
INTEGER NCONT,NARGS,CHNL,IER
INTEGER IGEOM(*),ISNCA(*),IQUCA(*)
REAL RAD1,RAD2,PSD,MINPD,MAXPD
REAL RADII(*),THETA(*),RGEOM(*),RSNCA(*)
COMPLEX CENTR
COMPLEX ZSNCA(*),ZQUCA(*)
LOGICAL INTER
CHARACTER NEWD*(*)
C
C ......................................................................
C
C 1. LEVCUR
C PRODUCES DATA FOR PLOTTING LEVEL CURVES ASSOCIATED WITH THE
C MAP : PHYSICAL --> CANONICAL.
C
C 2. PURPOSE
C THIS ROUTINE PRODUCES DATA FOR PLOTTING THE TWO FAMILIES OF
C LEVEL CURVES IN THE PHYSICAL DOMAIN DEFINED BY
C
C (1) {Z : ABS(F(Z)) = RADII(K) }, K=1,2,..,NCONT ,
C
C AND
C
C (2) {Z : ARG(F(Z)) = THETA(K) AND RAD1 <= ABS(F(Z)) <= RAD2} ,
C K=1,2,..
C
C WHERE F:PHYSICAL --> CANONICAL, RADII IS A GIVEN ARRAY OF
C RADII IN THE CANONICAL DOMAIN AND THETA IS AN ARRAY OF
C ARGUMENTS IN THE CANONICAL DOMAIN. HOWEVER, THETA NEED NOT
C BE GIVEN ON ENTERING THE ROUTINE, SINCE A DEFAULT PROVISION
C IS MADE TO TAKE THE RAYS IN THE CANONICAL PLANE WHICH
C TERMINATE AT CORNER POINT PRE-IMAGES.
C
C THE DATA IS AUTOMATICALLY OUTPUT TO THE FILE NAMED lc,
C WHERE IS COLLECTED FROM THE FILE jbnm. THE OUTPUT
C DATA POINTS ARE SELECTED ADAPTIVELY ACCORDING TO THE
C PLOTTING RESOLUTION SPECIFIED BY THE THREE ARGUMENTS PSD,
C MINPD AND MAXPD.
C
C
C 3. CALLING SEQUENCE
C CALL LEVCUR(NCONT,RADII,NARGS,THETA,RAD1,RAD2,PSD,MINPD,
C MAXPD,INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,ZSNCA,
C IQUCA,ZQUCA,NEWD,CHNL,IER)
C
C PARAMETERS
C ON ENTRY
C NCONT - INTEGER
C DEFINES THE NUMBER OF CONTOURS (1) WHICH ARE TO BE
C CONSIDERED. IF N.LT.1 THEN NO CONTOURS WILL BE
C CONSIDERED.
C
C RADII - REAL ARRAY
C REAL VECTOR OF SIZE AT LEAST MAX(NCONT,1).
C RADII(K), K=1,...,NCONT, DEFINES THE RADIUS IN
C THE CANONICAL DOMAIN FOR THE K'TH CONTOUR (1)
C ABOVE.
C
C NARGS - INTEGER
C DEFINES THE NUMBER OF RAYS (2) WHICH ARE TO BE
C CONSIDERED, AS FOLLOWS:
C NARGS.GE.1 - THE ARGUMENTS FOR THE RAYS (2) WILL
C BE THETA(K), K=1(1)NARGS.
C NARGS.LT.1 - THE ARGUMENTS FOR THE RAYS (2) WILL
C BE THOSE OF THE CORNER POINT PRE-
C IMAGES ON THE UNIT CIRCLE AND THE
C CONTENTS OF THETA WILL BE IRRELEVANT.
C
C THETA - REAL ARRAY
C REAL VECTOR OF SIZE AT LEAST MAX(NARGS,1).
C IF NARGS.GE.1 THEN THETA(K), K=1,...,NARGS,
C DEFINES THE ARGUMENT IN THE CANONICAL DOMAIN OF
C THE K'TH RAY (2) ABOVE. IF NARGS.LT.1 THEN THE
C CONTENTS OF THETA ARE IGNORED.
C
C RAD1 - REAL
C ALL RAYS IN THE CANONICAL PLANE START AT THE POINT
C WITH RADIUS EQUAL TO RAD1.
C
C RAD2 - REAL
C ALL RAYS IN THE CANONICAL PLANE END AT THE POINT
C WITH RADIUS EQUAL TO RAD2. IF RAD2.LE.RAD1 THEN
C NO RAYS WILL CONSIDERED.
C
C PSD - REAL
C THE PLOTTING SIZE FOR THE DOMAIN IN ANY APPROPR-
C IATE UNITS. IF PSD .LE. 0.0 THEN IT IS ASSIGNED
C THE DEFAULT VALUE OF 160.0 (A REASONBLE WIDTH IN
C MM FOR PLOTTING ON A4 PAPER).
C
C MINPD - REAL
C THE MINIMUM SIGNIFICANT PLOTTING DISTANCE, IN THE
C SAME UNITS AS PSD. IF PSD .LE. 0.0 THEN IT IS
C ASSIGNED THE DEFAULT VALUE OF 2.0.
C
C MAXPD - REAL
C THE MAXIMUM ALLOWED PLOTTING DISTANCE, IN THE
C SAME UNITS AS PSD. IF PSD .LE. 0.0 THEN IT IS
C ASSIGNED THE DEFAULT VALUE OF 5.0. THE LARGER
C MAXPD, THE COARSER WILL BE THE RESOLUTION OF THE
C BOUNDARY POINTS OUTPUT TO lc, BUT THE
C QUICKER THEY WILL BE COMPUTED.
C
C INTER - LOGICAL
C TRUE IF THE PHYSICAL DOMAIN IS INTERIOR, FALSE
C OTHERWISE.
C
C CENTR - COMPLEX
C THE POINT IN THE PHYSICAL PLANE THAT IS MAPPED
C TO THE CENTRE OF THE UNIT DISC. FOR
C EXTERIOR DOMAINS CENTR MUST BE SOME POINT IN THE
C COMPLEMENTARY INTERIOR PHYSICAL DOMAIN.
C
C IGEOM - INTEGER ARRAY
C THE INTEGER VECTOR IGEOM PREVIOUSLY SET UP BY
C JAPHYC.
C
C RGEOM - REAL ARRAY
C THE REAL VECTOR RGEOM PREVIOUSLY SET UP BY JAPHYC.
C
C ISNCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY JACANP.
C
C RSNCA - REAL ARRAY
C THE REAL VECTOR PREVIOUSLY SET UP BY JACANP.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY JACANP.
C
C IQUCA - INTEGER ARRAY
C THE INTEGER VECTOR PREVIOUSLY SET UP BY GQCANP.
C
C ZSNCA - COMPLEX ARRAY
C THE COMPLEX VECTOR PREVIOUSLY SET UP BY GQCANP.
C
C NEWD - CHARACTER
C A CHARACTER VARIABLE OF USER-DEFINED LENGTH WHICH
C DENOTES THE START OF A NEW DATA GROUP THAT THE
C USER MAY REQUIRE FOR GRAPH PLOTTING; SEE FURTHER
C COMMENTS BELOW.
C
C CHNL - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILE lc.
C
C ON EXIT
C RAD1 - REAL
C IF INTER IS TRUE AND RAD1.LT.0.0 ON ENTRY, THEN
C IT WILL HAVE THE 0.0 ON EXIT.
C IF INTER IS FALSE AND RAD1.LT.1.0 ON ENTRY, THEN
C IT WILL HAVE THE 1.0 ON EXIT.
C
C RAD2 - REAL
C IF INTER IS TRUE AND RAD2.GT.1.0 ON ENTRY, THEN
C IT WILL HAVE THE 1.0 ON EXIT.
C
C PSD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN IT WILL HAVE
C THE DEFAULT VALUE OF 160.0 ON EXIT.
C
C MINPD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN MINPD WILL HAVE
C THE DEFAULT VALUE OF 2.0 ON EXIT
C
C MAXPD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN MAXPD WILL HAVE
C THE DEFAULT VALUE OF 5.0 ON EXIT
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - A SUMMARY LISTING IS AUTOMATICALLY WRITTEN ON THE
C STANDARD OUTPUT CHANNEL.
C - THE PLOTTING DATA IS WRITTEN ON THE FILE lc .
C EACH CONTOUR OR RAY TO TO BE PLOTTED IN THE PHYSICAL
C DOMAIN CONTRIBUTES N+1 LINES TO lc, AS FOLLOWS
C
C X1 Y1
C X2 Y2
C .. ..
C XN YN
C WHERE DENOTES THE VALUE OF THE ARGUMENT NEWD
C (USED TO INDICATED THE START OF A NEW DATA GROUP), AND
C (X1,Y1), (X2,Y2),..., (XN,YN) ARE COORDINATES OF
C SUCCESSIVE POINTS ON THE RELEVANT LEVEL CURVE IN THE
C PHYSICAL DOMAIN. THE VALUE OF N WILL OF COURSE BE
C DIFFERENT FOR EACH LEVEL CURVE AND WILL ALSO DEPEND
C ON THE PLOTTING PRECISION REQUESTED.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 8 JULY 1990
C ......................................................................
C
C LOCAL VARAIBLES
C
INTEGER COARG,CLNO,IC,IR,L,MNSUA,MXTRY,NARCS,NJIND,NRAYS,PPNO,PT,
+TNGQP,TRY,VTARG
REAL DIAPHY,DIFF,DPD,HS,HT,MXRAD,PI,R1MACH,RMAX,RMEAN,RMIN,SC1,
+SC2,TH1,TH2,THET0,TMIN,TINC
COMPLEX WW(2),WEND,ZZ(2)
LOGICAL ATEND,NECES,WANTC,WANTR
CHARACTER OFL*6,JBNM*4
PARAMETER (MXTRY=5)
C
EXTERNAL DIAPHY,DMCANP,R1MACH,WRHEAD,WRTAIL
C
1 FORMAT(T12,A8,I4,A6,I4,A6,I4,A6)
2 FORMAT(T16,A4,I4,A6,I4,A6,I4,A6)
C
CALL WRHEAD(8,0)
C
C**** INITIALISE SOME VARIABLES
C
IER=0
WANTC=(NCONT.GE.1)
WANTR=(RAD2.GT.RAD1)
PI=4E+0*ATAN(1E+0)
NARCS=ISNCA(1)
MNSUA=IGEOM(4)
NJIND=NARCS+1
TNGQP=ISNCA(2)*NJIND
COARG=3*NJIND+6*TNGQP+2
VTARG=2*MNSUA+3
THET0=RGEOM(VTARG)
IF (INTER) THEN
IF (RAD1.LT.0E+0) RAD1=0E+0
IF (RAD2.GT.1E+0) RAD2=1E+0
ELSE
IF (RAD1.LT.1E+0) RAD1=1E+0
ENDIF
C
C**** NAME AND OPEN THE OUTPUT THE FILE TO RECEIVE PLOTTING DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'lc'
OPEN(CHNL,FILE=OFL)
C
C**** DETERMINE THE APPROXIMATE DIAMETER OF THE DOMAIN TO BE PLOTTED
C
DPD=DIAPHY(NARCS)
IF (.NOT. INTER) THEN
MXRAD=0E+0
DO 10 IC=1,NCONT
MXRAD=MAX(MXRAD,RADII(IC))
10 CONTINUE
IF (WANTR) MXRAD=MAX(MXRAD,RAD2)
DPD=MAX(ABS(ZSNCA(1))*MXRAD,DPD)
ENDIF
C
C**** SET DEFAULT PLOTTING DISTANCES, IF NECESSARY
C
IF (PSD.LE.0E+0) THEN
PSD=1.6E+2
MINPD=2E+0
MAXPD=5E+0
ENDIF
RMIN=MINPD*DPD/PSD
RMAX=MAXPD*DPD/PSD
RMEAN=5E-1*(RMIN+RMAX)
TMIN=SQRT(R1MACH(4))
C
C**** THE DO 50 LOOP DETERMINES THE IMAGE OF A CONTOUR
C
IF (WANTC) THEN
DO 50 IC=1,NCONT
PPNO=0
CLNO=0
SC1=RADII(IC)
HT=SC1*(MINPD+MAXPD)/PSD
WRITE(CHNL,*) NEWD
ATEND=.FALSE.
PT=1
TH1=THET0
WW(1)=SC1*CMPLX(COS(TH1),SIN(TH1))
CLNO=CLNO+1
CALL DMCANP(1,ZZ,WW,INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,ZSNCA,
+ IQUCA,ZQUCA,.FALSE.,IER)
IF (IER.GT.0) GOTO 999
PPNO=PPNO+1
WRITE(CHNL,20) ZZ(1)
20 FORMAT(2E16.8)
TINC=HT
TRY=0
C
30 CONTINUE
TH2=TH1+TINC
IF (TH2 .GT. RSNCA(COARG+PT)) THEN
PT=PT+1
TH2=RSNCA(COARG-1+PT)
NECES=.TRUE.
ELSE
NECES=.FALSE.
ENDIF
WW(2)=SC1*CMPLX(COS(TH2),SIN(TH2))
CLNO=CLNO+1
TRY=TRY+1
CALL DMCANP(1,ZZ(2),WW(2),INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,
+ ZSNCA,IQUCA,ZQUCA,.FALSE.,IER)
IF (IER.GT.0) GOTO 999
IF (TRY.LT.MXTRY) THEN
DIFF=ABS(ZZ(2)-ZZ(1))
IF (DIFF.GT.RMAX .OR. (DIFF.LT.RMIN .AND. (.NOT.NECES))) THEN
TINC=RMEAN*TINC/DIFF
IF (TINC.LE.TMIN) THEN
TINC=TMIN
GOTO 40
ELSE
IF (NECES) PT=PT-1
GOTO 30
ENDIF
ENDIF
ENDIF
40 CONTINUE
PPNO=PPNO+1
WRITE(CHNL,20) ZZ(2)
C
ATEND=(PT .GT. NARCS)
IF (.NOT. ATEND) THEN
ZZ(1)=ZZ(2)
WW(1)=WW(2)
TH1=TH2
TRY=0
GOTO 30
ENDIF
C
WRITE(*,1) 'CONTOUR ',IC,' DONE:',PPNO,' PTS ',CLNO,' TRIES'
50 CONTINUE
ENDIF
C
C**** THE DO 70 LOOP DETERMINES THE IMAGE OF A RAY
C
IF (WANTR) THEN
HS=(RAD2-RAD1)*(MINPD+MAXPD)/PSD
IF (NARGS.GE.1) THEN
NRAYS=NARGS
ELSE
NRAYS=NARCS
ENDIF
DO 70 IR=1,NRAYS
IF (NARGS.GE.1) THEN
WEND=CMPLX(COS(THETA(IR)),SIN(THETA(IR)))
ELSE
WEND=CMPLX(COS(RSNCA(COARG-1+IR)),SIN(RSNCA(COARG-1+IR)))
ENDIF
CLNO=0
PPNO=0
WRITE(CHNL,*) NEWD
SC1=RAD1
WW(1)=WEND*SC1
CLNO=CLNO+1
CALL DMCANP(1,ZZ,WW,INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,ZSNCA,
+ IQUCA,ZQUCA,.FALSE.,IER)
IF (IER.GT.0) GOTO 999
PPNO=PPNO+1
WRITE(CHNL,20) ZZ(1)
TINC=HS
TRY=0
C
60 CONTINUE
SC2=SC1+TINC
IF (SC2 .GT. RAD2) THEN
SC2=RAD2
ATEND=.TRUE.
ELSE
ATEND=.FALSE.
ENDIF
WW(2)=WEND*SC2
CLNO=CLNO+1
TRY=TRY+1
CALL DMCANP(1,ZZ(2),WW(2),INTER,CENTR,IGEOM,RGEOM,ISNCA,RSNCA,
+ ZSNCA,IQUCA,ZQUCA,.FALSE.,IER)
IF (IER.GT.0) GOTO 999
IF (TRY.LT.MXTRY) THEN
DIFF=ABS(ZZ(2)-ZZ(1))
IF (DIFF.GT.RMAX .OR. (DIFF.LT.RMIN .AND. (.NOT.ATEND))) THEN
TINC=RMEAN*TINC/DIFF
GOTO 60
ENDIF
ENDIF
PPNO=PPNO+1
WRITE(CHNL,20) ZZ(2)
C
IF (.NOT. ATEND) THEN
ZZ(1)=ZZ(2)
WW(1)=WW(2)
SC1=SC2
TRY=0
GOTO 60
ENDIF
C
WRITE(*,2) 'RAY ',IR,' DONE:',PPNO,' PTS ',CLNO,' TRIES'
70 CONTINUE
ENDIF
C
999 CALL WRTAIL(8,0,IER)
CLOSE(CHNL)
C
END
REAL FUNCTION LGGAM(X)
REAL X
C
C**** TO ESTIMATE THE LOGARITHM OF THE GAMMA FUNCTION FOR L A R G E
C**** POSITIVE VALUES OF X USING THE ASYMPTOTIC FORMULA FROM ABRAMOWITZ
C**** AND STEGUN, SECTION 6.1.41
C
REAL PI,W
C
PI=4E+0*ATAN(1E+0)
W=1E+0/X/X
LGGAM=
+((((W/9.9E+1-1E+0/1.4E+2)*W+1E+0/1.05E+2)*W-1E+0/3E+1)*W+1E+0)/
+(1.2E+1*X) + 5E-1*LOG(2E+0*PI) - X + (X-5E-1)*LOG(X)
C
END
SUBROUTINE LINSEG(LNSEG,NARCS)
INTEGER NARCS
LOGICAL LNSEG(*)
C
C**** TO DETERMINE THE ARRAY LNSEG, WHERE LNSEG(I) IS SET TO TRUE IF THE
C**** I'TH ARC IS A LINE SEGMENT, I=1,...,NARCS.
C
C**** LOCAL VARIABLES
C
INTEGER IA,J,NINTS,NPTS
REAL DIFF,HH,MXDIF,TOL,R1MACH
COMPLEX DPARFN,SUM,TT
PARAMETER(NPTS=9)
COMPLEX DF(NPTS)
EXTERNAL DPARFN,R1MACH
C
NINTS=NPTS-1
HH=2E+0/NINTS
TOL=1E+1*R1MACH(4)
C
DO 30 IA=1,NARCS
SUM=(0E+0,0E+0)
DO 10 J=1,NPTS
TT=CMPLX(-1E+0+(J-1)*HH)
DF(J)=DPARFN(IA,TT)
SUM=SUM+DF(J)
10 CONTINUE
SUM=SUM/NPTS
C
MXDIF=0E+0
DO 20 J=1,NPTS
DIFF=ABS(SUM-DF(J))
MXDIF=MAX(MXDIF,DIFF)
20 CONTINUE
C
IF (MXDIF .LE. TOL) THEN
LNSEG(IA)=.TRUE.
ELSE
LNSEG(IA)=.FALSE.
ENDIF
30 CONTINUE
C
END
SUBROUTINE LNSY11(MATRX,RGTSD,MNEQN,NCOLL,ORDSG,REFLN,NQPTS,TNSUA,
+JATYP,PARNT,DGPOL,LOSUB,HISUB,NQUAD,LOQSB,TOLNR,MIDPT,HALEN,H0VAL,
+COLSC,ACOEF,BCOEF,COLPR,QCOMX,QCOMW,CENTR,ZCOLL,INTER,LNSEG,
+WORK,QIERR,MQERR,JACIN,A1COF,B1COF,AQTOL,RQTOL,
+AQCOF,BQCOF,CQCOF,LOOLD,HIOLD)
C
INTEGER MNEQN,NCOLL,ORDSG,NQPTS,TNSUA,JATYP(*),PARNT(*),
+DGPOL(*),LOSUB(*),HISUB(*),NQUAD(*),LOQSB(*),QIERR(0:6),LOOLD(*),
+HIOLD(*)
C
REAL MATRX(MNEQN,MNEQN,2),RGTSD(*),TOLNR,MIDPT(*),HALEN(*),
+H0VAL(*),COLSC(*),ACOEF(*),BCOEF(*),COLPR(*),QCOMX(*),QCOMW(*),
+MQERR,WORK(*),A1COF(*),B1COF(*),AQTOL,
+JACIN(*),RQTOL,AQCOF(*),BQCOF(*),CQCOF(*)
C
COMPLEX CENTR,ZCOLL(*)
C
LOGICAL INTER,LNSEG(*),REFLN
C
C TO SET UP THE INITIAL COLLOCATION MATRIX (MATRX) AND THE RIGHT
C HAND SIDE VECTOR (RGTSD). WE ASSUME COLLOCATION DOES NOT TAKE
C PLACE AT END POINTS OF ARCS.
C
C.......................................................................
C THIS ROUTINE IS ADAPTED FROM LNSY10 AND IS DESIGNED TO FORM ONLY
C THOSE LINEAR EQUATIONS THAT ARISE FROM COLLOCATING AT POINTS ON
C THE FUNDAMENTAL PART OF THE BOUNDARY
C.......................................................................
C
C LOCAL VARIABLES
C
INTEGER I,J,I1,J1,J2,J3,JO,IA,IQ,IS,JI,AJI,PT,DG,LOM,HIM,LOQ,LOD,
+NQ,NCFBS,NROWS,NCOLS,ORDRG,TYPE,ISAMAX,IER,NVAL,IC,LOC,HIC,TSFBS
REAL MD,HL,RH,TQ,WQ,DD,LDD,SG,SJI,TC,C0,BETA,A1,B1,P0VAL,SCALE,
+FNVAL,U0,U1,CURR,PREV,NEXT,ABER0,ABER1
COMPLEX GTQ,ZQ,ZC,PARFUN,DPARFN
LOGICAL OLDIA
COMMON /FNDEF/BETA,A1,B1,P0VAL,SCALE,TYPE
EXTERNAL DPARFN,FNVAL,ISAMAX,JAPAR7,PARFUN,QAWS
C
NCFBS=NCOLL/ORDSG
TSFBS=TNSUA/ORDSG
NROWS=NCFBS+1
NCOLS=NCOLL+1
C
DO 2 J=1,NCOLS
DO 1 I=1,NROWS
MATRX(I,J,2)=0E+0
1 CONTINUE
2 CONTINUE
DO 3 I=0,6
QIERR(I)=0E+0
3 CONTINUE
MQERR=0E+0
C
C NOW SELECT THE INTEGRATION ARC
C
DO 120 IA=1,TNSUA
C
C INITIALISE DATA FOR THIS ARC
C
PT=PARNT(IA)
MD=MIDPT(IA)
HL=HALEN(IA)
DG=DGPOL(IA)
LOM=LOSUB(IA)
HIM=HISUB(IA)
JI=JATYP(IA)
IF (JI .LT. 0) THEN
SJI=-1E+0
ELSE
SJI=1E+0
ENDIF
AJI=ABS(JI)
LOD=(AJI-1)*NQPTS+1
RH=SQRT(H0VAL(AJI))
BETA=JACIN(AJI)
A1=A1COF(AJI)
B1=B1COF(AJI)
P0VAL=1E+0/RH
C
C ASSIGN THE NON-ZERO ELEMENT FOR THE SIDE EQUATION FOR THIS ARC
C
MATRX(NROWS,LOM,2)=RH*COLSC(LOD)
C
C SET UP THE DIAGONAL BLOCK OF SCALED PRINCIPAL SINGULAR INTEGRALS
C IF THIS DOESN'T ALREADY EXIST.
C
JO=LOOLD(IA)
OLDIA=(JO .GT. 0)
IF (.NOT.OLDIA .AND. HIM.LE.NCFBS) THEN
DO 35 I1=LOM,HIM
TC=SJI*COLPR(I1)
SCALE=COLSC(LOD)
TYPE=1
CALL QAWS(FNVAL,-1E+0,TC,BETA,0E+0,3,AQTOL,RQTOL,U0,ABER0,
+ NVAL,IER)
QIERR(IER)=QIERR(IER)+1
TYPE=2
CALL QAWS(FNVAL,TC,1E+0,0E+0,0E+0,2,AQTOL,RQTOL,U1,ABER1,
+ NVAL,IER)
QIERR(IER)=QIERR(IER)+1
WORK(1)=U0+U1
MQERR=MAX(MQERR,ABER0+ABER1)
IF (DG .GT. 0) THEN
SCALE=COLSC(LOD+1)
TYPE=3
CALL QAWS(FNVAL,-1E+0,TC,BETA,0E+0,3,AQTOL,RQTOL,U0,
+ ABER0,NVAL,IER)
QIERR(IER)=QIERR(IER)+1
TYPE=4
CALL QAWS(FNVAL,TC,1E+0,0E+0,0E+0,2,AQTOL,RQTOL,U1,
+ ABER1,NVAL,IER)
QIERR(IER)=QIERR(IER)+1
WORK(2)=U0+U1
MQERR=MAX(MQERR,ABER0+ABER1)
C
C NOW USE THE (WEAKLY) STABLE FORWARD RECURRENCE SCHEME
C FOR WORK(I),I=3,NQPTS (WITH SCALE FACTOR FOR WORK(2))
C
CURR=WORK(2)
PREV=SCALE
DO 10 I=1,DG-1
J=LOD+I-1
NEXT=(AQCOF(J)*TC-BQCOF(J))*CURR-CQCOF(J)*PREV
WORK(I+2)=NEXT
PREV=CURR
CURR=NEXT
10 CONTINUE
C
C ASSIGN CORRECT SCALE FACTORS.
C
DO 20 I=3,DG+1
J=LOD+I-1
WORK(I)=WORK(I)*COLSC(J)/SCALE
20 CONTINUE
ENDIF
C
SG=1E+0
DO 30 J=LOM,HIM
MATRX(I1,J,2)=MATRX(I1,J,2)+SG*WORK(J-LOM+1)
SG=SG*SJI
30 CONTINUE
C
35 CONTINUE
ENDIF
C
C INITIALISE SOME DATA FOR THE NON-SINGULAR INTEGRALS
C
WORK(1)=1E+0/RH
NQ=NQUAD(AJI)
LOQ=LOQSB(AJI)
C
DO 100 IQ=1,NQ
I=LOQ+IQ-1
TQ=QCOMX(I)
WQ=QCOMW(I)
CALL JAPAR7(WORK,TQ,ACOEF(LOD),BCOEF(LOD),DG)
IF (JI .LT. 0) THEN
TQ=-TQ
ENDIF
GTQ=CMPLX(MD+HL*TQ)
ZQ=PARFUN(PT,GTQ)
C
C ACCUMULATE ALL NEW ELEMENTS NOT ON THE DIAGONAL BLOCK
C
DO 55 IC=1,TSFBS
J2=LOOLD(IC)
IF (IC .NE. IA .AND. (J2 .EQ. 0 .OR. .NOT. OLDIA)) THEN
LOC=LOSUB(IC)
HIC=HISUB(IC)
DO 50 I1=LOC,HIC
ZC=ZCOLL(I1)
DD=ABS(ZC-ZQ)
LDD=LOG(DD)*WQ
SG=1E+0
DO 40 J1=LOM,HIM
J=J1-LOM+1
I=J1-LOM+LOD
MATRX(I1,J1,2)=MATRX(I1,J1,2)+SG*WORK(J)*LDD
+ *COLSC(I)
SG=SG*SJI
40 CONTINUE
50 CONTINUE
ENDIF
55 CONTINUE
C
C ACCUMULATE THE RESIDUAL NON-SINGULAR CONTRIBUTIONS INTO
C ANY NEW DIAGONAL BLOCK FOR THE NON-LINE-SEGMENT CASE.
C
IF (.NOT.LNSEG(IA) .AND. .NOT.OLDIA .AND. HIM.LE.NCFBS) THEN
DO 90 I1=LOM,HIM
TC=COLPR(I1)
DD=ABS(TC-TQ)
IF (DD .LE. TOLNR) THEN
DD=ABS(DPARFN(PT,GTQ))*HL
ELSE
ZC=ZCOLL(I1)
DD=ABS(ZC-ZQ)/DD
IF (DD.LT.TOLNR) DD=ABS(DPARFN(PT,GTQ))*HL
ENDIF
LDD=LOG(DD)*WQ
SG=1E+0
DO 80 J1=LOM,HIM
J=J1-LOM+1
I=J1-LOM+LOD
MATRX(I1,J1,2)=MATRX(I1,J1,2)+SG*WORK(J)*LDD*COLSC(I)
SG=SG*SJI
80 CONTINUE
90 CONTINUE
ENDIF
100 CONTINUE
C
C ACCUMULATE THE RESIDUAL NON-SINGULAR CONTRIBUTIONS INTO
C ANY NEW DIAGONAL BLOCK FOR THE LINE-SEGMENT CASE.
C
IF (LNSEG(IA) .AND. .NOT.OLDIA .AND. HIM.LE.NCFBS) THEN
ZC=DPARFN(PT,CMPLX(MD))*HL
C0=ABS(ZC)
C0=RH*LOG(C0)*COLSC(LOD)
DO 110 I1=LOM,HIM
MATRX(I1,LOM,2)=MATRX(I1,LOM,2)+C0
110 CONTINUE
ENDIF
C
C NOW COPY OVER ANY RELEVANT ELEMENTS ALREADY AVAILABLE IN
C MATRX(*,*,1)
C
IF (OLDIA) THEN
DO 118 IC=1,TSFBS
J2=LOOLD(IC)
IF (J2 .GT. 0) THEN
LOC=LOSUB(IC)
HIC=HISUB(IC)
J2=J2-1
DO 116 I1=LOC,HIC
J2=J2+1
DO 114 J1=LOM,HIM
J=J1+JO-LOM
MATRX(I1,J1,2)=MATRX(J2,J,1)
114 CONTINUE
116 CONTINUE
ENDIF
118 CONTINUE
ENDIF
C
120 CONTINUE
C
C SET UP THE LAST COLUMN
C
DO 130 I=1,NCFBS
MATRX(I,NCOLS,2)=1E+0
130 CONTINUE
C
C FINALLY SET UP THE RIGHT HAND SIDE VECTOR
C
IF (INTER) THEN
DO 140 I=1,NCFBS
ZC=ZCOLL(I)-CENTR
RGTSD(I)=LOG(ABS(ZC))
140 CONTINUE
ELSE
DO 150 I=1,NCFBS
RGTSD(I)=0E+0
150 CONTINUE
ENDIF
RGTSD(NROWS)=1E+0
C
C COPY MATRX(*,*,2) ONTO MATRX(*,*,1)
C
DO 156 J=1,NCOLS
DO 154 I=1,NROWS
MATRX(I,J,1)=MATRX(I,J,2)
154 CONTINUE
156 CONTINUE
C
C COMBINE COLUMNS OF MATRX(*,*,2) TOGETHER ACCORDING TO SYMMETRY
C SPECIFICATIONS
C
IF (ORDSG.GT.1) THEN
IF (REFLN) THEN
ORDRG=ORDSG/2
DO 180 IS=2,ORDRG
LOM=(IS-1)*NCFBS*2
DO 170 I=1,NROWS
DO 160 J=1,NCFBS*2
J1=LOM+J
MATRX(I,J,2)=MATRX(I,J,2)+MATRX(I,J1,2)
160 CONTINUE
170 CONTINUE
180 CONTINUE
DO 220 IA=1,TSFBS
J1=LOSUB(IA)
J2=HISUB(IA)
LOM=LOSUB(2*TSFBS+1-IA)-J1
SG=-1E+0
DO 210 J=J1,J2
SG=-SG
J3=LOM+J
DO 190 I=1,NROWS
MATRX(I,J,2)=MATRX(I,J,2)+SG*MATRX(I,J3,2)
190 CONTINUE
210 CONTINUE
220 CONTINUE
ELSE
DO 250 IS=2,ORDSG
LOM=(IS-1)*NCFBS
DO 240 I=1,NROWS
DO 230 J=1,NCFBS
J1=LOM+J
MATRX(I,J,2)=MATRX(I,J,2)+MATRX(I,J1,2)
230 CONTINUE
240 CONTINUE
250 CONTINUE
ENDIF
C
DO 260 I=1,NROWS
MATRX(I,NROWS,2)=MATRX(I,NCOLS,2)
260 CONTINUE
ENDIF
C
END
REAL FUNCTION MDNBT(ALFA,BETA)
REAL ALFA,BETA
C
C MDNBT IS THE MEDIAN OF THE BETA DISTRIBUTION DEFINED BY THE
C DENSITY (1-X)**ALFA * (1+X)**BETA ON (-1,1).
C
C LOCAL VARIABLES..
C
INTEGER N
REAL TOL,R1MACH,CC,CONST,SOLD,SNEW,SMNAB,GAMMA,FF,AA,BB,SS
EXTERNAL R1MACH,SMNAB,GAMMA
C
TOL=1E+2*R1MACH(4)
C
IF (ABS(ALFA-BETA) .LE. TOL) THEN
MDNBT=0E+0
RETURN
ENDIF
C
IF (ALFA .GT. BETA) THEN
CC=BETA+1E+0
ELSE
CC=ALFA+1E+0
ENDIF
C
FF=1E+0
AA=ALFA+1E+0
BB=BETA+1E+0
SS=ALFA+BETA+2E+0
C
10 CONTINUE
IF (AA .GT. 3E+1) THEN
FF=(AA-1E+0)*FF/(SS-1E+0)
AA=AA-1E+0
SS=SS-1E+0
GOTO 10
ENDIF
C
20 CONTINUE
IF (BB .GT. 3E+1) THEN
FF=(BB-1E+0)*FF/(SS-1E+0)
BB=BB-1E+0
SS=SS-1E+0
GOTO 20
ENDIF
C
CONST=5E-1*FF*GAMMA(AA)/GAMMA(SS)
CONST=CONST*GAMMA(BB)
C
N=0
SOLD=(CC*CONST)**(1E+0/CC)
C
30 CONTINUE
N=N+1
IF (ALFA .GT. BETA) THEN
SNEW=(CONST/SMNAB(N,ALFA,BETA,SOLD))**(1E+0/CC)
ELSE
SNEW=(CONST/SMNAB(N,BETA,ALFA,SOLD))**(1E+0/CC)
ENDIF
C
IF (ABS(1E+0-SOLD/SNEW) .GE. TOL) THEN
SOLD=SNEW
GOTO 30
ENDIF
C
IF (ALFA .GT. BETA) THEN
MDNBT=2E+0*SNEW-1E+0
ELSE
MDNBT=1E+0-2E+0*SNEW
ENDIF
C
END
SUBROUTINE OPQUD1(NJIND,NQPTS,JACIN,ACOEF,BCOEF,H0VAL,AICOF,BICOF,
+HIVAL,QUPTS,QUWTS,WORK,IER)
INTEGER NJIND,NQPTS,IER
REAL JACIN(*),ACOEF(*),BCOEF(*),H0VAL(*),QUPTS(*),QUWTS(*),
+WORK(*),AICOF(*),BICOF(*),HIVAL(*)
C
C**** TO SET UP THE THREE TERM RECURRENCE COEFFICIENTS (ACOEF AND BCOEF)
C**** FOR THE ON JACOBI POLYNOMIALS (UP TO DEGREE NQPTS) ASSOCIATED WITH
C**** THE JACOBI INDECES GIVEN IN JACIN AND TO STORE THE ZEROTH MOMENTS
C**** OF THE JACOBI DISTRIBUTIONS IN H0VAL. ALSO TO REPEAT THESE
C**** CALCULATIONS FOR THE INCREMENTED JACOBI INDECES ARISING IN THE
C**** EXPRESSIONS FOR THE BOUNDARY CORRESPONDENCE FUNCTION, STORING
C**** RESULTS IN AICOF, BICOF AND HIVAL.
C
C**** ALSO TO SET UP THE NQPT POINT GAUSS JACOBI QUADRATURE RULES,
C**** STORING THE ABSCISSAE IN QUPTS AND THE WIEGHTS IN QUWTS.
C
C**** IER=0 - NORMAL EXIT
C**** IER=4 - FAILURE TO CONVERGE IN EIGSYS; CAN'T SET UP BASIC
C**** QUADRATURE RULES
C
C LOCAL VARIABLES
C
INTEGER I,IFAIL,J,K,LOSUB
REAL BETA,BETA1,C,EPS,PROD,S,R1MACH,T
EXTERNAL ASONJ7,EIGSYS,R1MACH
C
EPS=R1MACH(4)
DO 40 I=1,NJIND
BETA=JACIN(I)
BETA1=BETA+1E+0
PROD=BETA*BETA
C
C CALCULATE THE ZEROTH MOMENT FOR THIS BETA
C
H0VAL(I)=2E+0**BETA1/BETA1
C
C START ON THE 3-TERM ORTHONORMAL RECURRENCE COEFFICIENTS ACOEF
C AND BCOEF FOR THIS BETA
C
T=2E+0+BETA
S=T*T
C=4E+0*BETA1/S/(T+1E+0)
LOSUB=(I-1)*NQPTS+1
ACOEF(LOSUB)=SQRT(C)
BCOEF(LOSUB)=BETA/T
C
DO 10 K=2,NQPTS
J=LOSUB+K-1
BCOEF(J)=PROD/T/(T+2E+0)
T=2E+0*K+BETA
S=T*T
C=4E+0*K*K*(BETA+K)*(BETA+K)/S/(S-1E+0)
ACOEF(J)=SQRT(C)
10 CONTINUE
C
C START ON THE QUADRATURE POINTS AND WEIGHTS FOR THIS BETA
C
DO 20 K=1,NQPTS
J=LOSUB+K-1
QUPTS(J)=BCOEF(J)
QUWTS(J)=ACOEF(J)
WORK(K)=0E+0
20 CONTINUE
WORK(1)=1E+0
C
C AT THIS POINT THE LOCAL SEGMENTS OF QUPTS AND QUWTS ARE THE
C DIAGONAL AND SUBDIAGONAL OF A SYMMETRIC TRIDIAGONAL MATRIX
C WHOSE EIGENVALUES ARE THE QUADRATURE POINTS AND WHOSE
C EIGENVECTORS GIVE THE QUADRATURE WEIGHTS.
C
CALL EIGSYS(NQPTS,EPS,QUPTS(LOSUB),QUWTS(LOSUB),WORK,IFAIL)
IF (IFAIL .GT. 0) THEN
IER=4
RETURN
ENDIF
C
DO 30 K=1,NQPTS
QUWTS(LOSUB+K-1)=WORK(K)*WORK(K)*H0VAL(I)
30 CONTINUE
C
C SET UP THE THREE TERM RECURRENCE COEFFICIENTS AIVAL,BIVAL AND
C THE ZEROTH MOMENT HIVAL FOR THE INTEGRATED POLYNOMIALS.
C
CALL ASONJ7(1E+0,BETA1,AICOF(LOSUB),BICOF(LOSUB),HIVAL(I),NQPTS)
C
40 CONTINUE
C
C NORMAL TERMINATION
C
IER=0
C
END
SUBROUTINE OUPTCA(ISNCA,RSNCA,CSNCA,CHNL)
INTEGER CHNL
INTEGER ISNCA(*)
REAL RSNCA(*)
COMPLEX CSNCA(*)
C
C**** WRITE RESULTS NEEDED FOR LATER PROCESSING IN COMPUTING THE MAP
C**** CANONICAL PHYSICAL.
C
C**** LOCAL VARIABLES
C
INTEGER ACOFC,AICOC,BCOFC,BFSNC,BICOC,COARG,DGPOC,H0VLC,HIVLC,I,
+JAINC,JTYPC,L,LSUBC,NJIND,PHPAS,PRNSA,QUPTC,QUWTC,SOLNC,SW,TNGQP,
+VARGC
REAL EPS,R1MACH
CHARACTER IFORM(6)*5,RFORM(6)*9,JBNM*4,OFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(6)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)','(5I6)','(6I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3','4','5','6'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE OUTPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'ca'
OPEN(CHNL,FILE=OFL)
C
C**** SET UP REAL WRITE FORMATS
C
DO 5 I=1,6
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START OUTPUT
C
WRITE(CHNL,IFORM(6)) (ISNCA(I),I=1,6)
C
NJIND=ISNCA(1)+1
TNGQP=ISNCA(2)*NJIND
C
C**** SET UP POINTERS, AS IN JACANP
C
DGPOC=7
JTYPC=ISNCA(5)+7
LSUBC=2*ISNCA(5)+7
PRNSA=3*ISNCA(5)+7
ACOFC=2
BCOFC=TNGQP+2
AICOC=2*TNGQP+2
BICOC=3*TNGQP+2
QUPTC=4*TNGQP+2
QUWTC=5*TNGQP+2
H0VLC=6*TNGQP+2
HIVLC=NJIND+6*TNGQP+2
JAINC=2*NJIND+6*TNGQP+2
COARG=3*NJIND+6*TNGQP+2
PHPAS=4*NJIND+6*TNGQP+2
VARGC=ISNCA(5)+4*NJIND+6*TNGQP+2
BFSNC=2
SOLNC=ISNCA(6)+2
C
DO 10 I=1,ISNCA(3)
WRITE(CHNL,IFORM(4)) ISNCA(DGPOC+I-1),ISNCA(JTYPC+I-1),
+ ISNCA(LSUBC+I-1),ISNCA(PRNSA+I-1)
10 CONTINUE
C
WRITE(CHNL,RFORM(1)) RSNCA(1)
C
DO 20 I=1,TNGQP
WRITE(CHNL,RFORM(6)) RSNCA(ACOFC+I-1),RSNCA(BCOFC+I-1),
+ RSNCA(AICOC+I-1),RSNCA(BICOC+I-1),
+ RSNCA(QUPTC+I-1),RSNCA(QUWTC+I-1)
20 CONTINUE
C
DO 30 I=1,NJIND
WRITE(CHNL,RFORM(4)) RSNCA(H0VLC+I-1),RSNCA(HIVLC+I-1),
+ RSNCA(JAINC+I-1),RSNCA(COARG+I-1)
30 CONTINUE
C
DO 40 I=1,ISNCA(3)+1
WRITE(CHNL,RFORM(2)) RSNCA(PHPAS+I-1),RSNCA(VARGC+I-1)
40 CONTINUE
C
WRITE(CHNL,RFORM(2)) CSNCA(1)
C
DO 50 I=1,ISNCA(4)
WRITE(CHNL,RFORM(4)) CSNCA(BFSNC+I-1),CSNCA(SOLNC+I-1)
50 CONTINUE
C
CLOSE(CHNL)
C
END
SUBROUTINE OUPTCL(DGPOC,JTYPC,LGTOL,LSUBC,NQPTS,OC,PARNT,PRNSA,
+RIGLL,SOLNC,TNSUC,INTER,INNRAD,IER)
INTEGER NQPTS,OC,TNSUC,IER
INTEGER DGPOC(*),JTYPC(*),LSUBC(*),PARNT(*),PRNSA(*)
REAL LGTOL,INNRAD
REAL RIGLL(*)
COMPLEX SOLNC(*)
LOGICAL INTER
C
C LOCAL VARIABLES
C
INTEGER AJT,DG,I,IC,L,LOM,LOD,PSA,PT
REAL MOD
COMPLEX COF
CHARACTER JBNM*4,OFL*6
EXTERNAL WRHEAD,WRTAIL
C
C**** NAME AND OPEN THE OUTPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(OC,FILE='jbnm')
READ(OC,'(A4)') JBNM
CLOSE(OC)
L=4
DO 1 I=1,4
IF (JBNM(I:I) .EQ. ' ') THEN
L=I-1
GOTO 2
ENDIF
1 CONTINUE
2 CONTINUE
OFL=JBNM(1:L)//'cl'
OPEN(OC,FILE=OFL)
C
CALL WRHEAD(3,OC)
C
WRITE(OC,*) 'JOB IDENTIFIER : ',JBNM
IF (INTER) THEN
WRITE(OC,'(/,A,E16.8,/)') 'INNER RADIUS = ',INNRAD
ENDIF
WRITE(OC,'(/,A,/)') 'JACOBI COEFFICIENTS FOR INVERSE DENSITY FUNCT
+IONS'
DO 20 IC=1,TNSUC
DG=DGPOC(IC)
PSA=PRNSA(IC)
PT=PARNT(PSA)
WRITE(OC,*)
WRITE(OC,101) IC,PSA,PT
LOM=LSUBC(IC)
AJT=ABS(JTYPC(IC))
LOD=(AJT-1)*NQPTS+1
DO 10 I=0,DG
COF=SOLNC(LOM+I)
MOD=ABS(COF)
WRITE(OC,102) I,COF,MOD,LGTOL/RIGLL(LOD+I)
10 CONTINUE
20 CONTINUE
C
101 FORMAT('SUB ARC = ',I3,'; PHYSICAL PARENTAL SUB ARC = ',I3,' ON GL
+OBAL ARC ',I2/,' N',T6,'REAL PART',T24,'IMAGINARY PART',T42,'MODUL
+US',T56,'IGNORE LVL')
102 FORMAT(I2,T4,E16.8,T22,E16.8,T40,E11.3,T54,E11.3)
C
CALL WRTAIL(3,OC,IER)
CLOSE(OC)
C
END
SUBROUTINE OUPTCQ(IQUCA,CQUCA,CHNL)
INTEGER CHNL
INTEGER IQUCA(*)
COMPLEX CQUCA(*)
C
C**** WRITE QUADRATURE DATA FOR COMPUTING THE MAP CANONICAL --> PHYSICAL
C
C**** LOCAL VARIABLES
C
INTEGER I,L,LQSBG,NPPQG,SW,WPPQG,ZPPQG
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(2)*9,JBNM*4,OFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(2)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE OUTPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'cq'
OPEN(CHNL,FILE=OFL)
C
C**** SET UP REAL WRITE FORMATS
C
DO 5 I=1,2
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START OUTPUT
C
WRITE(CHNL,IFORM(4)) (IQUCA(I),I=1,4)
C
C**** SET UP POINTERS FOR IQUCA AND CQUCA, AS IN GQCANP
C
LQSBG=5
NPPQG=IQUCA(3)+5
WPPQG=2
ZPPQG=IQUCA(4)+2
C
DO 10 I=1,IQUCA(2)
WRITE(CHNL,IFORM(2)) IQUCA(LQSBG+I-1),IQUCA(NPPQG+I-1)
10 CONTINUE
C
DO 20 I=1,IQUCA(1)
WRITE(CHNL,RFORM(2)) CQUCA(WPPQG+I-1)
20 CONTINUE
C
DO 30 I=1,IQUCA(1)
WRITE(CHNL,RFORM(2)) CQUCA(ZPPQG+I-1)
30 CONTINUE
C
WRITE(CHNL,RFORM(2)) CQUCA(1)
C
CLOSE(CHNL)
C
END
SUBROUTINE OUPTGM(IGEOM,RGEOM,CENTR,INTER,CHNL)
INTEGER CHNL
INTEGER IGEOM(*)
REAL RGEOM(*)
COMPLEX CENTR
LOGICAL INTER
C
C**** WRITE RESULTS NEEDED FOR LATER PROCESSING IN COMPUTING BOTH THE
C**** PHYSICAL --> CANONICAL AND THE CANONICAL --> PHYSICAL MAPS.
C
C LOCAL VARIABLES
C
INTEGER I,HALEN,MIDPT,PARNT,SW,VTARG
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(2)*9,LFORM*5
CHARACTER SIG(10)*2,WID(10)*2,NOUT(2)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/LFORM/'(1L1)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** SET UP REAL WRITE FORMATS
C
DO 1 I=1,2
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
1 CONTINUE
C
C**** SET UP POINTERS, AS IN JAPHYC
C
WRITE(CHNL,IFORM(4)) (IGEOM(I), I=1,4)
C
PARNT=5
HALEN=3
MIDPT=IGEOM(4)+3
VTARG=2*IGEOM(4)+3
C
DO 10 I=1,IGEOM(3)
WRITE(CHNL,IFORM(1)) IGEOM(PARNT+I-1)
10 CONTINUE
C
WRITE(CHNL,RFORM(2)) (RGEOM(I), I=1,2)
C
DO 20 I=1,IGEOM(3)
WRITE(CHNL,RFORM(2)) RGEOM(HALEN+I-1),RGEOM(MIDPT+I-1)
20 CONTINUE
C
DO 30 I=1,IGEOM(3)+1
WRITE(CHNL,RFORM(1)) RGEOM(VTARG+I-1)
30 CONTINUE
C
WRITE(CHNL,RFORM(2)) CENTR
WRITE(CHNL,LFORM) INTER
C
END
SUBROUTINE OUPTPH(ISNPH,RSNPH,CHNL)
INTEGER CHNL
INTEGER ISNPH(*)
REAL RSNPH(*)
C
C**** WRITE RESULTS NEEDED FOR LATER PROCESSING IN COMPUTING THE MAP
C**** PHYSICAL --> CANONICAL.
C
C**** LOCAL VARIABLES
C
INTEGER ACOEF,BCOEF,AICOF,BICOF,DGPOL,JATYP,LOSUB,QUPTS,QUWTS,
+H0VAL,HIVAL,JACIN,ERARC,BCFSN,SOLUN
INTEGER I,NJIND,SW,TNGQP
REAL EPS,R1MACH
CHARACTER IFORM(6)*5,RFORM(6)*9
CHARACTER SIG(10)*2,WID(10)*2,NOUT(6)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)','(5I6)','(6I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3','4','5','6'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** SET UP REAL WRITE FORMATS
C
DO 1 I=1,6
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
1 CONTINUE
C
WRITE(CHNL,IFORM(6)) (ISNPH(I),I=1,6)
C
C**** SET UP POINTERS, AS IN JAPHYC
C
NJIND=ISNPH(1)+1
TNGQP=NJIND*ISNPH(2)
DGPOL=7
JATYP=ISNPH(5)+7
LOSUB=2*ISNPH(5)+7
ACOEF=1
BCOEF=TNGQP+1
AICOF=2*TNGQP+1
BICOF=3*TNGQP+1
QUPTS=4*TNGQP+1
QUWTS=5*TNGQP+1
H0VAL=6*TNGQP+1
HIVAL=NJIND+6*TNGQP+1
JACIN=2*NJIND+6*TNGQP+1
ERARC=3*NJIND+6*TNGQP+1
BCFSN=ISNPH(5)+3*NJIND+6*TNGQP+1
SOLUN=ISNPH(6)+ISNPH(5)+3*NJIND+6*TNGQP+1
C
DO 10 I=1,ISNPH(3)
WRITE(CHNL,IFORM(3)) ISNPH(DGPOL+I-1),ISNPH(JATYP+I-1),
+ ISNPH(LOSUB+I-1)
10 CONTINUE
C
DO 20 I=1,TNGQP
WRITE(CHNL,RFORM(6)) RSNPH(ACOEF+I-1),RSNPH(BCOEF+I-1),
+ RSNPH(AICOF+I-1),RSNPH(BICOF+I-1),
+ RSNPH(QUPTS+I-1),RSNPH(QUWTS+I-1)
20 CONTINUE
C
DO 30 I=1,NJIND
WRITE(CHNL,RFORM(3)) RSNPH(H0VAL+I-1),RSNPH(HIVAL+I-1),
+ RSNPH(JACIN+I-1)
30 CONTINUE
C
DO 40 I=1,ISNPH(3)
WRITE(CHNL,RFORM(1)) RSNPH(ERARC+I-1)
40 CONTINUE
C
DO 50 I=1,ISNPH(4)
WRITE(CHNL,RFORM(2)) RSNPH(BCFSN+I-1),RSNPH(SOLUN+I-1)
50 CONTINUE
C
END
SUBROUTINE OUPTPQ(IQUPH,RQUPH,CQUPH,CHNL)
INTEGER CHNL
INTEGER IQUPH(*)
REAL RQUPH(*)
COMPLEX CQUPH(*)
C
C**** WRITE QUADRATURE DATA FOR COMPUTING THE MAP PHYSICAL --> CANONICAL
C
C**** LOCAL VARIABLES
C
INTEGER FACTR,I,L,LQSBF,NPPQF,SW,TPPQF,TRRAD,WPPQF,ZPPQF
REAL EPS,R1MACH
CHARACTER IFORM(4)*5,RFORM(3)*9,JBNM*4,OFL*6
CHARACTER SIG(10)*2,WID(10)*2,NOUT(3)*1
EXTERNAL R1MACH
C
DATA
+IFORM/'(1I6)','(2I6)','(3I6)','(4I6)'/
+SIG/'7','8','9','10','11','12','13','14','15','16'/
+WID/'15','16','17','18','19','20','21','22','23','24'/
+NOUT/'1','2','3'/
C
C**** DETERMINE NUMBER OF SIGNIFICANT FIGURES REQUIRED AND SET UP
C**** POINTER SW TO SIG AND WID
C
EPS=R1MACH(4)
SW=INT(-LOG10(EPS))+2
IF (SW.LE.7) THEN
SW=1
ELSE IF (SW.GE.16) THEN
SW=10
ELSE
SW=SW-6
ENDIF
C
C**** NAME AND OPEN THE OUTPUT FILE ASSOCIATED WITH THIS DATA
C
OPEN(CHNL,FILE='jbnm')
READ(CHNL,'(A4)') JBNM
CLOSE(CHNL)
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'pq'
OPEN(CHNL,FILE=OFL)
C
C**** SET UP REAL WRITE FORMATS
C
DO 5 I=1,3
RFORM(I)='('//NOUT(I)//'E'//WID(SW)//'.'//SIG(SW)//')'
5 CONTINUE
C
C**** START OUTPUT
C
WRITE(CHNL,IFORM(4)) (IQUPH(I),I=1,4)
C
C**** SET UP QUADRATURE POINTERS, AS IN GQPHYC
C
LQSBF=5
NPPQF=IQUPH(3)+5
TPPQF=2
TRRAD=IQUPH(4)+2
WPPQF=2*IQUPH(4)+2
FACTR=1
ZPPQF=2
C
DO 10 I=1,IQUPH(2)
WRITE(CHNL,IFORM(2)) IQUPH(LQSBF+I-1),IQUPH(NPPQF+I-1)
10 CONTINUE
C
DO 20 I=1,IQUPH(1)
WRITE(CHNL,RFORM(3)) RQUPH(TPPQF+I-1),RQUPH(TRRAD+I-1),
+ RQUPH(WPPQF+I-1)
20 CONTINUE
C
WRITE(CHNL,RFORM(2)) CQUPH(FACTR)
C
DO 30 I=1,IQUPH(1)
WRITE(CHNL,RFORM(2)) CQUPH(ZPPQF+I-1)
30 CONTINUE
C
WRITE(CHNL,RFORM(1)) RQUPH(1)
C
CLOSE(CHNL)
C
END
SUBROUTINE PHTCA1(NPTS,PHYPT,CANPT,NARCS,NQPTS,TNSUA,DGPOL,JATYP,
+LOSUB,LPQSB,NPPQF,PARNT,A1COF,ACOEF,B1COF,BCFSN,BCOEF,H0VAL,
+H1VAL,HALEN,JACIN,LGTOL,MIDPT,QUPTS,QUWTS,SOLUN,TPPQF,TRRAD,
+VTARG,WPPQF,CENTR,FACTR,ZPPQF,INTER,IER)
INTEGER IER,NPTS,NARCS,NQPTS,TNSUA
INTEGER DGPOL(*),JATYP(*),LOSUB(*),LPQSB(*),NPPQF(*),PARNT(*)
REAL LGTOL
REAL A1COF(*),ACOEF(*),B1COF(*),BCFSN(*),BCOEF(*),H1VAL(*),
+H0VAL(*),HALEN(*),JACIN(*),MIDPT(*),QUPTS(*),QUWTS(*),SOLUN(*),
+TPPQF(*),TRRAD(*),VTARG(*),WPPQF(*)
COMPLEX CENTR,FACTR
COMPLEX CANPT(*),PHYPT(*),ZPPQF(*)
LOGICAL INTER
C
C GIVEN THE ARRAY PHYPT OF NPTS POINTS IN THE PHYSICAL PLANE, THIS
C ROUTINE COMPUTES THE ARRAY CANPT OF IMAGES IN THE CANONICAL
C PLANE.
C
C IER=0 - NORMAL EXIT
C IER=27 - LOCAL PARAMETER MXNQD NEEDS INCREASING
C IER=28 - LOCAL PARAMETER MNCOF NEEDS INCREASING
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,I,IA,IP,K,J,J1,J2,JQ,JT,LIM,LOD,LOL,LOM,MNCOF,
+MQIN1,MXNQD,NQ,NQUAD,PT,QINTS
REAL AISUM,ANGLE,ARGBR,ARGIN1,ARSUM,BETA,CURARG,DIST,HL,ISUM,
+JACSUM,LIMIT,MD,MEAN,MINDS,NEWTL,PI,PTHTL,R1MACH,RR,RRB,RSUM,RT1,
+RT2,SCO,SS,STARG,STRT1,STTH1,SUM1,THET1,THET2,TOLOU,TT,TXI,TUPI,WT
COMPLEX BCF,CJACSU,CT,DPARFN,PARFUN,PSI,XI,DIFF1,DIFF2,
+STDF1,ZXI,ZTOB1,ZZ
LOGICAL FIRST
EXTERNAL ARGIN1,CJACSU,DPARFN,JACSUM,PARFUN,PPSBI1,R1MACH,ZTOB1
PARAMETER (MNCOF=32,MQIN1=11,MXNQD=80,PTHTL=1E-3)
PARAMETER (LIMIT=2.3562E+0)
REAL JACOF(MNCOF),TSPEC(MXNQD),WSPEC(MXNQD),XENPT(MQIN1)
COMPLEX JCOFC(MNCOF),ZSPEC(MXNQD)
C
NEWTL=SQRT(R1MACH(4))
PI=4E+0*ATAN(1E+0)
TUPI=2E+0*PI
LOL=NARCS*NQPTS
DO 300 IP=1,NPTS
ZZ=PHYPT(IP)
RSUM=0E+0
ISUM=0E+0
FIRST=.TRUE.
DO 200 IA=1,TNSUA
PT=PARNT(IA)
JT=JATYP(IA)
NQ=NPPQF(IA)
K=LPQSB(IA)-1
HL=HALEN(IA)
MD=MIDPT(IA)
ARSUM=0E+0
AISUM=0E+0
DO 100 JQ=1,NQ
K=K+1
DIFF2=ZZ-ZPPQF(K)
RT2=MD+HL*TPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .GE. TRRAD(K)) THEN
WT=WPPQF(K)
IF (WT .NE. 0E+0) THEN
ARSUM=ARSUM+WT*LOG(DIST)
IF (FIRST) THEN
CURARG=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
THET2=CURARG
FIRST=.FALSE.
STARG=CURARG
ELSE
C CT=DIFF2/DIFF1
C CT=DIFF2*CONJG(DIFF1)
C ANGLE=ATAN2(AIMAG(CT),REAL(CT))
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ENDIF
AISUM=CURARG*WT+AISUM
RT1=RT2
DIFF1=DIFF2
THET1=THET2
ENDIF
ELSE
C
C ZZ IS TOO CLOSE TO ARC IA TO USE THE STANDARD RULE.
C FIND THE QUADRATURE POINT NEAREST TO ZZ.
C
J1=JQ
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
40 CONTINUE
J1=J1+1
IF (J1 .LE. NQ) THEN
K=K+1
DIFF2=ZZ-ZPPQF(K)
DIST=ABS(DIFF2)
IF (DIST .LT. MINDS) THEN
MINDS=DIST
TXI=TPPQF(K)
ZXI=ZPPQF(K)
GOTO 40
ENDIF
ENDIF
C
C PRELIMINARIES
C
IF (JT .GT. 0) THEN
SS=1E+0
ELSE
SS=-1E+0
ENDIF
AJT=ABS(JT)
BETA=JACIN(AJT)
DEG=DGPOL(IA)
IF (DEG+1 .GT. MNCOF) THEN
IER=28
RETURN
ENDIF
LOM=LOSUB(IA)
LOD=(AJT-1)*NQPTS+1
C
C NOW USE NEWTON'S METHOD TO ESTIMATE THE PARAMETRIC
C PRE-IMAGE XI OF ZZ.
C
XI=CMPLX(TXI)
CT=MD+HL*XI
DIFF2=(ZXI-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
50 CONTINUE
IF (ABS(DIFF2) .GT. NEWTL) THEN
CT=MD+HL*XI
DIFF2=(PARFUN(PT,CT)-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
GOTO 50
ELSE
C
C LAST ITERATION
C
CT=MD+HL*XI
DIFF2=(PARFUN(PT,CT)-ZZ)/(DPARFN(PT,CT)*HL)
XI=XI-DIFF2
ENDIF
C
XI=SS*XI
C
IF (ABS(AIMAG(XI)).LT.PTHTL .AND. ABS(REAL(XI)).LT.1E+
+ 0+PTHTL) THEN
C
C ZZ IS PATHOLOGICALLY CLOSE TO ARC IA AND WE USE THE
C CONTINUATION OF THE BOUNDARY CORRESPONDENCE FUNCTION TO
C ESTIMATE CANPT.
C
PSI=CJACSU(XI,DEG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),
+ BCFSN(LOM+1))
PSI=ZTOB1(XI+1E+0,BETA+1E+0,JT,INTER)*
+ (BCFSN(LOM)-(1E+0-XI)*PSI)
IF (JT .GT. 0) THEN
BCF=VTARG(IA)
ELSE
BCF=VTARG(IA+1)
ENDIF
BCF=BCF+SS*PSI
CANPT(IP)=CEXP((0E+0,1E+0)*BCF)
GOTO 300
ELSE
C
C SET UP A SPECIAL COMPOSITE GAUSSIAN RULE TO HANDLE THIS
C PARTICULAR POINT ZZ.
C
SCO=SS
DO 55 J=1,DEG+1
J1=LOM+J-1
SCO=SCO*SS
JACOF(J)=SOLUN(J1)*SCO
JCOFC(J)=CMPLX(SOLUN(J1)*SCO)
55 CONTINUE
CALL PPSBI1(XI,BETA,NQPTS,DEG,ACOEF(LOD),BCOEF(LOD),
+ H0VAL(AJT),JCOFC,LGTOL,TOLOU,XENPT,QINTS,
+ MQIN1,IER)
IF (IER .GT. 0) THEN
RETURN
ENDIF
NQUAD=QINTS*NQPTS
IF (NQUAD .GT. MXNQD) THEN
IER=27
RETURN
ENDIF
K=0
SUM1=BETA+1E+0
DO 70 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
DO 60 J=1,NQPTS
J1=LOD+J-1
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WSPEC(K)=RRB*QUWTS(J1)*JACSUM(TT,DEG,ACOEF(LOD),
+ BCOEF(LOD),H0VAL(AJT),JACOF)
TT=TT*SS
TSPEC(K)=MD+TT*HL
CT=CMPLX(TSPEC(K))
ZSPEC(K)=PARFUN(PT,CT)
60 CONTINUE
ELSE
DO 65 J=1,NQPTS
J1=LOL+J
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WSPEC(K)=RR*QUWTS(J1)*(1E+0+TT)**BETA*JACSUM(TT,
+ DEG,ACOEF(LOD),BCOEF(LOD),H0VAL(AJT),
+ JACOF)
TT=TT*SS
TSPEC(K)=MD+TT*HL
CT=CMPLX(TSPEC(K))
ZSPEC(K)=PARFUN(PT,CT)
65 CONTINUE
ENDIF
70 CONTINUE
IF (SS .LT. 0E+0) THEN
LIM=NQUAD
IF (MOD(LIM,2) .EQ. 0) THEN
LIM=LIM/2
ELSE
LIM=(LIM-1)/2
ENDIF
J1=0
J2=NQUAD+1
DO 75 J=1,LIM
J1=J1+1
J2=J2-1
TT=WSPEC(J1)
WSPEC(J1)=WSPEC(J2)
WSPEC(J2)=TT
TT=TSPEC(J1)
TSPEC(J1)=TSPEC(J2)
TSPEC(J2)=TT
CT=ZSPEC(J1)
ZSPEC(J1)=ZSPEC(J2)
ZSPEC(J2)=CT
75 CONTINUE
ENDIF
C
C THIS COMPLETES THE SETTING UP OF THE SPECIAL WEIGHTS
C AND POINTS WSPEC AND ZSPEC. NOW ESTIMATE THE INTEGRAL.
C
ARSUM=0E+0
AISUM=0E+0
IF (IA .EQ. 1) THEN
FIRST=.TRUE.
ELSE
CURARG=STARG
RT1=STRT1
DIFF1=STDF1
THET1=STTH1
ENDIF
DO 80 K=1,NQUAD
WT=WSPEC(K)
DIFF2=ZZ-ZSPEC(K)
RT2=TSPEC(K)
DIST=ABS(DIFF2)
ARSUM=ARSUM+WT*LOG(DIST)
IF (FIRST) THEN
CURARG=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
THET2=CURARG
FIRST=.FALSE.
ELSE
C CT=DIFF2/DIFF1
C CT=DIFF2*CONJG(DIFF1)
C ANGLE=ATAN2(AIMAG(CT),REAL(CT))
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ENDIF
AISUM=CURARG*WT+AISUM
RT1=RT2
DIFF1=DIFF2
THET1=THET2
80 CONTINUE
GOTO 150
ENDIF
ENDIF
C
C END OF QUADRATURE SUM LOOP
C
100 CONTINUE
C
150 CONTINUE
RSUM=RSUM+ARSUM
ISUM=ISUM+AISUM
IF (JT .LT. 0) THEN
C
C BRING THE ARGUMENT FORWARD TO THE CORNER POINT AND REPLACE
C THE INCREMENTED CURARG VALUE BY AN INVERSE TANGENT
C EVALUATION
C
DIFF2=ZZ-PARFUN(PT,(1E+0,0E+0))
RT2=1E+0
THET2=ATAN2(AIMAG(DIFF2),REAL(DIFF2))
ANGLE=THET2-THET1
IF (ANGLE .LE. -PI .OR. ANGLE .GT. PI) THEN
ANGLE=ANGLE-SIGN(TUPI,ANGLE)
ENDIF
IF (ABS(ANGLE) .GE. LIMIT) THEN
ANGLE=ARGIN1(RT1,RT2,PT,-DIFF1,-DIFF2,ZZ,
+ LIMIT)
ENDIF
CURARG=CURARG+ANGLE
ARGBR=ANINT((CURARG-THET2)/TUPI)
CURARG=THET2+TUPI*ARGBR
RT1=-1E+0
DIFF1=DIFF2
THET1=THET2
ENDIF
STARG=CURARG
STRT1=RT1
STDF1=DIFF1
STTH1=THET1
C
C END OF LOOP FOR CONTRIBUTIONS FROM ARC NUMBER IA
C
200 CONTINUE
CT=CMPLX(RSUM,ISUM)
CT=CEXP(CT)
IF (INTER) THEN
CANPT(IP)=(ZZ-CENTR)*FACTR/CT
ELSE
CANPT(IP)=CT*FACTR
ENDIF
C
C END OF MAP CALCULATION FOR FIELD POINT NUMBER IP
C
300 CONTINUE
C
IER=0
C
END
SUBROUTINE POPQF1(NPPQF,LPQSB,TNPQP,TOLOU,TPPQF,TRRAD,WPPQF,
+ZPPQF,MNQUA,MQIN1,NARCS,NINTS,NQPTS,TNSUA,DGPOL,JATYP,LOSUB,PARNT,
+DELTA,LGTOL,ACOEF,BCOEF,H0VAL,HALEN,JACIN,MIDPT,QUPTS,QUWTS,SOLUN,
+XENPT,IER)
INTEGER IER,MQIN1,MNQUA,NARCS,NINTS,NQPTS,TNPQP,TNSUA
INTEGER DGPOL(*),JATYP(*),LOSUB(*),LPQSB(*),NPPQF(*),
+PARNT(*)
REAL DELTA,LGTOL,TOLOU
REAL ACOEF(*),BCOEF(*),HALEN(*),H0VAL(*),JACIN(*),MIDPT(*),
+QUPTS(*),QUWTS(*),SOLUN(*),TPPQF(*),TRRAD(*),WPPQF(*),XENPT(*)
COMPLEX ZPPQF(*)
C
C THE MAIN PURPOSE OF THIS ROUTINE IS TO SET UP THE REAL ARRAY
C WPPQF OF QUADRATURE WEIGHTS, THE COMPLEX ARRAY ZPPQF OF
C QUADRATURE POINTS ON THE PHYSICAL BOUNDARY AND THE REAL ARRAY
C TPPQF OF LOCAL PARAMETER VALUES CORRESPONDING TO ZPPQF; ALL THESE
C DATA DEFINE THE POST-PROCESSING COMPOSITE GAUSSIAN
C QUADRATURE RULES FOR THE ESTIMATE OF THE MAP F (PHYSICAL ONTO
C CANONICAL) WHEN Z IS NOT TOO CLOSE TO THE BOUNDARY.
C
C THIS ROUTINE ALSO RETURNS THE ARRAY TRRAD OF SO-CALLED TRANSITION
C RADII; THE IDEA IS THAT IF A PHYSICAL FIELD POINT Z SATISFIES
C
C ABS(Z-ZPPQF(I)) < TRRAD(I)
C
C THEN THE QUADRATURE RULE PRODUCED BY THIS ROUTINE IS PROBABLY
C NOT SUFFICIENTLY ACCURATE ON THE PARTICULAR ARC ON WHICH
C ZPPQF(I) LIES. THIS ROUTINE ALSO ASSIGNS FICTICIOUS QUADRATURE
C POINTS WITH WEIGHTS SET TO ZERO. THESE POINTS ARE INSERTED TO
C ENSURE THAT IF A FIELD POINT Z IS CLOSE TO THE PHYSICAL BOUNDARY
C THEN THE ABOVE INEQUALITY SHOULD BE SATISFIED FOR AT LEAST ONE
C "GENERALISED" QUADRATURE POINT.
C
C THE ARRAY ELEMENT NPPQF(I) RECORDS THE NUMBER OF QUADRATURE
C POINTS FOR THE SUBARC NUMBER I, I=1,...,TNSUA. THE WEIGHTS,
C QUADRATURE POINTS AND LOCAL QUADRATURE POINT PARAMETERS FOR ARC
C NUMBER I ARE STORED IN WPPQF, ZPPQF AND TPPQF STARTING AT THE
C ELEMENT WITH INDEX LPQSB(I).
C
C IER=0 - NORMAL EXIT
C IER=22- THE TOTAL NUMBER OF QUADRATURE POINTS REQUESTED FOR
C THE WHOLE BOUNDARY EXCEEDS THE LIMIT DEFINED BY THE
C INPUT PARAMETER MNQUA; MNQUA MUST BE INCREASED IN A
C HIGHER LEVEL ROUTINE.
C IER=23- THE LOCAL PARAMETER MNCOF SHOULD BE INCREASED
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,HI,HI1,I,I1,J,J1,J2,JT,K,LIM,LOD,LOL,LOM,PT,QINTS,
+MNCOF
REAL BETA,DIST,HL,JACSUM,MD,MEAN,MXDIS,RHO,RR,RRB,SS,SUM1,TT,SCO
COMPLEX CTT,DPARFN,PARFUN
PARAMETER(MNCOF=32,RHO=1.3E-1)
REAL JACOF(MNCOF)
COMPLEX JCOFC(MNCOF)
EXTERNAL DPARFN,JACSUM,PARFUN,PPSBI7
C
MXDIS=DELTA
HI=0
LOL=NARCS*NQPTS
DO 80 I1=1,TNSUA
JT=JATYP(I1)
IF (JT .GT. 0) THEN
SS=1E+0
ELSE
SS=-1E+0
ENDIF
AJT=ABS(JT)
BETA=JACIN(AJT)
DEG=DGPOL(I1)
IF (DEG+1 .GT. MNCOF) THEN
IER=23
RETURN
ENDIF
LOM=LOSUB(I1)
LOD=(AJT-1)*NQPTS+1
PT=PARNT(I1)
HL=HALEN(I1)
MD=MIDPT(I1)
C
SCO=SS
DO 5 J=1,DEG+1
J1=LOM+J-1
SCO=SCO*SS
JACOF(J)=SOLUN(J1)*SCO
JCOFC(J)=CMPLX(SOLUN(J1)*SCO)
5 CONTINUE
C
CALL PPSBI7(DELTA,NINTS,BETA,NQPTS,DEG,ACOEF(LOD),
+ BCOEF(LOD),H0VAL(AJT),JCOFC,LGTOL,TOLOU,XENPT,
+ QINTS,MQIN1,IER)
IF (IER .GT. 0) THEN
RETURN
ENDIF
NPPQF(I1)=QINTS*NQPTS
LPQSB(I1)=HI+1
HI1=HI+NPPQF(I1)
IF (HI1 .GT. MNQUA) THEN
IER=22
RETURN
ENDIF
K=HI
SUM1=BETA+1E+0
DO 30 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
DO 10 J=1,NQPTS
J1=LOD+J-1
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WPPQF(K)=RRB*QUWTS(J1)*JACSUM(TT,DEG,ACOEF(LOD),
+ BCOEF(LOD),H0VAL(AJT),JACOF)
TT=TT*SS
TPPQF(K)=TT
CTT=CMPLX(MD+TT*HL)
ZPPQF(K)=PARFUN(PT,CTT)
TRRAD(K)=HL*DELTA*ABS(DPARFN(PT,CTT))
10 CONTINUE
ELSE
DO 20 J=1,NQPTS
J1=LOL+J
K=K+1
TT=(MEAN+RR*QUPTS(J1))
WPPQF(K)=RR*QUWTS(J1)*(1E+0+TT)**BETA*JACSUM(TT,DEG,
+ ACOEF(LOD),BCOEF(LOD),H0VAL(AJT),JACOF)
TT=TT*SS
TPPQF(K)=TT
CTT=CMPLX(MD+TT*HL)
ZPPQF(K)=PARFUN(PT,CTT)
TRRAD(K)=HL*DELTA*ABS(DPARFN(PT,CTT))
20 CONTINUE
ENDIF
30 CONTINUE
IF (SS .LT. 0E+0) THEN
LIM=NPPQF(I1)
IF (MOD(LIM,2) .EQ. 0) THEN
LIM=LIM/2
ELSE
LIM=(LIM-1)/2
ENDIF
J1=LPQSB(I1)-1
J2=HI1+1
DO 40 J=1,LIM
J1=J1+1
J2=J2-1
TT=WPPQF(J1)
WPPQF(J1)=WPPQF(J2)
WPPQF(J2)=TT
TT=TRRAD(J1)
TRRAD(J1)=TRRAD(J2)
TRRAD(J2)=TT
TT=TPPQF(J1)
TPPQF(J1)=TPPQF(J2)
TPPQF(J2)=TT
CTT=ZPPQF(J1)
ZPPQF(J1)=ZPPQF(J2)
ZPPQF(J2)=CTT
40 CONTINUE
ENDIF
C
C NEXT WE INSERT ANY NECESSARY FICTICIOUS QUADRATURE POINTS
C
J1=LPQSB(I1)
IF (TPPQF(J1)+1E+0 .GT. RHO*MXDIS) THEN
J2=HI1
DO 50 I=J2,J1,-1
WPPQF(I+1)=WPPQF(I)
TRRAD(I+1)=TRRAD(I)
TPPQF(I+1)=TPPQF(I)
ZPPQF(I+1)=ZPPQF(I)
50 CONTINUE
HI1=J2+1
NPPQF(I1)=NPPQF(I1)+1
WPPQF(J1)=0E+0
TPPQF(J1)=-1E+0
CTT=CMPLX(MD-HL)
ZPPQF(J1)=PARFUN(PT,CTT)
TRRAD(J1)=HL*DELTA*ABS(DPARFN(PT,CTT))
ENDIF
C
60 CONTINUE
J1=J1+1
IF (J1 .LT. HI1) THEN
DIST=TPPQF(J1+1)-TPPQF(J1)
IF (DIST .GT. MXDIS) THEN
J2=HI1
DO 70 I=J2,J1+1,-1
WPPQF(I+1)=WPPQF(I)
TRRAD(I+1)=TRRAD(I)
TPPQF(I+1)=TPPQF(I)
ZPPQF(I+1)=ZPPQF(I)
70 CONTINUE
HI1=J2+1
NPPQF(I1)=NPPQF(I1)+1
WPPQF(J1+1)=0E+0
TPPQF(J1+1)=(TPPQF(J1)+TPPQF(J1+2))*5E-1
CTT=CMPLX(MD+HL*TPPQF(J1+1))
ZPPQF(J1+1)=PARFUN(PT,CTT)
TRRAD(J1+1)=HL*DELTA*ABS(DPARFN(PT,CTT))
ENDIF
GOTO 60
ELSE IF (1E+0-TPPQF(J1) .GT. RHO*MXDIS) THEN
J1=J1+1
HI1=J1
NPPQF(I1)=NPPQF(I1)+1
WPPQF(J1)=0E+0
TPPQF(J1)=1E+0
CTT=CMPLX(MD+HL)
ZPPQF(J1)=PARFUN(PT,CTT)
TRRAD(J1)=HL*DELTA*ABS(DPARFN(PT,CTT))
ENDIF
HI=HI1
80 CONTINUE
C
TNPQP=HI
C
IER=0
C
END
SUBROUTINE POPQG1(NPPQG,LPQSB,TNPQP,TOLOU,WPPQG,ZPPQG,MNQUA,
+MQIN1,NARCS,NINTS,NQPTS,TNSUC,DGPOC,JTYPC,LSUBC,DELTA,LGTOL,ACOFC,
+BCOFC,H0VLC,JAINC,QUPTC,QUWTC,SOLNC,VARGC,XENPT,IER)
INTEGER IER,MQIN1,MNQUA,NARCS,NINTS,NQPTS,TNPQP,TNSUC
INTEGER DGPOC(*),JTYPC(*),LSUBC(*),LPQSB(*),NPPQG(*)
REAL DELTA,LGTOL,TOLOU
REAL ACOFC(*),BCOFC(*),H0VLC(*),JAINC(*),QUPTC(*),QUWTC(*),
+VARGC(*),XENPT(*)
COMPLEX SOLNC(*),WPPQG(*),ZPPQG(*)
C
C THE MAIN PURPOSE OF THIS ROUTINE IS TO SET UP THE COMPLEX ARRAY
C WPPQG OF QUADRATURE WEIGHTS AND THE COMPLEX ARRAY ZPPQG OF
C QUADRATURE POINTS ON THE PHYSICAL BOUNDARY; ALL THESE
C DATA DEFINE THE POST-PROCESSING COMPOSITE GAUSSIAN
C QUADRATURE RULES FOR THE ESTIMATE OF THE MAP G (CANONICAL ONTO
C PHYSICAL) WHEN Z IS NOT TOO CLOSE TO THE BOUNDARY.
C
C THE ARRAY ELEMENT NPPQG(I) RECORDS THE NUMBER OF QUADRATURE
C POINTS FOR THE SUBARC NUMBER I, I=1,...,TNSUC. THE WEIGHTS AND
C QUADRATURE POINTS FOR ARC NUMBER I ARE STORED IN WPPQG AND ZPPQG
C STARTING AT THE ELEMENT WITH INDEX LPQSB(I).
C
C IER=0 - NORMAL EXIT
C IER=41 - THE TOTAL NUMBER OF QUADRATURE POINTS REQUESTED FOR
C THE WHOLE BOUNDARY EXCEEDS THE LIMIT DEFINED BY THE
C INPUT PARAMETER MNQUA; MNQUA MUST BE INCREASED IN A
C HIGHER LEVEL ROUTINE.
C IER=42 - THE LOCAL PARAMETER MNCOF SHOULD BE INCREASED
C IER=43 - THE REQUIRED NUMBER OF QUADRATURE INTERVALS EXCEEDS THAT
C SPECIFIED BY THE GLOBAL PARAMETER MQIN1; MQIN1 MUST BE
C INCREASED.
C
C LOCAL VARIABLES
C
INTEGER AJT,DEG,HI,HI1,I,I1,J,J1,J2,JT,K,LIM,LOD,LOL,LOM,QINTS,
+MNCOF
REAL BETA,HA,MD,MEAN,RHO,RR,RRB,SS,SUM1,TT,SCO
COMPLEX CTT,DPARFN,JACSUC,PARFUN
PARAMETER(MNCOF=32,RHO=1.3E-1)
COMPLEX JACOF(MNCOF)
EXTERNAL DPARFN,JACSUC,PARFUN,PPSBI7
C
HI=0
LOL=NARCS*NQPTS
DO 80 I1=1,TNSUC
JT=JTYPC(I1)
IF (JT .GT. 0) THEN
SS=1E+0
ELSE
SS=-1E+0
ENDIF
AJT=ABS(JT)
BETA=JAINC(AJT)
DEG=DGPOC(I1)
IF (DEG+1 .GT. MNCOF) THEN
IER=42
RETURN
ENDIF
LOM=LSUBC(I1)
LOD=(AJT-1)*NQPTS+1
HA=(VARGC(I1+1)-VARGC(I1))*5E-1
MD=(VARGC(I1+1)+VARGC(I1))*5E-1
C
SCO=SS
DO 5 J=1,DEG+1
J1=LOM+J-1
SCO=SCO*SS
JACOF(J)=SOLNC(J1)*SCO
5 CONTINUE
C
CALL PPSBI7(DELTA,NINTS,BETA,NQPTS,DEG,ACOFC(LOD),
+ BCOFC(LOD),H0VLC(AJT),JACOF,LGTOL,TOLOU,XENPT,
+ QINTS,MQIN1,IER)
IF (IER .GT. 0) THEN
IF (IER .EQ. 24) THEN
IER=43
ENDIF
RETURN
ENDIF
NPPQG(I1)=QINTS*NQPTS
LPQSB(I1)=HI+1
HI1=HI+NPPQG(I1)
IF (HI1 .GT. MNQUA) THEN
IER=41
RETURN
ENDIF
K=HI
SUM1=BETA+1E+0
DO 30 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
DO 10 J=1,NQPTS
J1=LOD+J-1
K=K+1
TT=(MEAN+RR*QUPTC(J1))
WPPQG(K)=RRB*QUWTC(J1)*JACSUC(TT,DEG,ACOFC(LOD),
+ BCOFC(LOD),H0VLC(AJT),JACOF)
TT=TT*SS
TT=MD+TT*HA
ZPPQG(K)=CMPLX(COS(TT),SIN(TT))
10 CONTINUE
ELSE
DO 20 J=1,NQPTS
J1=LOL+J
K=K+1
TT=(MEAN+RR*QUPTC(J1))
WPPQG(K)=RR*QUWTC(J1)*(1E+0+TT)**BETA*JACSUC(TT,DEG,
+ ACOFC(LOD),BCOFC(LOD),H0VLC(AJT),JACOF)
TT=TT*SS
TT=MD+TT*HA
ZPPQG(K)=CMPLX(COS(TT),SIN(TT))
20 CONTINUE
ENDIF
30 CONTINUE
IF (SS .LT. 0E+0) THEN
LIM=NPPQG(I1)
IF (MOD(LIM,2) .EQ. 0) THEN
LIM=LIM/2
ELSE
LIM=(LIM-1)/2
ENDIF
J1=LPQSB(I1)-1
J2=HI1+1
DO 40 J=1,LIM
J1=J1+1
J2=J2-1
CTT=WPPQG(J1)
WPPQG(J1)=WPPQG(J2)
WPPQG(J2)=CTT
CTT=ZPPQG(J1)
ZPPQG(J1)=ZPPQG(J2)
ZPPQG(J2)=CTT
40 CONTINUE
ENDIF
HI=HI1
80 CONTINUE
C
TNPQP=HI
C
IER=0
C
END
SUBROUTINE PPSBI7(DELTA,NINTS,BETA,NQUAD,DGPOL,ACOEF,BCOEF,
+H0VAL,SOLUN,TOLIN,TOLOU,XENPT,QINTS,MQIN1,IER)
INTEGER DGPOL,MQIN1,NQUAD,QINTS,IER,NINTS
REAL BETA,H0VAL,TOLIN,TOLOU,DELTA
REAL ACOEF(*),BCOEF(*),XENPT(*)
COMPLEX SOLUN(*)
C
C CALCULATES THE NUMBER OF QUADRATURE INTERVALS (QINTS) REQUIRED
C FOR THE COMPOSITE GAUSS-JACOBI/GAUSS-LEGENDRE ESTIMATION OF
C
C INTEGRAL [(1+X)**BETA*FNPHI(X)*LOG(ZZ(J)-X)*dX],
C -1<=X<=1
C
C WHERE FNPHI IS A POLYNOMIAL APPROXIMATION TO THE BOUNDARY
C CORRESPONDENCE DERIVATIVE / JACOBI WEIGHT QUOTIENT.
C
C ZZ IS ANY POINT ON A "DELTA-CONTOUR" IN THE UPPER HALF PLANE,
C THIS CONTOUR BEING DEFINED BY THE PARAMETER DELTA. TEST VALUES
C FOR ZZ ARE ASSIGNED IN THE SUBROUTINES DEPPJ8 AND DEPPL8.
C
C THE PARAMETERS DGPOL,ACOEF,BCOEF,H0VAL AND SOLUN ARE USED TO
C DEFINE FNPHI AND ARE PASSED TO DEPPJ8 AND DEPPL8 FOR THIS PURPOSE.
C
C THE ENDPOINTS OF THE QUADRATURE INTERVALS ARE RETURNED IN VECTOR
C XENPT, WITH XENPT(1)=-1zz.
C
C THE THIRD PURPOSE OF THE ROUTINE IS TO CHECK PARFUN AND
C DPARFN FOR MUTUAL CONSISTECY. THIS IS DONE BY COMPUTING
C TWO POINT FINITE DIFFERENCE APPROXIMATIONS TO DPARFN.
C THESE DIFFERENCE APPROXIMATIONS ARE COMPUTED AT EACH BOUND-
C ARY POINT THAT IS OUTPUT FOR PLOTTING AND ALSO AT NEARBY
C POINTS WHICH LIE JUST O F F THE BOUNDARY. THIS LATTER
C COMPARISON ALSO TESTS PARFUN AND DPARFN FOR CORRECTNESS IN
C ACCEPTING COMPLEX PARAMETER VALUES. A RELATIVE ERROR IN
C THE FINITE DIFFERENCE APPROXIMATION GREATER THAN 0.1 IS
C REPORTED AS A POSSIBLE LOGICAL INCONSISTENCY BETWEEN PARFUN
C AND DPARFN. (THE CRITICAL RELATIVE ERROR VALUE OF 0.1 CAN
C BE ALTERED BY ADJUSTING THE LOCAL PARAMETER DTOL).
C
C 3. CALLING SEQUENCE
C CALL TSTPLT(JBNM,MXMIS,MXDIF,NARCS,PSD,MINPD,MAXPD,CHNL,IER)
C
C PARAMETERS
C ON ENTRY
C JBNM - CHARACTER*4
C THE JOB NAME. THIS IS USED TO CREATE THE OUTPUT
C FILE WITH FILENAME
C
C zz ,
C
C WHERE DENOTES THE VALUE OF VARIABLE JBNM
C WITH ANY TRAILING SPACES DELETED.
C
C NARCS - INTEGER
C THE NUMBER OF ANALYTIC ARCS THAT MAKE UP THE
C W H O L E BOUNDARY OF THE PHYSICAL DOMAIN.
C
C PSD - REAL
C THE PLOTTING SIZE FOR THE DOMAIN IN ANY APPROPR-
C IATE UNITS. IF PSD .LE. 0.0 THEN IT IS ASSIGNED
C THE DEFAULT VALUE OF 160.0 (A REASONBLE WIDTH IN
C MM FOR PLOTTING ON A4 PAPER).
C
C MINPD - REAL
C THE MINIMUM SIGNIFICANT PLOTTING DISTANCE, IN THE
C SAME UNITS AS PSD. IF PSD .LE. 0.0 THEN IT IS
C ASSIGNED THE DEFAULT VALUE OF 2.0.
C
C MAXPD - REAL
C THE MAXIMUM ALLOWED PLOTTING DISTANCE, IN THE
C SAME UNITS AS PSD. IF PSD .LE. 0.0 THEN IT IS
C ASSIGNED THE DEFAULT VALUE OF 5.0. THE LARGER
C MAXPD, THE COARSER WILL BE THE RESOLUTION OF THE
C BOUNDARY POINTS OUTPUT TO zz, BUT THE
C QUICKER THEY WILL BE COMPUTED.
C
C CHNL - INTEGER
C DEFINES AN OUTPUT CHANNEL THAT MAY BE USED FOR
C WRITING THE FILE zz.
C ON EXIT
C MXMIS - REAL
C THE MAXIMUM RELATIVE MISFIT ERROR OVER ALL
C CORNER POINTS
C
C MXDIF - REAL
C THE MAXIMUM RELATIVE ERROR IN FINITE DIFFERENCE
C APPROXIMATIONS TO DPARFN OVER ALL BOUNDARY
C POINTS OUTPUT TO zz AND NEARBY POINTS OFF
C THE BOUNDARY.
C
C PSD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN IT WILL HAVE
C THE DEFAULT VALUE OF 160.0 ON EXIT.
C
C MINPD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN MINPD WILL HAVE
C THE DEFAULT VALUE OF 2.0 ON EXIT
C
C MAXPD - REAL
C IF PSD .LE. 0.0 ON ENTRY THEN MAXPD WILL HAVE
C THE DEFAULT VALUE OF 5.0 ON EXIT
C
C IER - INTEGER
C IF IER > 0 THEN AN ABNORMAL EXIT HAS OCCURRED;
C A MESSAGE TO DESCRIBE THE ERROR IS AUTOMATICALLY
C WRITTEN ON THE STANDARD OUTPUT CHANNEL.
C IER=0 - NORMAL EXIT.
C IER>0 - ABNORMAL EXIT; THE ERROR MESSAGE SHOULD
C BE SELF EXPLANATORY.
C
C
C 4. SUBROUTINES OR FUNCTIONS NEEDED
C - THE CONFPACK LIBRARY.
C - THE REAL FUNCTION R1MACH.
C - THE USER SUPPLIED COMPLEX FUNCTIONS PARFUN AND DPARFN.
C
C
C 5. FURTHER COMMENTS
C - A SUMMARY LISTING IS AUTOMATICALLY WRITTEN ON THE
C STANDARD OUTPUT CHANNEL.
C - THE OUTPUT FILE zz CONTAINS COORDINATE PAIRS
C
C X Y
C
C FOR POINTS ON THE PHYSICAL BOUNDARY, WITH ONE PAIR
C PER LINE.
C
C ......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 6 JULY 1990
C ......................................................................C
C LOCAL VARIABLES
C
INTEGER I,IA,IMX,L,NH,MNARC
REAL A1,DIFF,DTOL,ERR,HH,MINC,R1MACH,RMAX,RMEAN,RMIN,T,TINC,
+TOL1,TMX,TSD
REAL TT(2)
COMPLEX C1,C2,CENTR,ZZ0,PARFUN,DZZ,DPARFN,ZDPARF,NDZZ
COMPLEX ZZ(2)
CHARACTER OFL*6
PARAMETER (MNARC=200,DTOL=1E-1,NH=4)
LOGICAL ATEND,FIRST,WARND
LOGICAL LNSEG(MNARC)
EXTERNAL DPARFN,LINSEG,PARFUN,R1MACH,WRHEAD,WRTAIL,ZDPARF
C
C**** WRITE CONFPACK HEADING
C
CALL WRHEAD(7,0)
C
IF (NARCS.GT.MNARC) THEN
IER=59
GOTO 999
ENDIF
C
1 FORMAT(A45)
2 FORMAT(A45,I4)
3 FORMAT(A45,E10.3)
4 FORMAT(//,T17,A)
C
TOL1=1E+1*R1MACH(4)
C
C**** CHECK THAT ALL ARCS MEET AT CORNER POINTS
C
IER=0
CENTR=(0E+0,0E+0)
MXMIS=0E+0
DO 10 IA=1,NARCS
IF (IA.EQ.1) THEN
I=NARCS
ELSE
I=IA-1
ENDIF
C1=PARFUN(IA,(-1E+0,0E+0))
CENTR=CENTR+C1
A1=ABS(C1)
C2=PARFUN(I,(1E+0,0E+0))
ERR=ABS(C1-C2)
IF (A1.GE.1E+0) THEN
ERR=ERR/A1
ENDIF
IF (ERR.GT.MXMIS) THEN
IMX=IA
MXMIS=ERR
ENDIF
10 CONTINUE
IF (MXMIS.GE.TOL1) THEN
WRITE(*,3) 'MAXIMUM CORNER MISFIT:',MXMIS
WRITE(*,2) 'OCCURS AT CORNER:',IMX
ELSE
WRITE(*,1) 'ALL ARCS FIT AT CORNERS:'
ENDIF
C
C**** ESTIMATE THE DIAMETER (TSD) OF THE PHYSICAL DOMAIN
C
CENTR=CENTR/NARCS
TSD=0E+0
HH=2E+0/REAL(NH)
DO 15 IA=1,NARCS
T=-1E+0
DO 12 I=1,NH
T=T+HH
C1=PARFUN(IA,CMPLX(T))-CENTR
A1=ABS(C1)
TSD=MAX(TSD,A1)
12 CONTINUE
15 CONTINUE
TSD=2E+0*TSD
C
C**** DETERMINE WHICH ARCS (IF ANY) ARE LINE SEGMENTS
C
CALL LINSEG(LNSEG,NARCS)
C
C**** OPEN FILE TO RECEIVE BOUNDARY DATA POINTS FOR PLOTTING
C
L=INDEX(JBNM,' ')-1
IF (L.EQ.-1) L=4
OFL=JBNM(1:L)//'zz'
OPEN(CHNL,FILE=OFL)
C
C**** SET DEFAULT PLOTTING DISTANCES, IF NECESSARY
C
IF (PSD.LE.0E+0) THEN
PSD=1.6E+2
MINPD=2E+0
MAXPD=5E+0
ENDIF
RMIN=MINPD*TSD/PSD
RMAX=MAXPD*TSD/PSD
RMEAN=5E-1*(RMIN+RMAX)
MINC=SQRT(R1MACH(4))
C
C**** START EVALUATING BOUNDARY POINTS AND DERIVATIVES FOR PLOTTING AND
C**** TESTING
C
MXDIF=0E+0
DO 50 IA=1,NARCS
TT(1)=-1E+0
ZZ(1)=PARFUN(IA,CMPLX(TT(1)))
WRITE(CHNL,'(2E16.7)') ZZ(1)
IF (IA.EQ.1) ZZ0=ZZ(1)
FIRST=.TRUE.
WARND=.FALSE.
20 CONTINUE
C
C**** TEST THE COMPATIBILTY OF PARFUN AND DPARFN BY ESTIMATING DPARFN
C**** NUMERICALLY AT BOTH REAL AND COMPLEX PARAMETER VALUES.
C
DO 30 I=1,2
IF (I.EQ.1) THEN
C1=CMPLX(TT(1))
ELSE
C1=CMPLX(TT(1),MINC)
ENDIF
DZZ=DPARFN(IA,C1)
NDZZ=ZDPARF(IA,C1)
A1=ABS(DZZ)
C
IF (A1.EQ.0E+0) THEN
IER=60
WRITE(*,*)
WRITE(*,*) ' ***DPARFN=(0.,0.)***'
WRITE(*,*) ' ARC:',IA
WRITE(*,*) ' STANDARDISED PARAMETER VALUE:',TT(1)
GOTO 999
ENDIF
C
IF (A1.LE.TOL1 .AND. .NOT.WARND) THEN
WRITE(*,4) '*** W A R N I N G ***'
WRITE(*,2) 'PATHOLOGICALLY SMALL DERIVATIVE ON ARC',IA
WARND=.TRUE.
ENDIF
C
IF (FIRST) THEN
TINC=RMEAN/A1
TINC=MAX(TINC,MINC)
FIRST=.FALSE.
ENDIF
C
ERR=ABS(1E+0-NDZZ/DZZ)
IF (ERR.GT.MXDIF) THEN
MXDIF=ERR
IMX=IA
TMX=TT(1)
ENDIF
30 CONTINUE
C
IF (.NOT.LNSEG(IA)) THEN
C
C**** DETERMINE THE NEXT BOUNDARY POINT TO BE PLOTTED
C
40 CONTINUE
TT(2)=TT(1)+TINC
IF (TT(2) .GE. 1E+0) THEN
TT(2)=1E+0
ATEND=.TRUE.
ELSE
ATEND=.FALSE.
ENDIF
C
ZZ(2)=PARFUN(IA,CMPLX(TT(2)))
DIFF=ABS(ZZ(2)-ZZ(1))
IF (DIFF.EQ.0E+0 .AND. .NOT.ATEND) THEN
TINC=MAX(MINC,2*TINC)
GOTO 40
ENDIF
C
IF (DIFF.GT.RMAX .OR. (DIFF.LT.RMIN .AND. .NOT.ATEND)) THEN
TINC=RMEAN*TINC/DIFF
TINC=MAX(TINC,MINC)
GOTO 40
ENDIF
C
WRITE(CHNL,'(2E16.7)') ZZ(2)
IF (.NOT. ATEND) THEN
ZZ(1)=ZZ(2)
TT(1)=TT(2)
GOTO 20
ENDIF
ENDIF
C
50 CONTINUE
IF (LNSEG(NARCS)) WRITE(CHNL,'(2E16.7)') ZZ0
CLOSE(CHNL)
C
IF (MXDIF .GT. DTOL) THEN
WRITE(*,*)
WRITE(*,2) 'POSSIBLE PARFUN/DPARFN INCONSISTECY ON ARC:',IMX
WRITE(*,3) 'OCCURS AT STANDARDISED PARAMETER VALUE:',TMX
WRITE(*,3) 'RELATIVE FINITE DIFF ERROR:',MXDIF
ELSE
WRITE(*,*)
WRITE(*,1) 'PARFUN AND DPARFN ARE CONSISTENT:'
ENDIF
C
999 CALL WRTAIL(7,0,IER)
C
END
SUBROUTINE UPCOQ1(NARCS,NJIND,NQPTS,MDGPO,MQIN1,AQTOL,QUPTS,QUWTS,
+JACIN,MIDPT,HALEN,ACOEF,BCOEF,H0VAL,COLSC,NQUAD,LOQSB,QCOMX,
+QCOMW,MNQUA,TOLOU,MCQER,XENPT,XIVAL,XIDST,TNSUA,PNEWQ,NEWQU,JATYP,
+PARNT,NUQTL,IER)
INTEGER NARCS,NQPTS,MDGPO,MQIN1,TNSUA,IER,NQUAD(*),LOQSB(*),
+NJIND,JATYP(*),PARNT(*),MNQUA
REAL AQTOL,QUPTS(*),QUWTS(*),JACIN(*),MIDPT(*),HALEN(*),ACOEF(*),
+BCOEF(*),H0VAL(*),COLSC(*),QCOMX(*),QCOMW(*),TOLOU(*),XENPT(*),
+XIDST(*),MCQER
LOGICAL NUQTL
LOGICAL PNEWQ(*),NEWQU(*)
COMPLEX XIVAL(*)
C
C THE PURPOSE OF THIS ROUTINE IS TO UPDATE THE ABSCISSAE
C (QCOMX) AND WEIGHTS (QCOMW) FOR THE COMPOSITE GAUSSIAN RULES
C FOR THE ESTIMATION OF
C
C INTEGRAL [(1+X)**BETA*P(X,I)*LOG|ZZ-X|*dX], I=0,1,...,MDGPO.
C -1<=X<=1 J=1,NZZ
C
C HERE P(.,I) IS THE ORTHONORMAL JACOBI POLYNOMIAL OF DEGREE I
C ASSOCIATED WITH THE WEIGHT (1+X)**BETA AND ZZ IS ANY COLLOCATION
C POINT PREIMAGE NOT ON [-1,1]. BETA TAKES ON THE VARIOUS VALUES
C DEFINED BY ARRAY JACIN. THE ROUTINE ALSO COMPUTES
C
C NQUAD - NQUAD(I) IS THE NUMBER OF QUADRATURE POINTS IN THE
C COMPOSITE RULE FOR BETA=JACIN(I).
C LOQSB - THE ABSCISSAE AND WEIGHTS OF THE COMPOSITE RULE FOR
C BETA=JACIN(I) ARE STORED IN ARRAYS QCOMX AND QCOMW IN
C THE POSITIONS LOQSB(I) TO LOQSB(I)+NQUAD(I)-1 INCLUSIVE.
C XIDST,
C XIVAL - XIVAL(2*I-1) STORES THE COLLOCATION PREIMAGE THOUGHT
C TO BE NEAREST TO -1 AND XIDST(2*I-1) STORES ITS DISTANCE
C FROM -1; SIMILARLY, XIVAL(2*I) STORES THE PREIMAGE
C THOUGHT TO BE NEAREST TO +1 AND XIDST(2*I) ITS DISTANCE
C FROM +1. THE PREIMAGES ARE WITH RESPECT TO
C THE PARAMETRIC FUNCTIONS DEFINING THE SUBARCS WHICH
C MEET AT THE PHYSICAL CORNER WHERE BETA=JACIN(I).
C TOLOU - TOLOU(I) IS THE ESTIMATED MAXIMUM ERROR OVER ALL
C COLLOCATION POINTS IN USING THE COMPOSITE RULE
C FOR BETA=JACIN(I).
C IER - IER=0 FOR NORMAL TERMINATION.
C IER=19 THE REQUIRED TOTAL NUMBER OF COMPOSITE QUADRATURE
C POINTS EXCEEDS THE LIMIT MNQUA.
C IER=20 THE PARAMETER MQIN1 NEEDS INCREASING; MQIN1-1 IS
C THE MAXIMUM ALLOWED NUMBER OF SUBINTERVALS IN OUR
C COMPOSITE GAUSSIAN RULE. (SAME AS IER=11, BUT 20
C IDICATES DURING REFINEMENT PROCESS)
C
C ALL THE ABOVE (APART FROM IER) SHOULD HAVE EXISTING VALUES ON
C INPUT WHICH ARE UPDATED BY THE NEW VERSIONS ON OUTPUT.
C
C LOCAL VARIABLES
C
INTEGER I,I0,I1,I2,J,K,JI,JI0,JI1,JI2,P0,P1,P2,HI,LO,
+QINTS,NQ,DIFF,TNCQP
REAL BETA,H1,M1,T0,T2,SUM1,RR,RRB,MEAN,RXI,IXI,DST(2),R1MACH
COMPLEX ONE,ZZ,Z0,Z2,XI(2),PARFUN,DPARFN
PARAMETER (ONE=(1E+0,0E+0))
EXTERNAL PARFUN,DPARFN,R1MACH,SUBIN7
C
C**** NEWQU(J) IS TRUE IF THE QUADRATURE RULE FOR THE J'TH JACOBI INDEX
C**** NEEDS UPDATING. FIRST SET NEWQU FOR THE CASE WHERE A NEW
C**** QUADRATURE TOLERANCE HAS BEEN FIXED; THIS IS INDEPENDENT OF ANY
C**** POSSIBLE ARC SUBDIVISIONS. IF THE PURE LEGENDRE RULE DOESN'T
C**** ALREADY EXIST THEN IT DOESN'T HAVE TO BE UPDATED.
C
DO 5 J=1,NARCS
NEWQU(J)=NUQTL
5 CONTINUE
NEWQU(NJIND)=(NUQTL .AND. (NQUAD(NJIND).GT.0))
C
C**** NEXT OVERWRITE NEWQU TO PICK UP THOSE CASES WHERE A BOUNDARY
C**** SUBDIVISION HAS OCCURRED AND UPDATE THE NEAR POINT VECTOR XIVAL.
C
DO 30 I1=1,TNSUA
IF (PNEWQ(I1)) THEN
IF (I1 .EQ. 1) THEN
I0=TNSUA
ELSE
I0=I1-1
ENDIF
C
IF (I1 .EQ. TNSUA) THEN
I2=1
ELSE
I2=I1+1
ENDIF
C
JI0=JATYP(I0)
JI1=JATYP(I1)
JI2=JATYP(I2)
C
IF (JI0 .GT. 0) THEN
T0=QUPTS(JI0*NQPTS)
ELSE
JI0=-JI0
T0=-QUPTS((JI0-1)*NQPTS+1)
ENDIF
C
IF (JI2 .GT. 0) THEN
T2=QUPTS((JI2-1)*NQPTS+1)
ELSE
JI2=-JI2
T2=-QUPTS(JI2*NQPTS)
ENDIF
C
T0=MIDPT(I0)+T0*HALEN(I0)
T2=MIDPT(I2)+T2*HALEN(I2)
P0=PARNT(I0)
P1=PARNT(I1)
P2=PARNT(I2)
Z0=PARFUN(P0,CMPLX(T0))
Z2=PARFUN(P2,CMPLX(T2))
H1=HALEN(I1)
M1=MIDPT(I1)
ZZ=CMPLX(M1-H1)
XI(1)=-ONE-(PARFUN(P1,ZZ)-Z0)/DPARFN(P1,ZZ)/H1
ZZ=CMPLX(M1+H1)
XI(2)=ONE-(PARFUN(P1,ZZ)-Z2)/DPARFN(P1,ZZ)/H1
C
IF (JI1 .LT. 0) THEN
Z0=XI(1)
XI(1)=-XI(2)
XI(2)=-Z0
JI1=-JI1
ENDIF
C
DO 10 J=1,2
RXI=REAL(XI(J))
IXI=AIMAG(XI(J))
IF (-1E+0 .LE. RXI .AND. RXI .LE. 1E+0) THEN
DST(J)=ABS(IXI)
ELSE IF (RXI .LT. -1E+0) THEN
DST(J)=ABS(XI(J)+ONE)
ELSE
DST(J)=ABS(XI(J)-ONE)
ENDIF
10 CONTINUE
C
J=2*JI1-2
DO 20 I=1,2
J=J+1
IF (DST(I) .LT. XIDST(J)) THEN
NEWQU(JI1)=.TRUE.
XIVAL(J)=XI(I)
XIDST(J)=DST(I)
ENDIF
20 CONTINUE
ENDIF
30 CONTINUE
C
C FOR THOSE INDECES FOR WHICH NEWQU IS TRUE WE NOW SET UP THE NEW
C COMPOSITE GAUSSIAN QUADRATURE DATA.
C
TNCQP=LOQSB(NJIND)+NQUAD(NJIND)-1
HI=0
DO 90 JI=1,NJIND
NQ=NQUAD(JI)
IF (NEWQU(JI)) THEN
LO=(JI-1)*NQPTS+1
BETA=JACIN(JI)
I2=2*JI-1
CALL SUBIN7(XIVAL(I2),2,BETA,MDGPO,NQPTS,ACOEF(LO),BCOEF(LO),
+ H0VAL(JI),COLSC(LO),AQTOL,TOLOU(JI),XENPT,QINTS,MQIN1,
+ IER)
IF (IER .GT. 0) THEN
IF (IER .EQ. 11) THEN
IER=20
ENDIF
RETURN
ENDIF
C
DIFF=QINTS*NQPTS-NQ
IF (TNCQP+DIFF .GT. MNQUA) THEN
IER=19
RETURN
ENDIF
I1=HI+NQ+1
C
C IF DIFF IS NON-ZERO WE MUST MAKE SPACE IN ARRAYS QCOMX AND
C QCOMW TO RECEIVE THE NEW DATA.
C
IF (DIFF .GT. 0) THEN
DO 40 I=TNCQP,I1,-1
J=I+DIFF
QCOMX(J)=QCOMX(I)
QCOMW(J)=QCOMW(I)
40 CONTINUE
ELSE IF (DIFF .LT. 0) THEN
DO 50 I=I1,TNCQP
J=I+DIFF
QCOMX(J)=QCOMX(I)
QCOMW(J)=QCOMW(I)
50 CONTINUE
ENDIF
C
C NOW SET UP THE NEW RULE AND STORE DATA IN QCOMX, QCOMW
C
TNCQP=TNCQP+DIFF
NQUAD(JI)=NQ+DIFF
LOQSB(JI)=HI+1
SUM1=BETA+1E+0
K=HI
DO 80 I=1,QINTS
RR=(XENPT(I+1)-XENPT(I))*5E-1
MEAN=(XENPT(I+1)+XENPT(I))*5E-1
IF (I .EQ. 1) THEN
RRB=RR**SUM1
LO=LO-1
DO 60 J=1,NQPTS
K=K+1
QCOMX(K)=MEAN+RR*QUPTS(LO+J)
QCOMW(K)=RRB*QUWTS(LO+J)
60 CONTINUE
ELSE
LO=NARCS*NQPTS
DO 70 J=1,NQPTS
K=K+1
QCOMX(K)=MEAN+RR*QUPTS(LO+J)
QCOMW(K)=RR*QUWTS(LO+J)*(1E+0+QCOMX(K))**BETA
70 CONTINUE
ENDIF
80 CONTINUE
HI=HI+NQUAD(JI)
ELSE
C
C HERE WE DO NOTHING OTHER THAN UPDATE SOME SUBSCRIPTS.
C
LOQSB(JI)=HI+1
HI=HI+NQ
ENDIF
C
90 CONTINUE
C
MCQER=0E+0
DO 100 I=1,NJIND
MCQER=MAX(MCQER,TOLOU(I))
100 CONTINUE
C
NUQTL=.FALSE.
C
C NORMAL TERMINATION
C
IER=0
C
END
SUBROUTINE UPJAC1(NQPTS,NJIND,INDEG,AXION,DGPOL,NEWDG,ACOEF,BCOEF,
+DIAG,SDIAG,TNSUA,MNSUA,LOSUB,HISUB,JATYP,PARNT,MIDPT,HALEN,COLPR,
+ZCOLL,LNSEG,PNEWQ,EPS,IER,WORK,NEWHL,RCOPY,ICOPY,LCOPY,LOOLD,
+HIOLD)
INTEGER NQPTS,INDEG,TNSUA,MNSUA,IER,NJIND
INTEGER DGPOL(*),LOSUB(*),HISUB(*),JATYP(*),PARNT(*),ICOPY(*),
+AXION(*),NEWDG(*),LOOLD(*),HIOLD(*)
REAL EPS,ACOEF(*),BCOEF(*),DIAG(*),SDIAG(*),WORK(*),MIDPT(*),
+HALEN(*),COLPR(*),RCOPY(*),NEWHL(*)
COMPLEX ZCOLL(*)
LOGICAL LNSEG(*),LCOPY(*),PNEWQ(*)
C
C**** TO UPDATE THE COLLOCATION PARAMETERS (STORED IN COLPR), THE
C**** COLLOCATION POINTS ON THE PHYSICAL BOUNDARY (STORED IN ZCOLL)
C**** AND THE ARRAYS LOSUB AND HISUB NEEDED TO ACCESS THIS DATA
C**** CORRECTLY.
C**** ALSO TO UPDATE/DETERMINE THE ARRAYS
C**** JATYP - THE JACOBI INDEX TYPE OF EACH SUBARC
C**** PARNT - THE PARENT ARC OF EACH SUBARC
C**** MIDPT - THE GLOBAL PARAMETRIC MIDPOINT OF EACH SUBARC
C**** HALEN - THE GLOBAL PARAMETRIC HALF-LENGTH OF EACH SUBARC
C**** DGPOL - THE POLYNOMIAL DEGREE ON EACH SUBARC
C**** LNSEG - THE LINE SEGMENT BOOLEAN FOR EACH SUBARC
C**** PNEWQ - BOOLEAN INDICATING POSSIBLE NEW QUADRATURE FOR SUBARC
C**** IER=0 - NORMAL TERMINATION
C**** IER=7 - FAILURE IN IMTQLH
C**** IER=17- NUMBER OF SUBARCS REQUIRED EXCEEDS MNSUA
C
C LOCAL VARIABLES
C
INTEGER D,D1,FIRST,I,J,K,K1,K2,P,PREV,IFAIL,JT,NTNSA,J1,J2
REAL S,TC,MD,HH,F1,F2
COMPLEX PARFUN
LOGICAL LS,USEIN
PARAMETER (USEIN=.TRUE.)
EXTERNAL PARFUN,IMTQLH
C
J=0
DO 10 I=1,TNSUA
MD=MIDPT(I)
IF (AXION(I) .LT. 2) THEN
J=J+1
IF (J .GT. MNSUA) THEN
IER=17
RETURN
ENDIF
RCOPY(J)=MD
ELSE
JT=JATYP(I)
IF (JT .GT. 0) THEN
F1=1E+0-NEWHL(I)
ELSE
F1=NEWHL(I)
ENDIF
F2=1E+0-F1
HH=HALEN(I)
J=J+1
IF (J .GT. MNSUA) THEN
IER=17
RETURN
ENDIF
RCOPY(J)=MD-F1*HH
J=J+1
IF (J .GT. MNSUA) THEN
IER=17
RETURN
ENDIF
RCOPY(J)=MD+F2*HH
ENDIF
10 CONTINUE
NTNSA=J
DO 20 I=1,NTNSA
MIDPT(I)=RCOPY(I)
20 CONTINUE
C
J=0
DO 30 I=1,TNSUA
HH=HALEN(I)
IF (AXION(I) .LT. 2) THEN
J=J+1
RCOPY(J)=HH
ELSE
JT=JATYP(I)
IF (JT .GT. 0) THEN
F1=NEWHL(I)
ELSE
F1=1E+0-NEWHL(I)
ENDIF
F2=1E+0-F1
J=J+1
RCOPY(J)=F1*HH
J=J+1
RCOPY(J)=F2*HH
ENDIF
30 CONTINUE
DO 40 I=1,NTNSA
HALEN(I)=RCOPY(I)
40 CONTINUE
C
J=0
DO 50 I=1,TNSUA
JT=JATYP(I)
IF (AXION(I) .LT. 2) THEN
J=J+1
ICOPY(J)=JT
ELSE
IF (JT .LT. NJIND) THEN
IF (JT .GT. 0) THEN
J1=JT
J2=NJIND
ELSE
J1=NJIND
J2=JT
ENDIF
ELSE
J1=NJIND
J2=J1
ENDIF
J=J+1
ICOPY(J)=J1
J=J+1
ICOPY(J)=J2
ENDIF
50 CONTINUE
DO 60 I=1,NTNSA
JATYP(I)=ICOPY(I)
60 CONTINUE
C
J=0
DO 70 I=1,TNSUA
IF (AXION(I) .LT. 2) THEN
J=J+1
ICOPY(J)=PARNT(I)
ELSE
J=J+1
ICOPY(J)=PARNT(I)
J=J+1
ICOPY(J)=PARNT(I)
ENDIF
70 CONTINUE
DO 80 I=1,NTNSA
PARNT(I)=ICOPY(I)
80 CONTINUE
C
J=0
DO 90 I=1,TNSUA
LS=LNSEG(I)
IF (AXION(I) .LT. 2) THEN
J=J+1
LCOPY(J)=LS
ELSE
J=J+1
LCOPY(J)=LS
J=J+1
LCOPY(J)=LS
ENDIF
90 CONTINUE
DO 100 I=1,NTNSA
LNSEG(I)=LCOPY(I)
100 CONTINUE
C
IF (USEIN) THEN
C
C**** USE INDEG ON SUBDIVIDED ARCS
C
J=0
DO 110 I=1,TNSUA
IF (AXION(I) .LT. 2) THEN
J=J+1
DGPOL(J)=NEWDG(I)
ELSE
J=J+1
DGPOL(J)=INDEG
J=J+1
DGPOL(J)=INDEG
ENDIF
110 CONTINUE
ELSE
C
C*** USE CURRENT DEGREE ON SUBDIVIDED ARCS
C
J=0
DO 112 I=1,TNSUA
IF (AXION(I) .LT. 2) THEN
J=J+1
ICOPY(J)=NEWDG(I)
ELSE
J=J+1
ICOPY(J)=DGPOL(I)
J=J+1
ICOPY(J)=DGPOL(I)
ENDIF
112 CONTINUE
DO 113 I=1,NTNSA
DGPOL(I)=ICOPY(I)
113 CONTINUE
ENDIF
C
J=0
DO 115 I=1,TNSUA
IF (AXION(I) .EQ. 2) THEN
J=J+1
LOOLD(J)=0
HIOLD(J)=-1
J=J+1
LOOLD(J)=0
HIOLD(J)=-1
ELSE IF (AXION(I) .EQ. 0) THEN
J=J+1
LOOLD(J)=LOSUB(I)
HIOLD(J)=HISUB(I)
ELSE
J=J+1
LOOLD(J)=0
HIOLD(J)=-1
ENDIF
115 CONTINUE
C
J=0
DO 120 I=1,TNSUA
IF (AXION(I) .LT. 2) THEN
J=J+1
LCOPY(J)=.TRUE.
ELSE
J=J+1
LCOPY(J)=.FALSE.
J=J+1
LCOPY(J)=.FALSE.
ENDIF
120 CONTINUE
C
IF (LCOPY(1) .AND. LCOPY(NTNSA)) THEN
IF (LCOPY(2)) THEN
PNEWQ(1)=.FALSE.
ELSE
PNEWQ(1)=.TRUE.
ENDIF
IF (LCOPY(NTNSA-1)) THEN
PNEWQ(NTNSA)=.FALSE.
ELSE
PNEWQ(NTNSA)=.TRUE.
ENDIF
ELSE
PNEWQ(1)=.TRUE.
PNEWQ(NTNSA)=.TRUE.
ENDIF
C
J=NTNSA-1
DO 130 I=2,J
IF (LCOPY(I-1) .AND. LCOPY(I) .AND. LCOPY(I+1)) THEN
PNEWQ(I)=.FALSE.
ELSE
PNEWQ(I)=.TRUE.
ENDIF
130 CONTINUE
C
TNSUA=NTNSA
LOSUB(1)=1
HISUB(1)=1+DGPOL(1)
DO 140 I=2,TNSUA
LOSUB(I)=HISUB(I-1)+1
HISUB(I)=LOSUB(I)+DGPOL(I)
140 CONTINUE
C
DO 170 I=1,TNSUA
J=JATYP(I)
P=PARNT(I)
D=DGPOL(I)
D1=D+1
IF (J .GT. 0) THEN
S=1E+0
ELSE
S=-1E+0
J=-J
ENDIF
PREV=(J-1)*NQPTS
FIRST=LOSUB(I)
DO 150 K=1,D1
WORK(K)=0E+0
K1=PREV+K
DIAG(K)=BCOEF(K1)
IF (K .EQ. 1) THEN
SDIAG(K)=0E+0
ELSE
SDIAG(K)=ACOEF(K1-1)
ENDIF
150 CONTINUE
WORK(1)=1E+0
CALL IMTQLH(D1,DIAG,SDIAG,IFAIL)
IF (IFAIL .GT. 0) THEN
IER=7
RETURN
ENDIF
DO 160 K=1,D1
TC=S*DIAG(K)
K2=FIRST+K-1
COLPR(K2)=TC
TC=MIDPT(I)+HALEN(I)*TC
ZCOLL(K2)=PARFUN(P,CMPLX(TC))
160 CONTINUE
170 CONTINUE
C
C NORMAL EXIT
C
IER=0
C
END
SUBROUTINE WRFUN1(NARCS,STAPT,ARCTY,PGM,RGM,PTX,NTX,DEFN,
+CHNL,CHIA,CHTT,VAR,REDD)
INTEGER NARCS,CHNL
INTEGER ARCTY(*),PGM(*),PTX(*),NTX(*)
REAL RGM(*)
COMPLEX STAPT(*)
CHARACTER DEFN(*)*72,CHIA*2,CHTT*2,VAR*6,REDD*6
C
C**** TO WRITE THE SOURCE CODE FOR PARFUN IN THE CASE WHERE NO
C**** SYMMETRY IS INVOLVED.
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 4 AUG 1990
C.......................................................................
C
C LOCAL VARIABLES
C
INTEGER IA,I,J
CHARACTER TX1*16,TX2*21,FMT1*11,FMT2*11
EXTERNAL PTFUN1
C
TX1=' IF ('//CHIA//'.EQ.'
TX2=' ELSE IF ('//CHIA//'.EQ.'
FMT1='(A16,I3,A6)'
FMT2='(A21,I3,A6)'
C
DO 100 IA=1,NARCS
I=PGM(IA)
J=PTX(IA)
IF (NARCS.EQ.1) THEN
CALL PTFUN1(ARCTY(IA),STAPT(IA),RGM(I),NTX(IA),DEFN(J),
+ CHNL,CHTT,VAR,REDD)
ELSE
IF (IA.EQ.1) THEN
WRITE(CHNL,FMT1) TX1,IA,') THEN'
ELSE IF (IA.EQ.NARCS) THEN
WRITE(CHNL,'(A10)') ' ELSE'
ELSE
WRITE(CHNL,FMT2) TX2,IA,') THEN'
ENDIF
CALL PTFUN1(ARCTY(IA),STAPT(IA),RGM(I),NTX(IA),DEFN(J),
+ CHNL,CHTT,VAR,REDD)
IF (IA.EQ.NARCS) WRITE(CHNL,'(A11)') ' ENDIF'
ENDIF
100 CONTINUE
C
END
SUBROUTINE WRFUN2(NARCS,MNARC,STAPT,ARCTY,PGM,RGM,PTX,NTX,
+DEFN,CHNL,CHIA,CHTT,VAR,NUMDER,REDD)
INTEGER NARCS,MNARC,CHNL
INTEGER ARCTY(*),PGM(*),PTX(*),NTX(*)
REAL RGM(*)
COMPLEX STAPT(*)
LOGICAL NUMDER(*)
CHARACTER DEFN(*)*72,CHIA*2,CHTT*2,VAR*6,REDD*6
C
C**** TO WRITE THE SOURCE CODE FOR DPARFN IN THE CASE WHERE NO
C**** SYMMETRY IS INVOLVED.
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 4 AUG 1990
C.......................................................................
C
C LOCAL VARIABLES
C
INTEGER IA,I,J1,J2,N1,N2
CHARACTER TX1*16,TX2*21,FMT1*11,FMT2*11
EXTERNAL PTFUN2
C
TX1=' IF ('//CHIA//'.EQ.'
TX2=' ELSE IF ('//CHIA//'.EQ.'
FMT1='(A16,I3,A6)'
FMT2='(A21,I3,A6)'
C
DO 100 IA=1,NARCS
I=PGM(IA)
J1=PTX(IA)
J2=PTX(IA+MNARC)
N1=NTX(IA)
N2=NTX(IA+MNARC)
IF (NARCS.EQ.1) THEN
CALL PTFUN2(ARCTY(IA),STAPT(IA),RGM(I),N1,DEFN(J1),
+ N2,DEFN(J2),CHNL,CHTT,VAR,' 1',NUMDER(IA),REDD)
ELSE
IF (IA.EQ.1) THEN
WRITE(CHNL,FMT1) TX1,IA,') THEN'
ELSE IF (IA.EQ.NARCS) THEN
WRITE(CHNL,'(A10)') ' ELSE'
ELSE
WRITE(CHNL,FMT2) TX2,IA,') THEN'
ENDIF
CALL PTFUN2(ARCTY(IA),STAPT(IA),RGM(I),N1,DEFN(J1),
+ N2,DEFN(J2),CHNL,CHTT,VAR,CHIA,NUMDER(IA),REDD)
IF (IA.EQ.NARCS) WRITE(CHNL,'(A11)') ' ENDIF'
ENDIF
100 CONTINUE
C
END
SUBROUTINE WRHEAD(I,CHNL)
INTEGER I,CHNL
C
C**** WRITE A HEADING FOR THE MAIN CONFPACK MODULES JAPHYC (I=1),
C**** GQPHYC (I=2), JACANP (I=3), GQCANP (I=4), CNDPLT (I=5), THE
C**** PARAMETRIC FUNCTION GENERATOR PARGEN (I=6),THE PARAMETRIC FUNCTION
C**** TESTER TSTPLT (I=7) AND THE LEVEL CURVE ROUTINE LEVCUR (I=8). IF
C**** CHNL=0 THEN WRITE ON THE STANDARD OUTPUT CHANNEL, OTHERWISE WRITE
C**** ON THE CHANNEL SPECIFIED BY CHNL.
C
C LOCAL VARIABLES
C
CHARACTER DOTS*49,CPHEAD*36,MOD(8)*13,TXT*49
DATA
+ DOTS/'.................................................'/
+CPHEAD/': C O N F P A C K M O D U L E '/
+ MOD/'J A P H Y C :',
+ 'G Q P H Y C :',
+ 'J A C A N P :',
+ 'G Q C A N P :',
+ 'C N D P L T :',
+ 'P A R G E N :',
+ 'T S T P L T :',
+ 'L E V C U R :'/
C
TXT=CPHEAD//MOD(I)
IF (CHNL.EQ.0) THEN
WRITE(*,1) DOTS,TXT,DOTS
ELSE
WRITE(CHNL,1) DOTS,TXT,DOTS
ENDIF
C
1 FORMAT(//,T6,A49,/,T6,A49,/,T6,A49,//)
C
END
SUBROUTINE WRSYM1(NARCS,ORDRG,ORDSG,RTUNI,U2,CENSY,REFLN,PARFUN,
+REDD,CHNL)
INTEGER NARCS,ORDRG,ORDSG,CHNL
COMPLEX RTUNI,U2,CENSY
LOGICAL REFLN,PARFUN
CHARACTER REDD*6
C
C**** TO WRITE THE DIMENSION AND PARAMETER STATEMENTS AND THE CODE TO
C**** TO REDUCE A GIVEN ARC NUMBER TO ITS SYMMETRIC COUNTERPART ON THE
C**** FUNDAMENTAL BOUNDARY SECTION.
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 4 AUG 1990
C.......................................................................C
C LOCAL VARIABLES
C
INTEGER I
REAL R,A
COMPLEX ZT
LOGICAL NEEDC
CHARACTER FMT*25
C
FMT='(A12,'//REDD//',A1,'//REDD//',A2)'
C
IF (PARFUN) THEN
NEEDC=(CENSY.NE.(0E+0,0E+0))
IF (NEEDC .OR. REFLN) THEN
WRITE(CHNL,'(A17)') ' PARAMETER ('
IF (NEEDC .AND. REFLN) THEN
R=REAL(U2)
A=AIMAG(U2)
WRITE(CHNL,FMT) ' +U2 =(',R,',',A,'),'
R=REAL(CENSY)
A=AIMAG(CENSY)
WRITE(CHNL,FMT) ' +ZCEN=(',R,',',A,'))'
ELSE IF (NEEDC .AND. (.NOT.REFLN)) THEN
R=REAL(CENSY)
A=AIMAG(CENSY)
WRITE(CHNL,FMT) ' +ZCEN=(',R,',',A,'))'
ELSE
R=REAL(U2)
A=AIMAG(U2)
WRITE(CHNL,FMT) ' +U2 =(',R,',',A,'))'
ENDIF
WRITE(CHNL,'(A1)') 'C'
ENDIF
ELSE IF (REFLN) THEN
R=REAL(U2)
A=AIMAG(U2)
WRITE(CHNL,'(A17)') ' PARAMETER ('
WRITE(CHNL,FMT) ' +U2 =(',R,',',A,'))'
WRITE(CHNL,'(A1)') 'C'
ENDIF
C
FMT='(A7,'//REDD//',A1,'//REDD//',A2)'
C
IF (ORDRG.GE.2) THEN
WRITE(CHNL,'(A19,I3,A1)') ' DIMENSION WW(',ORDRG-1,')'
WRITE(CHNL,'(A14)') ' DATA WW/'
ZT=(1E+0,0E+0)
DO 10 I=1,ORDRG-2
ZT=ZT*RTUNI
R=REAL(ZT)
A=AIMAG(ZT)
WRITE(CHNL,FMT) ' +(',R,',',A,'),'
10 CONTINUE
ZT=ZT*RTUNI
R=REAL(ZT)
A=AIMAG(ZT)
WRITE(CHNL,FMT) ' +(',R,',',A,')/'
WRITE(CHNL,'(A1)') 'C'
ENDIF
C
IF (ORDRG.GT.19) THEN
WRITE(*,'(//)')
WRITE(*,*)' ****WARNING****'
WRITE(*,*)'MORE THAN 19 CONTINUTATION LINES HAVE BEEN WRITTEN'
ENDIF
C
IF (REFLN) THEN
IF (ORDRG.GT.1) THEN
IF (NARCS.GT.1) THEN
I=2*NARCS
WRITE(CHNL,'(A16,I3,A1)') ' IB=MOD(IA,',I,')'
WRITE(CHNL,'(A22,I3)') ' IF (IB.EQ.0) IB=',I
I=I+1
WRITE(CHNL,'(A16,I3,A6)') ' IF (IB.GT.',NARCS,')
+THEN'
WRITE(CHNL,'(A13,I3,A3)') ' IB=',I,'-IB'
WRITE(CHNL,'(A23)') ' TS=-CONJG(TT)'
WRITE(CHNL,'(A10)') ' ELSE'
WRITE(CHNL,'(A15)') ' TS=TT'
WRITE(CHNL,'(A11)') ' ENDIF'
ELSE
WRITE(CHNL,'(A30)') ' IF (MOD(IA,2).EQ.0) THEN'
WRITE(CHNL,'(A23)') ' TS=-CONJG(TT)'
WRITE(CHNL,'(A10)') ' ELSE'
WRITE(CHNL,'(A15)') ' TS=TT'
WRITE(CHNL,'(A11)') ' ENDIF'
ENDIF
ELSE
IF (NARCS.GT.1) THEN
I=2*NARCS+1
WRITE(CHNL,'(A16,I3,A6)') ' IF (IA.GT.',NARCS,')
+THEN'
WRITE(CHNL,'(A13,I3,A3)') ' IB=',I,'-IA'
WRITE(CHNL,'(A23)') ' TS=-CONJG(TT)'
WRITE(CHNL,'(A10)') ' ELSE'
WRITE(CHNL,'(A15)') ' IB=IA'
WRITE(CHNL,'(A15)') ' TS=TT'
WRITE(CHNL,'(A11)') ' ENDIF'
ELSE
WRITE(CHNL,'(A23)') ' IF (IA.EQ.2) THEN'
WRITE(CHNL,'(A23)') ' TS=-CONJG(TT)'
WRITE(CHNL,'(A10)') ' ELSE'
WRITE(CHNL,'(A15)') ' TS=TT'
WRITE(CHNL,'(A11)') ' ENDIF'
ENDIF
ENDIF
ELSE IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A16,I3,A1)') ' IB=MOD(IA,',NARCS,')'
WRITE(CHNL,'(A22,I3)') ' IF (IB.EQ.0) IB=',NARCS
ENDIF
C
WRITE(CHNL,'(A1)') 'C'
C
END
SUBROUTINE WRSYM2(NARCS,ORDRG,CENSY,REFLN,CHNL)
INTEGER NARCS,ORDRG,CHNL
COMPLEX CENSY
LOGICAL REFLN
C
C**** TO WRITE THE CODE TO RECOVER THE BOUNDARY POINT FROM ITS SYMMETRIC
C**** COUNTERPART ON THE FUNDAMENTAL BOUNDARY SECTION.
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 4 AUG 1990
C.......................................................................C
C LOCAL VARIABLES
C
INTEGER I
LOGICAL NEEDC
C
NEEDC=(CENSY.NE.(0E+0,0E+0))
C
WRITE(CHNL,'(A1)') 'C'
C
IF (REFLN) THEN
IF (ORDRG.GT.1) THEN
I=2*NARCS
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A19,I3,A1)')' IS=MOD(IA-IB,',I,')'
WRITE(CHNL,'(A20,I3)')' IR=(IA-IB-IS)/',I
ELSE
WRITE(CHNL,'(A20)')' IS=MOD(IA-1,2)'
WRITE(CHNL,'(A20)')' IR=(IA-1-IS)/2'
ENDIF
WRITE(CHNL,'(A37)')' IF (IR.EQ.0 .AND. IS.EQ.0) THEN'
WRITE(CHNL,'(A21)')' PARFUN=ZETA'
WRITE(CHNL,'(A42)')' ELSE IF (IR.GT.0 .AND. IS.EQ.0)
+THEN'
IF (NEEDC) THEN
WRITE(CHNL,'(A40)')' PARFUN=ZCEN+WW(IR)*(ZETA-
+ZCEN)'
ELSE
WRITE(CHNL,'(A28)')' PARFUN=WW(IR)*ZETA'
ENDIF
WRITE(CHNL,'(A42)')' ELSE IF (IR.EQ.0 .AND. IS.GT.0)
+THEN'
IF (NEEDC) THEN
WRITE(CHNL,'(A41)')' PARFUN=ZCEN+U2*CONJG(ZETA-
+ZCEN)'
ELSE
WRITE(CHNL,'(A31)')' PARFUN=U2*CONJG(ZETA)'
ENDIF
WRITE(CHNL,'(A10)')' ELSE'
IF (NEEDC) THEN
WRITE(CHNL,'(A48)')' PARFUN=ZCEN+U2*WW(IR)*CO
+NJG(ZETA-ZCEN)'
ELSE
WRITE(CHNL,'(A38)')' PARFUN=U2*WW(IR)*CONJG(Z
+ETA)'
ENDIF
WRITE(CHNL,'(A11)')' ENDIF'
ELSE
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A14)')' IS=IA-IB'
ELSE
WRITE(CHNL,'(A13)')' IS=IA-1'
ENDIF
WRITE(CHNL,'(A23)')' IF (IS.EQ.0) THEN'
WRITE(CHNL,'(A21)')' PARFUN=ZETA'
WRITE(CHNL,'(A10)')' ELSE'
IF (NEEDC) THEN
WRITE(CHNL,'(A41)')' PARFUN=ZCEN+U2*CONJG(ZET
+A-ZCEN)'
ELSE
WRITE(CHNL,'(A31)')' PARFUN=U2*CONJG(ZETA)'
ENDIF
WRITE(CHNL,'(A11)')' ENDIF'
ENDIF
ELSE
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A17,I3)')' IR=(IA-IB)/',NARCS
ELSE
WRITE(CHNL,'(A13)')' IR=IA-1'
ENDIF
WRITE(CHNL,'(A23)')' IF (IR.EQ.0) THEN'
WRITE(CHNL,'(A21)')' PARFUN=ZETA'
WRITE(CHNL,'(A10)')' ELSE'
IF (NEEDC) THEN
WRITE(CHNL,'(A40)')' PARFUN=ZCEN+WW(IR)*(ZETA-ZCE
+N)'
ELSE
WRITE(CHNL,'(A28)')' PARFUN=WW(IR)*ZETA'
ENDIF
WRITE(CHNL,'(A11)')' ENDIF'
ENDIF
C
END
SUBROUTINE WRSYM3(NARCS,ORDRG,REFLN,CHNL)
INTEGER NARCS,ORDRG,CHNL
LOGICAL REFLN
C
C**** TO WRITE THE CODE TO RECOVER THE DERIVATIVE FROM ITS SYMMETRIC
C**** COUNTERPART ON THE FUNDAMENTAL BOUNDARY SECTION.
C
C.......................................................................
C AUTHOR: DAVID HOUGH, ETH, ZUERICH
C LAST UPDATE: 4 AUG 1990
C.......................................................................C
C LOCAL VARIABLES
C
INTEGER I
C
C
WRITE(CHNL,'(A1)') 'C'
C
IF (REFLN) THEN
IF (ORDRG.GT.1) THEN
I=2*NARCS
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A19,I3,A1)')' IS=MOD(IA-IB,',I,')'
WRITE(CHNL,'(A20,I3)') ' IR=(IA-IB-IS)/',I
ELSE
WRITE(CHNL,'(A20)')' IS=MOD(IA-1,2)'
WRITE(CHNL,'(A20)')' IR=(IA-1-IS)/2'
ENDIF
WRITE(CHNL,'(A37)')' IF (IR.EQ.0 .AND. IS.EQ.0) THEN'
WRITE(CHNL,'(A21)')' DPARFN=ZETA'
WRITE(CHNL,'(A42)')' ELSE IF (IR.GT.0 .AND. IS.EQ.0)
+THEN'
WRITE(CHNL,'(A28)')' DPARFN=WW(IR)*ZETA'
WRITE(CHNL,'(A42)')' ELSE IF (IR.EQ.0 .AND. IS.GT.0)
+THEN'
WRITE(CHNL,'(A32)')' DPARFN=-U2*CONJG(ZETA)'
WRITE(CHNL,'(A10)')' ELSE'
WRITE(CHNL,'(A39)')' DPARFN=-U2*WW(IR)*CONJG(ZETA
+)'
WRITE(CHNL,'(A11)')' ENDIF'
ELSE
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A14)')' IS=IA-IB'
ELSE
WRITE(CHNL,'(A13)')' IS=IA-1'
ENDIF
WRITE(CHNL,'(A23)')' IF (IS.EQ.0) THEN'
WRITE(CHNL,'(A21)')' DPARFN=ZETA'
WRITE(CHNL,'(A10)')' ELSE'
WRITE(CHNL,'(A32)')' DPARFN=-U2*CONJG(ZETA)'
WRITE(CHNL,'(A11)')' ENDIF'
ENDIF
ELSE
IF (NARCS.GT.1) THEN
WRITE(CHNL,'(A17,I3)')' IR=(IA-IB)/',NARCS
ELSE
WRITE(CHNL,'(A13)')' IR=IA-1'
ENDIF
WRITE(CHNL,'(A23)')' IF (IR.EQ.0) THEN'
WRITE(CHNL,'(A21)')' DPARFN=ZETA'
WRITE(CHNL,'(A10)')' ELSE'
WRITE(CHNL,'(A28)')' DPARFN=WW(IR)*ZETA'
WRITE(CHNL,'(A11)')' ENDIF'
ENDIF
C
END
SUBROUTINE WRTAIL(I,CHNL,IER)
INTEGER I,CHNL,IER
C
C**** WRITE A CLOSING MESSAGE FOR THE MAIN CONFPACK MODULES JAPHYC (I=1)
C**** GQPHYC (I=2), JACANP (I=3), GQCANP (I=4), CNDPLT (I=5), THE PARA-
C**** METRIC FUNCTION GENERATOR PARGEN (I=6), THE PARAMETRIC FUNCTION
C**** TESTER TSTPLT (I=7) AND THE LEVEL CURVE ROUTINE LEVCUR (I=8). IF
C**** CHNL=0 THEN WRITE ON THE STANDARD OUTPUT CHANNEL, OTHERWISE WRITE
C**** ON THE CHANNEL SPECIFIED BY CHNL. THE TEXT OF THE MESSAGE IS
C**** DETERMINED BY THE ERROR NUMBER IER VIA THE SUBROUTINE IERTXT.
C
C LOCAL VARIABLES
C
CHARACTER MOD(8)*13,BAD*15,GOOD*13,TXT*36,IERTXT*66,TXT2*66,
+LINE*66
EXTERNAL IERTXT
C
DATA
+MOD/'J A P H Y C :','G Q P H Y C :','J A C A N P :',
+ 'G Q C A N P :','C N D P L T :','P A R G E N :',
+ 'T S T P L T :','L E V C U R :'/
+GOOD/' NORMAL EXIT'/
+ BAD/' ABNORMAL EXIT'/
+LINE/'____________________________________________________________
+______&'/
C
IF (IER.EQ.0) THEN
TXT=MOD(I)//GOOD
ELSE
TXT=MOD(I)//BAD
ENDIF
TXT2=IERTXT(IER)
C
IF (CHNL.EQ.0) THEN
WRITE(*,1) TXT
WRITE(*,2) TXT2
WRITE(*,*) LINE
ELSE
WRITE(CHNL,1) TXT
WRITE(CHNL,2) TXT2
WRITE(CHNL,*) LINE
ENDIF
C
1 FORMAT(//,T6,A)
2 FORMAT(T6,A)
C
END
COMPLEX FUNCTION ZDPARF(I,T)
INTEGER I
COMPLEX T
C
C**** NUMERICAL ESTIMATION OF THE DERIVATIVE OF THE PARAMETRIC FUNCTION
C**** USING 2- OR 4-POINT TRAPEZOIDAL RULE ESTIMATES IN CAUCHY'S
C**** FORMULA. THE 2-POINT ESTIMATE IS THE STANDARD CENTRAL DIFFERENCE
C**** IN THE REAL AXIS DIRECTION.
C
REAL EPS,R1MACH
COMPLEX IM,PARFUN,SUM
LOGICAL FOUR
PARAMETER (FOUR=.FALSE.,IM=(0E+0,1E+0))
C
EXTERNAL PARFUN,R1MACH
C
EPS=(R1MACH(4))**3.333E-1
SUM=(PARFUN(I,T+EPS) -PARFUN(I,T-EPS))/2E+0/EPS
C
IF (FOUR) THEN
ZDPARF=SUM/2E+0 -
+ IM*(PARFUN(I,T+IM*EPS)-PARFUN(I,T-IM*EPS))/4E+0/EPS
ELSE
ZDPARF=SUM
ENDIF
C
END
COMPLEX FUNCTION ZTOB1(Z,B1,JT,IN)
INTEGER JT
REAL B1
COMPLEX Z
LOGICAL IN
C
C TO COMPUTE Z**B1 BUT CHOOSING THE BRANCH CUT TO POINT ALONG THE
C RAY WITH POLAR ANGLE DEFINED BY THE VARIABLE *CUT* BELOW.
C
C THIS IS A SPECIAL PURPOSE ROUTINE IN THAT IT IS ASSUMED THAT
C B1=1/ALHPA, WHERE ALPHA*PI IS THE INTERIOR ANGLE AT THE BRANCH
C POINT OF THE MAP : PHYSICAL --> CANONICAL. HENCE THE USE OF THIS
C ROUTINE IS EFFECTIVELY RESTRCITED TO COMPUTING ONLY THE BOUNDARY
C CORRESPONDENCE FUNCTION FOR COMPLEX PARAMETERS.
C
REAL CUT,PI,TUPI
COMPLEX W
PARAMETER (PI=3.1415926535897932384E+0,
+TUPI=6.2831853071795864769E+0)
C
IF (ABS(Z) .EQ. 0E+0) THEN
ZTOB1=(0E+0,0E+0)
RETURN
ENDIF
W=CLOG(Z)
CUT=PI*(5E-1-B1)/B1
IF ((JT.LT.0E+0 .AND. IN).OR.(JT.GT.0E+0 .AND. .NOT.IN)) THEN
CUT=-CUT
IF (AIMAG(W) .GT. CUT) THEN
W=W-CMPLX(0E+0,TUPI)
ENDIF
ELSE IF (AIMAG(W) .LT. CUT) THEN
W=W+CMPLX(0E+0,TUPI)
ENDIF
ZTOB1=CEXP(W*B1)
C
END