Porting continues.
authorilb@NIH.GOV <ilb@NIH.GOV@ba61647d-9d00-f842-95cd-605cb4296b96>
Tue, 23 Jan 2018 21:06:53 +0000 (21:06 +0000)
committerilb@NIH.GOV <ilb@NIH.GOV@ba61647d-9d00-f842-95cd-605cb4296b96>
Tue, 23 Jan 2018 21:06:53 +0000 (21:06 +0000)
git-svn-id: https://citdcbmipav.cit.nih.gov/repos-pub/mipav/trunk@15348 ba61647d-9d00-f842-95cd-605cb4296b96

mipav/src/gov/nih/mipav/model/algorithms/SymmsIntegralMapping.java

index ad7775e..124750e 100644 (file)
@@ -12668,11 +12668,12 @@ public class SymmsIntegralMapping extends AlgorithmBase  {
        \r
        final int NIXINT = 200;\r
        final int MAXSA = 100;\r
-       int I,IMNLA,J,L,LODP,LODW,MNEQN,MNSUA,NARCS,NASYM,NCRVS,\r
-            NINFD,NJIND,NPRVS,NQPTS,NZERD,TNGQP,TNSUA;\r
+       int I,IMNLA,J,L,MNSUA,NASYM,NCRVS,\r
+            NINFD,NPRVS,NXINT,NZERD,TNSUA;\r
        final double BIG = 4.4;\r
        double ANGSP,CCAPH,COCAP,COPHC,CPHCA,CR,EXCAP,EXPHC,LA,\r
             OFLOW,PI,R1MACH,TOTLN,MCHEP;\r
+       String CHPC, CHCP;\r
        //CHARACTER OFLC*6,OFP0*6,OFP1*6,JBNM*4,CHPC*2,CHCP*2\r
        \r
        \r
@@ -12724,148 +12725,155 @@ public class SymmsIntegralMapping extends AlgorithmBase  {
        \r
        //**** COPY POINTERS FROM JAPHYC\r
        \r
-            \r
-       /*\r
-             OPEN(CH0,FILE=OFP0)\r
-             OPEN(CH1,FILE=OFP1)\r
-             WRITE(*,5) 'EVALUATION OF BCF STARTED:'\r
-       5     FORMAT(A45)\r
-             LODP=QUPTS+NARCS*NQPTS\r
-             LODW=QUWTS+NARCS*NQPTS\r
-             CALL DIAGN4(CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,ICRVS,IER,\r
-            +IPRVS,NASYM,NCRVS,NINFD,NPRVS,NZERD,ARCLN,ASYMP,BCDMN,CORXX,\r
-            +TOTLN,RGEOM(VTARG),MAP11,ISNPH(DGPOL),ISNPH(JATYP),ISNPH(LOSUB),\r
-            +NARCS,NQPTS,NXINT,CH0,CH1,IGEOM(PARNT),TNSUA,RSNPH(AICOF),\r
-            +RSNPH(ACOEF),RSNPH(BICOF),RSNPH(BCFSN),RSNPH(BCOEF),RSNPH(H0VAL),\r
-            +RSNPH(HIVAL),RGEOM(HALEN),RSNPH(JACIN),RGEOM(MIDPT),RSNPH(SOLUN),\r
-            +RSNPH(LODP),RSNPH(LODW))\r
-             WRITE(*,5) 'EVALUATION OF BCF DONE:'\r
-       C\r
-             IF (IER .GT. 0) THEN\r
-               GOTO 999\r
-             ENDIF\r
-       C\r
-             IF (NASYM .GT. 0) THEN\r
-               WRITE(CH1,*) DASH\r
-               DO 10 I=1,NASYM\r
-                 WRITE(CH1,*) NEWD\r
-                 WRITE(CH1,20) ASYMP(I),0E+0\r
-                 WRITE(CH1,20) ASYMP(I),BIG\r
-       10      CONTINUE\r
-       20      FORMAT(2E16.8)\r
-             ENDIF\r
-             CLOSE(CH1)\r
-       C\r
-             WRITE(CH0,*) DASH\r
-             DO 30 I=2,NARCS\r
-               WRITE(CH0,*) NEWD\r
-               WRITE(CH0,20) CORXX(I),0E+0\r
-               WRITE(CH0,20) CORXX(I),1E+0\r
-       30    CONTINUE\r
-             CLOSE(CH0)\r
-             WRITE(*,5) 'DATA FOR PLOTS DONE:'\r
-       C\r
-             OFLOW=R1MACH(2)\r
-             MCHEP=R1MACH(4)\r
-             UPHYC=MCHEP*CPHCA\r
-             UCANP=MCHEP*CCAPH\r
-             WRITE(*,*)\r
-             WRITE(*,35) 'PHYSICAL ROUNDOFF MAGNIFIES TO:',UPHYC\r
-             WRITE(*,35) 'CANONICAL ROUNDOFF MAGNIFIES TO:',UCANP\r
-       35    FORMAT(A45,2X,E9.2)\r
-       C\r
-             OPEN(CH0,FILE=OFLC)\r
-       C\r
-       C**** WRITE CONFPACK HEADING ON LISTING FILE\r
-       C\r
-             CALL WRHEAD(5,CH0)\r
-       C\r
-             WRITE(CH0,*)\r
-             WRITE(CH0,40)\r
-       40    FORMAT(T4,'MAP',T18,'ESTIMATED EVALUATION',T42,'ESTIMATED MAXIMUM'\r
-            +,/,T18,'CONDITION NUMBER',T42,'ROUNDOFF ERROR *',/)\r
-       C\r
-             IF (NINFD .GT. 0) THEN\r
-               CHPC='**'\r
-             ELSE\r
-               CHPC='  '\r
-             ENDIF\r
-             IF (NZERD .GT. 0) THEN\r
-               CHCP='**'\r
-             ELSE\r
-               CHCP='  '\r
-             ENDIF\r
-       C\r
-             WRITE(CH0,50) CPHCA,CHPC,UPHYC\r
-             WRITE(CH0,60) CCAPH,CHCP,UCANP\r
-       50    FORMAT('PHY --> CAN',T20,E11.3,A2,T44,E11.3,/)\r
-       60    FORMAT('CAN --> PHY',T20,E11.3,A2,T44,E11.3,/)\r
-             WRITE(CH0,*) '* BASED ON UNIT ROUNDOFF IN DOMAIN OF MAP'\r
-             IF (NINFD.GT.0 .OR. NZERD.GT.0) THEN\r
-               WRITE(CH0,*)'** CONDITION NUMBER DEPENDS ON UNIT ROUNDOFF,U:'\r
-               IF (NINFD .GT. 0) THEN\r
-                 WRITE(CH0,70) COPHC,EXPHC\r
-               ENDIF\r
-               IF (NZERD .GT. 0) THEN\r
-                 WRITE(CH0,80) COCAP,EXCAP\r
-               ENDIF\r
-             ENDIF\r
-       70    FORMAT(T4,'PHY --> CAN : CONDTN NO = ',E11.3,'*U**',E11.3)\r
-       80    FORMAT(T4,'CAN --> PHY : CONDTN NO = ',E11.3,'*U**',E11.3)\r
-       C\r
-             PI=4E+0*ATAN(1E+0)\r
-             WRITE(CH0,90) 'END PT.','PARENT','ARGUMENT/PI'\r
-       90    FORMAT(//,A,T10,A,T18,A)\r
-             DO 100 I=1,TNSUA\r
-               WRITE(CH0,110) I,IGEOM(PARNT+I-1),RGEOM(VTARG+I-1)/PI\r
-       100   CONTINUE\r
-       110   FORMAT(I3,T10,I3,T18,E16.8)\r
-       C\r
-             WRITE(CH0,120) 'SUBARC','% PHYSICAL','% CIRCLE'\r
-       120   FORMAT(/,A,T10,A,T29,A)\r
-             DO 130 I=1,TNSUA\r
-               ANGSP=RGEOM(VTARG+I)-RGEOM(VTARG+I-1)\r
-               WRITE(CH0,140) I,ARCLN(I)/TOTLN,ANGSP/2E+0/PI\r
-       130   CONTINUE\r
-       140   FORMAT(I4,T10,E14.7,T29,E14.7)\r
-       C\r
-             WRITE(CH0,150) 'SUB','ACHIEVED','CROWDING','ARC','RESOLUTION',\r
-            +'FACTOR'\r
-       150   FORMAT(/,A,T7,A,T19,A,/,A,T7,A,T19,A)\r
-             RESMN=OFLOW\r
-             DO 160 I=1,TNSUA\r
-               ANGSP=RGEOM(VTARG+I)-RGEOM(VTARG+I-1)\r
-               IF (ANGSP.EQ.0E+0) THEN\r
-                 CR=OFLOW\r
-                 LA=0E+0\r
-               ELSE\r
-                 CR=2E+0*PI*ARCLN(I)/ABS(ANGSP)/TOTLN\r
-                 IF (RSNPH(ERARC+I-1).EQ.0E+0) THEN\r
-                   LA=OFLOW\r
-                 ELSE\r
-                   LA=ABS(ANGSP)/(2E+0*RSNPH(ERARC+I-1))\r
-                 ENDIF\r
-               ENDIF\r
-               IF (LA .LT. RESMN) THEN\r
-                 RESMN=LA\r
-                 IMNLA=I\r
-               ENDIF\r
-               WRITE(CH0,170) I,LA,CR\r
-       160   CONTINUE\r
-       170   FORMAT(I2,T4,2E12.3)\r
-       C\r
-             WRITE(CH0,180) RESMN,IMNLA\r
-       180   FORMAT(/,'MINIMUM SUBARC RESOLUTION IS ',E11.3,' ON SUBARC ',I2) \r
-             WRITE(*,*)\r
-             WRITE(*,35) 'MINIMUM SUBARC RESOLUTION:',RESMN\r
-       C\r
-             WRITE(CH0,*)\r
-             IF (.NOT.MAP11 .OR. RESMN.LT.CRRES) THEN\r
-       C\r
-       C****   MESSAGE TO STANDARD OUTPUT\r
-       C\r
-               WRITE(*,185) '*** W A R N I N G  ***'\r
-       185     FORMAT(//,T20,A)\r
+       System.out.println("EVALUATION OF BCF STARTED:");\r
+       Preferences.debug("EVALUATION OF BCF STARTED/n",Preferences.DEBUG_ALGORITHM);\r
+       //LODP=QUPTS+NARCS*NQPTS,\r
+       //LODW=QUWTS+NARCS*NQPTS\r
+       double LODP[] = new double[NQPTS];\r
+       double LODW[] = new double[NQPTS];\r
+       for (I = 0; I < NQPTS; I++) {\r
+               LODP[I] = QUPTS[NARCS*NQPTS + I];\r
+               LODW[I] = QUWTS[NARCS*NQPTS + I];\r
+       }\r
+       /*DIAGN4(CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,ICRVS,IER,\r
+            IPRVS,NASYM,NCRVS,NINFD,NPRVS,NZERD,ARCLN,ASYMP,BCDMN,CORXX,\r
+            TOTLN,VTARG,MAP11,DGPOL,JATYP,LOSUB,\r
+            NARCS,NQPTS,NXINT,PARNT,TNSUA,AICOF,\r
+            ACOEF,BICOF,BCFSN,BCOEF,H0VAL,\r
+            HIVAL,HALEN,JACIN,MIDPT,SOLUN,\r
+            LODP,LODW);\r
+             for (I = 0; I < NQPTS; I++) {\r
+                       QUPTS[NARCS*NQPTS + I] = LODP[I];\r
+                       QUWTS[NARCS*NQPTS + I] = LODW[I];\r
+               }\r
+        System.out.println("EVALUATION OF BCF DONE:");\r
+        Preferences.debug("EVALUATION OF BCF DONE\n",Preferences.DEBUG_ALGORITHM);\r
+       \r
+       if (IER[0] > 0) {\r
+               WRTAIL(5,0,IER[0],null);\r
+           return;\r
+       }\r
+       \r
+       // if (NASYM > 0) {\r
+       // WRITE(CH1,*) DASH\r
+       // DO 10 I=1,NASYM\r
+       // WRITE(CH1,*) NEWD\r
+       // WRITE(CH1,20) ASYMP(I),0E+0\r
+        // WRITE(CH1,20) ASYMP(I),BIG\r
+       // 10      CONTINUE\r
+       //  20      FORMAT(2E16.8)\r
+       // } // if (NASYM > 0)\r
+       // CLOSE(CH1)\r
+       \r
+       // WRITE(CH0,*) DASH\r
+       // DO 30 I=2,NARCS\r
+       // WRITE(CH0,*) NEWD\r
+       // WRITE(CH0,20) CORXX(I),0E+0\r
+       // WRITE(CH0,20) CORXX(I),1E+0\r
+       // 30    CONTINUE\r
+       // CLOSE(CH0)\r
+       System.out.println("DATA FOR PLOTS DONE:");\r
+       Preferences.debug("DATA FOR PLOTS DONE:\n", Preferences.DEBUG_ALGORITHM);\r
+       \r
+       OFLOW=Double.MAX_VALUE;\r
+       MCHEP=EPS;\r
+       UPHYC[0]=MCHEP*CPHCA;\r
+       UCANP[0]=MCHEP*CCAPH;\r
+       System.out.println();\r
+       Preferences.debug("\n", Preferences.DEBUG_ALGORITHM);\r
+       System.out.println("PHYSICAL ROUNDOFF MAGNIFIES TO: " + UPHYC);\r
+       Preferences.debug("PHYSICAL ROUNDOFF MAGNIFIES TO " + UPHYC + "\n", Preferences.DEBUG_ALGORITHM);\r
+       System.out.println("CANONICAL ROUNDOFF MAGNIFIES TO: " + UCANP);\r
+       Preferences.debug("CANONICAL ROUNDOFF MAGNFIES TO " + UCANP + "\n", Preferences.DEBUG_ALGORITHM);\r
+       \r
+       \r
+       // OPEN(CH0,FILE=OFLC)\r
+       \r
+       // WRITE CONFPACK HEADING ON LISTING FILE\r
+       \r
+       WRHEAD(5,0, null);\r
+       \r
+       Preferences.debug("\n", Preferences.DEBUG_ALGORITHM);\r
+       Preferences.debug("   MAP           ESTIMATED EVALUATION   ESTIMATED MAXIMUM \n", Preferences.DEBUG_ALGORITHM);\r
+       \r
+       if (NINFD > 0) {\r
+           CHPC="**";\r
+       }\r
+       else {\r
+            CHPC="  ";\r
+       }\r
+       if (NZERD > 0) {\r
+           CHCP="**";\r
+       }\r
+       else {\r
+           CHCP="  ";\r
+       }\r
+       \r
+       Preferences.debug("PHY --> CAN        " + CPHCA + CHPC +"          " + UPHYC + "\n", Preferences.DEBUG_ALGORITHM);\r
+       Preferences.debug("CAN --> PHY        " + CCAPH + CHCP + "          " + UCANP + "\n", Preferences.DEBUG_ALGORITHM);\r
+       \r
+             \r
+       Preferences.debug("* BASED ON UNIT ROUNDOFF IN DOMAIN OF MAP\n",Preferences.DEBUG_ALGORITHM);\r
+       if (NINFD > 0 || NZERD > 0) {\r
+           Preferences.debug("** CONDITION NUMBER DEPENDS ON UNIT ROUNDOFF,U" + "\n", Preferences.DEBUG_ALGORITHM);\r
+           if (NINFD > 0) {\r
+               Preferences.debug("   PHY --> CAN : CONDTN NO = " + COPHC + "*U**" + EXPHC + "\n",Preferences.DEBUG_ALGORITHM );\r
+           }\r
+           if (NZERD > 0) {\r
+               Preferences.debug("   CAN --> PHY : CONDTN NO = " + COCAP + "*U**" + EXCAP + "\n", Preferences.DEBUG_ALGORITHM);\r
+           } // if (NZERD > 0)\r
+       } // if (NINFD > 0 || NZERD > 0)\r
+       \r
+       \r
+       PI=4E+0*Math.PI;\r
+       Preferences.debug("END PT.   PARENT  ARGUMENT/PI\n");\r
+        for (I=1; I <= TNSUA; I++) {\r
+                Preferences.debug(I + "      " + PARNT[I-1] + "     " + (VTARG[I-1]/PI) + "\n", Preferences.DEBUG_ALGORITHM); \r
+        }\r
+       \r
+        Preferences.debug("SUBARC   % PHYSICAL        % CIRCLE\n",Preferences.DEBUG_ALGORITHM);\r
+        for (I=1; I <= TNSUA; I++) {\r
+            ANGSP=VTARG[I]-VTARG[I-1];\r
+            Preferences.debug(I + "     " + (ARCLN[I-1]/TOTLN) + "    " + (ANGSP/2.0/PI) + "\n", Preferences.DEBUG_ALGORITHM);\r
+        }\r
+   \r
+       \r
+        Preferences.debug("SUB   ACHIEVED    CROWDING\n", Preferences.DEBUG_ALGORITHM);\r
+        Preferences.debug("ARC   RESOLUTION  FACTOR\n", Preferences.DEBUG_ALGORITHM);\r
+        RESMN[0]=OFLOW;\r
+        for (I=1; I <= TNSUA; I++) {\r
+            ANGSP=VTARG[I]-VTARG[I-1];\r
+            if (ANGSP == 0.0) {\r
+                CR=OFLOW;\r
+                LA=0.0;\r
+            }\r
+            else {\r
+                CR=2.0*PI*ARCLN[I-1]/Math.abs(ANGSP)/TOTLN;\r
+                if (ERARC[I-1] == 0.0) {\r
+                    LA=OFLOW;\r
+                }\r
+                else {\r
+                    LA=Math.abs(ANGSP)/(2.0*ERARC[I-1]);\r
+                }\r
+            }\r
+            if (LA < RESMN[0]) {\r
+                RESMN[0]=LA;\r
+                IMNLA=I;\r
+            }\r
+            Preferences.debug(I + " " + LA + " " + CR + "\n", Preferences.DEBUG_ALGORITHM);\r
+        } // for (I=1; I <= TNSUA; I++)\r
+       \r
+       Preferences.debug("MINIMUM SUBARC RESOLUTION IS " + RESMN + " ON SUBARC " + IMNLA + "\n",Preferences.DEBUG_ALGORITHM);\r
+       System.out.println();\r
+       System.out.println("MINIMUM SUBARC RESOLUTION: " + RESMN);\r
+       \r
+       Preferences.debug("\n", Preferences.DEBUG_ALGORITHM);\r
+       if (!MAP11 || RESMN[0] < CRRES) {\r
+\r
+           // MESSAGE TO STANDARD OUTPUT\r
+       \r
+           System.out.println("                   *** W A R N I N G  ***");\r
+           Preferences.debug("                   *** W A R N I N G  ***\n", Preferences.DEBUG_ALGORITHM);\r
                IF (RESMN.LT.CRRES) THEN\r
                  WRITE(*,5) 'THE ABOVE RESOLUTION IS TOO SMALL:'\r
                ENDIF\r
@@ -12913,7 +12921,7 @@ public class SymmsIntegralMapping extends AlgorithmBase  {
                  WRITE(CH0,*) '    DERIVATIVE ARE:'\r
                  WRITE(CH0,'(T10,E9.2)') (BCDMN(J),J=1,NPRVS)\r
                ENDIF\r
-             ENDIF\r
+       } // if (!MAP11 || RESMN < CRRES)\r
              CLOSE(CH0)\r
        999   CONTINUE\r
        C\r
@@ -12924,6 +12932,365 @@ public class SymmsIntegralMapping extends AlgorithmBase  {
        C */\r
     } // private void CNDPLT\r
 \r
+    private void DIAGN4(double CCAPH, double COCAP, double COPHC, double CPHCA, double EXCAP,\r
+        double EXPHC, int ICRVS[], int IER[], int IPRVS[], int NASYM, int NCRVS, int NINFD,\r
+        int NPRVS, int NZERD, double ARCLN[], double ASYMP[], double BCDMN[], double CORXX[],\r
+       double TOTLN, double VTARG[], boolean MAP11[], int DGPOL[], int JATYP[], int LOSUB[],\r
+       int NARCS, int NQPTS, int NXINT, int PARNT[], int TNSUA, double A1COF[], double ACOEF[],\r
+       double B1COF[], double BCFSN[], double BCOEF[], double H0VAL[], double H1VAL[],\r
+       double HALEN[], double JACIN[], double MIDPT[], double SOLUN[], double QUPTS[],\r
+       double QUWTS[]) {\r
+       // INTEGER IER,NARCS,NASYM,NCRVS,NINFD,NPRVS,NQPTS,NXINT,NZERD,OUCH0,\r
+       // +OUCH1,TNSUA\r
+       // INTEGER DGPOL(*),ICRVS(*),IPRVS(*),JATYP(*),LOSUB(*),PARNT(*)\r
+       // REAL CCAPH,COCAP,COPHC,CPHCA,EXCAP,EXPHC,TOTLN\r
+       // REAL A1COF(*),ACOEF(*),ARCLN(*),ASYMP(*),B1COF(*),\r
+       // +BCDMN(*),BCFSN(*),BCOEF(*),CORXX(*),JACIN(*),MIDPT(*),H0VAL(*),\r
+       // +H1VAL(*),HALEN(*),SOLUN(*),VTARG(*),QUPTS(*),QUWTS(*)\r
+       // LOGICAL MAP11\r
+       /*C\r
+       C     IER=0  - NORMAL EXIT\r
+       C     IER=50 - LOCAL PARAMETER MXCOF MUST BE >= NQPTS.\r
+       C     IER=51 - NON-ANALYTIC ARC DETECTED\r
+       C\r
+       C**** LOCAL VARIABLES\r
+       C\r
+             INTEGER AJT,DG,I,I1,IA,JT,K,LOD,LOM,MININ,MXCOF,NINTS,PT,QP\r
+             REAL AL,ATOL,BT,CC,COF,D,DSDT,H0,HH,HL,JACSUM,MD,MCHEP,MPT,\r
+            +PHI,R1MACH,RTOL,SEND,SINC,SJT,SS,SUM,TERM,TINC,TT,TUPI,X,XX,YMAX,\r
+            +YMIN,YY\r
+             COMPLEX PARFUN,T1,T2\r
+             COMMON /DSDTDA/PT,MD,HL\r
+             PARAMETER (MININ=20,MXCOF=32,QP=4)\r
+             REAL JACOF(MXCOF)\r
+             EXTERNAL DSDT,JACSUM,PARFUN,R1MACH\r
+       C\r
+       C     INITIALISE SOME CONSTANTS\r
+       C\r
+             TUPI=8E+0*ATAN(1E+0)\r
+             MCHEP=R1MACH(4)\r
+             RTOL=1E+1*MCHEP\r
+             ATOL=1E+2*MCHEP\r
+             NCRVS=0\r
+             NPRVS=0\r
+             CCAPH=0E+0\r
+             CPHCA=0E+0\r
+             MAP11=.TRUE.\r
+             YMAX=R1MACH(2)\r
+             NASYM=0\r
+       C\r
+       C     START TO COMPUTE THE ARC LENGTHS OF EACH SUBARC (ARCLN) AND THE  \r
+       C     TOTAL LENGTH (TOTLN) OF THE BOUNDARY\r
+       C\r
+             TOTLN=0E+0\r
+             DO 10 IA=1,TNSUA\r
+               PT=PARNT(IA)\r
+               MD=MIDPT(IA)\r
+               HL=HALEN(IA)\r
+               T1=CMPLX(MD+HL)\r
+               T2=CMPLX(MD-HL)\r
+       C\r
+       C****   COMPOSITE QP-PANEL GAUSS-LEGENDRE ESTIMATE FOR ARCLN(IA)\r
+       C\r
+               HH=1E+0/QP\r
+               SUM=0E+0\r
+               DO 6 K=1,QP\r
+                 MPT=-1E+0+(2E+0*K-1E+0)*HH\r
+                 DO 3 I=1,NQPTS\r
+                   X=MPT+HH*QUPTS(I)\r
+                   SUM=SUM+QUWTS(I)*DSDT(X)\r
+       3         CONTINUE\r
+       6       CONTINUE\r
+               ARCLN(IA)=HH*SUM\r
+               TOTLN=TOTLN+ARCLN(IA)\r
+       10    CONTINUE\r
+       C\r
+       C     TEST FOR COMPLETE REVERSAL OF DIRECTION OF A BOUNDARY SUBARC ON \r
+       C     THE UNIT DISC.\r
+       C\r
+             DO 20 IA=1,TNSUA\r
+               IF (VTARG(IA+1) .LT. VTARG(IA)) THEN\r
+                 NCRVS=NCRVS+1\r
+                 ICRVS(NCRVS)=IA\r
+                 MAP11=.FALSE.\r
+               ENDIF\r
+       20    CONTINUE\r
+       C\r
+       C     COMPUTE THE NUMBERS *NINFD* (*NZERD*) OF POINTS WHERE THE \r
+       C     DERIVATIVE OF THE MAP PHYSICAL --> CANONICAL IS RESPECTIVELY\r
+       C     INFINITE (ZERO).     \r
+       C\r
+             NINFD=0\r
+             NZERD=0\r
+             DO 25 I=1,NARCS\r
+               IF (JACIN(I) .LT. 0E+0) THEN\r
+                 NINFD=NINFD+1\r
+               ELSE IF (JACIN(I) .GT. 0E+0) THEN\r
+                 NZERD=NZERD+1\r
+               ENDIF\r
+       25    CONTINUE\r
+       C\r
+       C     NOW START TO EVALUATE THE DIMENSIONLESS BOUNDARY CORRESPONDENCE\r
+       C     DERIVATIVE AT SELECTED VALUES OF DIMENSIONLESS ARC LENGTH;\r
+       C     OUTPUT RESULTS FOR SUBSEQUENT GRAPH PLOTTING IF REQUIRED AND\r
+       C     TEST FOR SIGN CHANGES IN THIS DERIVATIVE.\r
+       C\r
+             SS=0E+0\r
+             SEND=0E+0\r
+             DO 60 IA=1,TNSUA\r
+               NINTS=MAX(MININ,NINT(ARCLN(IA)*NXINT/TOTLN))\r
+               TINC=2E+0/NINTS\r
+               DG=DGPOL(IA)\r
+               IF (DG+1 .GT. MXCOF) THEN\r
+                 IER=50\r
+                 RETURN\r
+               ENDIF\r
+               JT=JATYP(IA)\r
+               AJT=ABS(JT)\r
+               H0=H0VAL(AJT)\r
+               BT=JACIN(AJT)\r
+               AL=1E+0/(1E+0+BT)\r
+               PT=PARNT(IA)\r
+               MD=MIDPT(IA)\r
+               HL=HALEN(IA)\r
+               LOM=LOSUB(IA)\r
+               LOD=(AJT-1)*NQPTS+1 \r
+               IF (JT.GT.0) THEN\r
+                 CC=VTARG(IA)-VTARG(1)\r
+               ELSE\r
+                 CC=VTARG(IA+1)-VTARG(1)\r
+               ENDIF\r
+               DO 30 I=1,DG+1\r
+                 I1=I+LOM-1\r
+                 JACOF(I)=SOLUN(I1)\r
+       30      CONTINUE\r
+               SJT=SIGN(1E+0,REAL(JT))\r
+               DO 40 I=2,DG+1,2\r
+                 JACOF(I)=SJT*JACOF(I)\r
+       40      CONTINUE\r
+               TT=-1E+0\r
+               D=DSDT(TT)\r
+               YMIN=YMAX\r
+               IF (IA .EQ. 1) THEN\r
+                 XX=0E+0  \r
+                 IF (BT .LT. 0E+0) THEN\r
+                   YY=YMAX\r
+                   NASYM=NASYM+1\r
+                   ASYMP(NASYM)=XX\r
+                 ELSE IF (BT .GT. 0E+0) THEN\r
+                   YY=0E+0\r
+                 ELSE\r
+                   PHI=JACSUM(TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)\r
+                   IF (D .EQ. 0E+0) THEN\r
+                     IER=51\r
+                     RETURN \r
+                   ENDIF \r
+                   YY=TOTLN*PHI/D\r
+                 ENDIF\r
+                 IF (NINFD .EQ. 0E+0) THEN\r
+                   CPHCA=TUPI*ABS(YY)/TOTLN\r
+                 ENDIF\r
+                 IF (NZERD .EQ. 0E+0) THEN\r
+                   IF (YY .EQ. 0E+0) THEN\r
+                     CCAPH=YMAX\r
+                   ELSE\r
+                     CCAPH=TOTLN/TUPI/ABS(YY)\r
+                   ENDIF\r
+                 ENDIF\r
+                 WRITE(OUCH1,902) XX,YY\r
+                 YY=0E+0\r
+                 WRITE(OUCH0,902) XX,YY\r
+                 CORXX(1)=0E+0\r
+               ENDIF\r
+       C\r
+       C       ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS FOR INFINITE\r
+       C       DERIVATIVE CASES.\r
+       C\r
+               IF (BT .LT. 0E+0) THEN\r
+                 PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),\r
+            +               BCFSN(LOM+1))\r
+                 PHI=BCFSN(LOM)-2E+0*PHI\r
+                 COF=ABS(PHI)/D**(BT+1E+0)\r
+                 TERM=MCHEP**BT*COF\r
+                 IF (TERM .GT. CPHCA) THEN\r
+                   CPHCA=TERM\r
+                   COPHC=COF\r
+                   EXPHC=BT\r
+                 ENDIF\r
+               ENDIF\r
+               IF (BT .GT. 0E+0) THEN\r
+                 PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),\r
+            +               BCFSN(LOM+1))\r
+                 PHI=BCFSN(LOM)-2E+0*PHI\r
+                 IF (ABS(PHI) .EQ. 0E+0) THEN\r
+                   CCAPH=YMAX\r
+                   COCAP=YMAX\r
+                   EXCAP=AL-1E+0\r
+                 ELSE\r
+                   COF=D/ABS(PHI)**AL\r
+                   TERM=MCHEP**(AL-1E+0)*COF\r
+                   IF (TERM .GT. CCAPH) THEN\r
+                     CCAPH=TERM\r
+                     COCAP=COF\r
+                     EXCAP=AL-1E+0\r
+                   ENDIF\r
+                 ENDIF\r
+               ENDIF\r
+       C\r
+       C       "DO 50" LOOP FOR POINTS INTERIOR TO ARC NUMBER IA\r
+       C\r
+               DO 50 I=1,NINTS-1\r
+                 TT=TT+TINC\r
+       C\r
+       C****     ARC LENGTH INCREASE BY GAUSS-LEGENDRE\r
+       C\r
+                 SUM=0E+0\r
+                 DO 45 K=1,NQPTS\r
+                   X=TT+5E-1*TINC*(QUPTS(K)-1E+0)\r
+                   SUM=SUM+QUWTS(K)*DSDT(X)\r
+       45        CONTINUE\r
+                 SINC=5E-1*TINC*SUM\r
+                 SS=SS+SINC\r
+                 XX=SS/TOTLN\r
+       C\r
+       C         EVALUATE DIMENSIONLESS BCF DERIVATIVE *YY*\r
+       C\r
+                 PHI=JACSUM(SJT*TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)\r
+                 D=DSDT(TT)\r
+                 IF (D .EQ. 0E+0) THEN\r
+                   IER=51\r
+                   RETURN \r
+                 ENDIF \r
+                 YY=TOTLN*(1E+0+SJT*TT)**BT*PHI/D\r
+                 WRITE(OUCH1,902) XX,YY\r
+                 YMIN=MIN(YY,YMIN)\r
+       C\r
+       C         ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS FOR FINITE\r
+       C         DERIVATIVE CASES.\r
+       C\r
+                 IF (NINFD .EQ. 0E+0) THEN\r
+                   CPHCA=MAX(CPHCA,TUPI*ABS(YY)/TOTLN)\r
+                 ENDIF\r
+                 IF (NZERD .EQ. 0E+0) THEN\r
+                   IF (YY .EQ. 0E+0) THEN\r
+                     CCAPH=YMAX\r
+                   ELSE\r
+                     CCAPH=MAX(CCAPH,TOTLN/TUPI/ABS(YY))\r
+                   ENDIF\r
+                 ENDIF\r
+       C\r
+       C         EVALUATE DIMENSIONLESS BCF *YY*\r
+       C\r
+                 PHI=JACSUM(SJT*TT,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),\r
+            +               BCFSN(LOM+1))\r
+                 PHI=BCFSN(LOM)-(1E+0-SJT*TT)*PHI\r
+                 YY=(CC+SJT*(1E+0+SJT*TT)**(1E+0+BT)*PHI)/TUPI\r
+                 WRITE(OUCH0,902) XX,YY\r
+       50      CONTINUE\r
+       C\r
+       C       NEXT TAKE END POINT OF ARC NUMBER IA\r
+       C\r
+               TT=1E+0\r
+               D=DSDT(TT)\r
+               SEND=SEND+ARCLN(IA)\r
+               SS=SEND\r
+               XX=SS/TOTLN\r
+       C\r
+       C       EVALUATE DIMENSIONLESS BCF DERIVATIVE *YY*\r
+       C\r
+               IF (JT .LT. 0E+0) THEN\r
+                   IF (BT .LT. 0E+0) THEN\r
+                     YY=YMAX\r
+                     NASYM=NASYM+1\r
+                     ASYMP(NASYM)=XX\r
+                   ELSE IF (BT .GT. 0E+0) THEN\r
+                     YY=0E+0\r
+                   ELSE\r
+                     PHI=JACSUM(SJT*TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)\r
+                     IF (D .EQ. 0E+0) THEN\r
+                       IER=51\r
+                       RETURN \r
+                     ENDIF \r
+                     YY=TOTLN*PHI/D\r
+                   ENDIF\r
+               ELSE\r
+                   PHI=JACSUM(TT,DG,ACOEF(LOD),BCOEF(LOD),H0,JACOF)\r
+                   IF (D .EQ. 0E+0) THEN\r
+                     IER=51\r
+                     RETURN \r
+                   ENDIF \r
+                   YY=TOTLN*2E+0**BT*PHI/D\r
+               ENDIF\r
+               WRITE(OUCH1,902) XX,YY\r
+               YMIN=MIN(YY,YMIN)\r
+               IF (YMIN.LT.0E+0 .AND. (VTARG(IA+1) .GE. VTARG(IA))) THEN\r
+                 NPRVS=NPRVS+1\r
+                 IPRVS(NPRVS)=IA\r
+                 BCDMN(NPRVS)=YMIN\r
+                 MAP11=.FALSE.\r
+               ENDIF\r
+       C\r
+       C       ESTIMATE FUNCTION EVALUATION CONDITION NUMBERS\r
+       C\r
+               IF (NINFD .EQ. 0E+0) THEN\r
+                 CPHCA=MAX(CPHCA,TUPI*ABS(YY)/TOTLN)\r
+               ENDIF\r
+               IF (NZERD .EQ. 0E+0) THEN\r
+                 IF (YY .EQ. 0E+0) THEN\r
+                   CCAPH=YMAX\r
+                 ELSE\r
+                   CCAPH=MAX(CCAPH,TOTLN/TUPI/ABS(YY))\r
+                 ENDIF\r
+               ENDIF\r
+               IF (BT .LT. 0E+0) THEN\r
+                 PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),\r
+            +               BCFSN(LOM+1))\r
+                 PHI=BCFSN(LOM)-2E+0*PHI\r
+                 COF=ABS(PHI)/D**(BT+1E+0)\r
+                 TERM=MCHEP**BT*COF\r
+                 IF (TERM .GT. CPHCA) THEN\r
+                   CPHCA=TERM\r
+                   COPHC=COF\r
+                   EXPHC=BT\r
+                 ENDIF\r
+               ENDIF\r
+               IF (BT .GT. 0E+0) THEN\r
+                 PHI=JACSUM(-1E+0,DG-1,A1COF(LOD),B1COF(LOD),H1VAL(AJT),\r
+            +               BCFSN(LOM+1))\r
+                 PHI=BCFSN(LOM)-2E+0*PHI\r
+                 IF (ABS(PHI) .EQ. 0E+0) THEN\r
+                   CCAPH=YMAX\r
+                   COCAP=YMAX\r
+                   EXCAP=AL-1E+0\r
+                 ELSE\r
+                   COF=D/ABS(PHI)**AL\r
+                   TERM=MCHEP**(AL-1E+0)*COF\r
+                   IF (TERM .GT. CCAPH) THEN\r
+                     CCAPH=TERM\r
+                     COCAP=COF\r
+                     EXCAP=AL-1E+0\r
+                   ENDIF\r
+                 ENDIF\r
+               ENDIF\r
+       C\r
+       C       EVALUATE DIMENSIONLESS BCF *YY*\r
+       C\r
+               YY=(VTARG(IA+1)-VTARG(1))/TUPI\r
+               WRITE(OUCH0,902) XX,YY\r
+               IF (JT.LT.0) THEN\r
+                 CORXX(PT+1)=XX\r
+               ENDIF\r
+       C\r
+       60    CONTINUE\r
+       C          \r
+       901   FORMAT(2E16.8,1X,A3)\r
+       902   FORMAT(2E16.8)\r
+       C\r
+       C     NORMAL EXIT\r
+       C\r
+             IER=0\r
+       C */\r
+    } // private void DIAGN4\r
 \r
       /**\r
        * zabs computes the absolute value or magnitude of a double precision complex variable zr + j*zi.\r