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