C ALGORITHM 789, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 25,NO. 1, March, 1999, P. 58-- 69. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Doc/ # Doc/EXTRAS/ # Doc/EXTRAS/drived.f # Doc/EXTRAS/makepqwd.f # Doc/EXTRAS/sleign2.doc # Doc/EXTRAS/sleign2.hlp # Doc/EXTRAS/sleign2.txt # Doc/EXTRAS/sleign2d.f # Doc/EXTRAS/sleign2x.tex # Doc/EXTRAS/xamplesd.f # Doc/bsample.lnk # Doc/bstandrd.lnk # Doc/d02kef.doc # Doc/d02kef.lnk # Doc/evsimp.lnk # Doc/filelist # Doc/librarie.dir # Doc/marcomod.lnk # Doc/nagf90.mk # Doc/read.me # Doc/salftn90.mk # Doc/sample.lnk # Doc/slattrib.bat # Doc/sledgemd.lnk # Doc/sleig2md.lnk # Doc/sleignmd.lnk # Doc/slpkzip.bat # Doc/slsetup.bat # Doc/sltar.bat # Doc/standard.lnk # Doc/standard\sledge48.m # Src/ # Src/Fortran90/ # Src/Fortran90/Dp/ # Src/Fortran90/Dp/d02kef/ # Src/Fortran90/Dp/d02kef/d02kef.f # Src/Fortran90/Dp/marcopak/ # Src/Fortran90/Dp/marcopak/marcomod.f # Src/Fortran90/Dp/probsets/ # Src/Fortran90/Dp/probsets/sample.f # Src/Fortran90/Dp/probsets/standard.f # Src/Fortran90/Dp/sldriver/ # Src/Fortran90/Dp/sldriver/batchio.f # Src/Fortran90/Dp/sldriver/dbmod.f # Src/Fortran90/Dp/sldriver/errflags.hlp # Src/Fortran90/Dp/sldriver/evsimp.f # Src/Fortran90/Dp/sldriver/initpuff.hlp # Src/Fortran90/Dp/sldriver/playback.dat # Src/Fortran90/Dp/sldriver/safeio.f # Src/Fortran90/Dp/sldriver/sample.lst # Src/Fortran90/Dp/sldriver/samplrun.dat # Src/Fortran90/Dp/sldriver/samplrun.out # Src/Fortran90/Dp/sldriver/slbrows.hlp # Src/Fortran90/Dp/sldriver/slconsts.f # Src/Fortran90/Dp/sldriver/sld02k.hlp # Src/Fortran90/Dp/sldriver/sldriver.f # Src/Fortran90/Dp/sldriver/slhelp0.hlp # Src/Fortran90/Dp/sldriver/slpset.f # Src/Fortran90/Dp/sldriver/sltstpak.f # Src/Fortran90/Dp/sldriver/sltstvar.f # Src/Fortran90/Dp/sldriver/slutil.f # Src/Fortran90/Dp/sldriver/solvrs.f # Src/Fortran90/Dp/sldriver/standard.lst # Src/Fortran90/Dp/sldriver/standard/ # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/ # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.01 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.02 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.07 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.15 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.20 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.21 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.22 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.28 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.29 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.35 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.36 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/eftru.41 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.01 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.02 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.05 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.07 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.15 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.18 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.19 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.20 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.21 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.22 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.23 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.28 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.29 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.30 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.32 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.34 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.35 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.36 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.40 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.41 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/evtru.43 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/sdtru.56 # Src/Fortran90/Dp/sldriver/standard/TRUEVALS/sdtru.57 # Src/Fortran90/Dp/sledge/ # Src/Fortran90/Dp/sledge/sledgemd.f # Src/Fortran90/Dp/sleign/ # Src/Fortran90/Dp/sleign/sleignmd.f # Src/Fortran90/Dp/sleign2/ # Src/Fortran90/Dp/sleign2/sleig2md.f # This archive created: Fri Oct 22 10:00:04 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Doc' then mkdir 'Doc' fi cd 'Doc' if test ! -d 'EXTRAS' then mkdir 'EXTRAS' fi cd 'EXTRAS' if test -f 'drived.f' then echo shar: will not over-write existing file "'drived.f'" else cat << SHAR_EOF > 'drived.f' PROGRAM DRIVE C C ********** C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C ********** C This program solves the boundary value problem defined by C the differential equation C C -(py')' + q*y = lambda*w*y C C and appropriate boundary conditions. If the problem is regular, C the boundary conditions can be of periodic type. C C Program usage is facilitated by a large HELP subroutine. C C ********** C .. Scalars in Common .. INTEGER IND,MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,CC,DTHDAA,DTHDBB,EPSMIN,HPI,PI,THETU,THETV, 1 TMID,TWOPI,UB,UL,UR,VB,VL,VR,Z C .. C .. Local Scalars .. INTEGER I,I1,I2,IFLAG,INTAB,NANS,NEND,NIVP,NUMEIG,NUMEIG1,NUMEIG2 LOGICAL REGA,REGB,EIGV,PEIGF,PERIOD,RITE,SINGA,SINGB, 1 SKIPB,WREGA,WREGB,YEH CHARACTER*1 ANSCH,HQ,YN CHARACTER*9 INFM,INFP CHARACTER*19 FILLA,FILLB CHARACTER*32 CHA,CHB,CHANS,CH1,CH2,CH3,CH4,CH5,CH6,FMT,TAPE2 CHARACTER*70 CHTXT DOUBLE PRECISION A,ALFA,ALFA1,ALFA2,A1,A2,B,BETA,BETA1,BETA2, 1 B1,B2,CIRCLA,CIRCLB,EIG,OSCILA,OSCILB,P0ATA,P0ATB, 2 QFATA,QFATB,SINGATA,SINGATB,THA,THB,TOL,TOLL C .. C .. Local Arrays .. INTEGER ICOL(2),IIS(50) CHARACTER*2 COL(32) CHARACTER*39 BLNK(2),STAR(2),STR(2) DOUBLE PRECISION EES(50),SLFN(9),TTS(50) C .. C .. External Subroutines .. EXTERNAL DRAW,EXAMP,HELP,LSTDIR,SLEIGN2,PERIO C .. C .. External Functions .. CHARACTER*32 FMT2 EXTERNAL FMT2 C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,ATAN2,MIN,MOD C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ COMMON /THET/THETU,THETV C .. DATA COL/'01','02','03','04','05','06','07','08','09','10','11', 1 '12','13','14','15','16','17','18','19','20','21','22', 2 '23','24','25','26','27','28','29','30','31','32'/ C CALL EXAMP() C WRITE(*,*) WRITE(*,*) ' This program solves the boundary value problem ' WRITE(*,*) ' defined by the differential equation ' WRITE(*,*) WRITE(*,*) ' -(py'')'' + q*y = lambda*w*y ' WRITE(*,*) WRITE(*,*) ' together with appropriate boundary conditions. ' WRITE(*,*) WRITE(*,*) ' HELP may be called at any point where the program ' WRITE(*,*) ' halts and displays (h?) by pressing "h ". ' WRITE(*,*) ' To RETURN from HELP, press "r ". ' WRITE(*,*) ' To QUIT at any program halt, press "q ". ' WRITE(*,*) ' WOULD YOU LIKE AN OVERVIEW OF HELP ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H' .OR. HQ.EQ.'y' .OR. HQ.EQ.'Y') 1 CALL HELP(1) WRITE(*,*) WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON THE RANGE OF ' WRITE(*,*) ' BOUNDARY CONDITIONS AVAILABLE ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H' .OR. HQ.EQ.'y' .OR. HQ.EQ.'Y') 1 CALL HELP(7) 10 CONTINUE WRITE(*,*) ' DO YOU WANT A RECORD KEPT OF THE PROBLEMS ' WRITE(*,*) ' AND RESULTS ? (Y/N) (h?) ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(8) GO TO 10 END IF READ(CHANS,9020) YN RITE = YN.EQ.'y' .OR. YN.EQ.'Y' .OR. YN.EQ.'yes' .OR. YN.EQ.'YES' IF (RITE) THEN 20 CONTINUE WRITE(*,*) ' SPECIFY NAME OF THE OUTPUT RECORD FILE: (h?) ' READ(*,9010) CHANS IF (CHANS.EQ.'q' .OR. CHANS.EQ.'Q') THEN GO TO 460 ELSE IF (CHANS.EQ.'h' .OR. CHANS.EQ.'H') THEN CALL HELP(8) GO TO 20 ELSE TAPE2 = CHANS WRITE(*,*) ' ENTER SOME HEADER LINE (<=70 CHARACTERS): ' WRITE(*,*) READ(*,9030) CHTXT END IF C OPEN(2,FILE=TAPE2,STATUS='NEW') C WRITE(2,*) ' ',TAPE2 WRITE(2,*) WRITE(2,*) CHTXT WRITE(2,*) END IF C OPEN(21,FILE='test.out') C C DEFINITIONS OF SOME STRINGS. C INFP = '+INFINITY' INFM = '-INFINITY' CH1 = 'REGULAR * ' CH2 = 'WEAKLY REGULAR * ' CH3 = 'LIMIT CIRCLE, NON-OSCILLATORY * ' CH4 = 'LIMIT CIRCLE, OSCILLATORY * ' CH5 = 'LIMIT POINT * ' CH6 = 'UNSPEC.(NOT LCO), DEFAULT B.C.* ' STAR(1) = ' **************************************' STAR(2) = '***************************************' BLNK(1) = ' * ' BLNK(2) = ' *' FILLA = '*******************' FILLB = ' *' C 30 CONTINUE SKIPB = .FALSE. C 40 CONTINUE WRITE(*,*) ' ************************************************** ' WRITE(*,*) ' * INDICATE THE KIND OF PROBLEM INTERVAL (a,b): * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (CHECK THAT THE COEFFICIENTS p,q,w ARE WELL * ' WRITE(*,*) ' * DEFINED THROUGHOUT THE INTERVAL open(a,b).) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) FINITE, (a,b) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SEMI-INFINITE, (a,+INFINITY) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) SEMI-INFINITE, (-INFINITY,b) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) DOUBLY INFINITE, (-INFINITY,+INFINITY) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ************************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(9) GO TO 40 END IF READ(CHANS,'(I32)') INTAB IF (RITE) THEN IF (INTAB.EQ.1) WRITE(2,*) ' The interval is (a,b) .' IF (INTAB.EQ.2) WRITE(2,*) ' The interval is (a,+inf).' IF (INTAB.EQ.3) WRITE(2,*) ' The interval is (-inf,b). ' IF (INTAB.EQ.4) WRITE(2,*) ' The interval is (-inf,+inf).' END IF IF (INTAB.LT.1 .OR. INTAB.GT.4) GO TO 40 C 50 CONTINUE WRITE(*,*) P0ATA = -1.0D0 QFATA = 1.0D0 SINGATA = -1.0D0 CIRCLA = -1.0D0 OSCILA = -1.0D0 REGA = .FALSE. WREGA = .FALSE. SINGA = .FALSE. C IF (INTAB.EQ.1 .OR. INTAB.EQ.2) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 60 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT a: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' a = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(10) GO TO 60 END IF READ(CHANS,'(F32.0)') A IF (RITE) WRITE(2,*) ' a = ',A IF (INTAB.EQ.2) B = A + 1.0D0 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 70 CONTINUE STR(1) = ' * IS THIS PROBLEM: ' STR(2) = ' *' WRITE(*,9110) STAR WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (1) REGULAR AT a ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS p, q, & w' STR(2) = ' ARE BOUNDED CONTINUOUS NEAR a; *' WRITE(*,9110) STR STR(1) = ' * p & w ARE POSITIVE AT a.) ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (2) WEAKLY REGULAR AT a ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS 1/p, q, &' STR(2) = ' w ALL ARE FINITELY INTEGRABLE ON *' WRITE(*,9110) STR STR(1) = ' * SOME INTERVAL [a,a+e] FOR e >' STR(2) = ' 0; p & w ARE POSITIVE NEAR a.) *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (3) LIMIT CIRCLE, NON-OSCILLATORY ' STR(2) = 'AT a ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (4) LIMIT CIRCLE, OSCILLATORY AT a' STR(2) = ' ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (5) LIMIT POINT AT a ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (6) NOT SPECIFIED (BUT NOT LIMIT C' STR(2) = 'IRCLE OSCILLATORY) WITH DEFAULT *' WRITE(*,9110) STR STR(1) = ' * BOUNDARY CONDITION AT a ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * ENTER THE NUMBER OF YOUR CHOICE: (h)' STR(2) = '? *' WRITE(*,9110) STR WRITE(*,9110) STAR WRITE(*,*) C C SPECIFY TYPE OF BOUNDARY CONDITION AT a. C READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 70 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.6) GO TO 70 C C SET CHARACTER STRING CHA ACCORDING TO BOUNDARY CONDITION AT a. C IF (NANS.EQ.1) THEN REGA = .TRUE. CHA = CH1 IF (RITE) WRITE(2,*) ' Endpoint a is Regular. ' ELSE IF (NANS.EQ.2) THEN WREGA = .TRUE. CHA = CH2 IF (RITE) WRITE(2,*) ' Endpoint a is Weakly Regular. ' ELSE IF (NANS.EQ.3) THEN CIRCLA = 1.0D0 CHA = CH3 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Circle,', 1 ' Non-Oscillatory. ' ELSE IF (NANS.EQ.4) THEN CIRCLA = 1.0D0 OSCILA = 1.0D0 CHA = CH4 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Circle,', 1 ' Oscillatory. ' ELSE IF (NANS.EQ.5) THEN CHA = CH5 IF (RITE) WRITE(2,*) ' Endpoint a is Limit Point. ' ELSE CHA = CH6 IF (RITE) WRITE(2,*) ' Endpoint a is Singular, unspecified. ' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C IF (.NOT.REGA .AND. INTAB.LE.2) THEN 80 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * IS p = 0. AT a ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 80 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 80 IF (YEH) P0ATA = 1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' p is zero at a. ' ELSE WRITE(2,*) ' p is not zero at a. ' END IF END IF 90 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * ARE THE COEFFICIENT FUNCTIONS q & w * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * FINITE AT THE ENDPOINT a ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 90 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 90 IF (.NOT.YEH) QFATA = -1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' q and w are both finite at a. ' ELSE WRITE(2,*) ' q and w are not both finite at a. ' END IF END IF IF (P0ATA.LT.0.0D0 .AND. QFATA.GT.0.0D0) THEN IF (RITE) 1 WRITE(2,*) 'This problem appears to be Regular at a.' WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * THIS PROBLEM APPEARS TO BE REGULAR AT a. * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) CHA = CH1 END IF END IF SINGA = .NOT.(REGA .OR. WREGA) IF (SINGA) SINGATA = 1.0D0 IF (SKIPB) GO TO 150 C 100 CONTINUE WRITE(*,*) P0ATB = -1.0D0 QFATB = 1.0D0 SINGATB = -1.0D0 CIRCLB = -1.0D0 OSCILB = -1.0D0 REGB = .FALSE. WREGB = .FALSE. SINGB = .FALSE. C IF (INTAB.EQ.1 .OR. INTAB.EQ.3) THEN 110 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT b: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' b = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(10) GO TO 110 END IF READ(CHANS,'(F32.0)') B IF (RITE) WRITE(2,*) ' b = ',B IF (INTAB.EQ.3) A = B - 1.0D0 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C 120 CONTINUE STR(1) = ' * IS THIS PROBLEM: ' STR(2) = ' *' WRITE(*,9110) STAR WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (1) REGULAR AT b ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS p, q, & w' STR(2) = ' ARE BOUNDED CONTINUOUS NEAR b; *' WRITE(*,9110) STR STR(1) = ' * p & w ARE POSITIVE AT b.) ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (2) WEAKLY REGULAR AT b ? ' STR(2) = ' *' WRITE(*,9110) STR STR(1) = ' * (I.E., THE FUNCTIONS 1/p, q, &' STR(2) = ' w ALL ARE FINITELY INTEGRABLE ON *' WRITE(*,9110) STR STR(1) = ' * SOME INTERVAL [b-e,b] FOR e >' STR(2) = ' 0; p & w ARE POSITIVE NEAR b.) *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (3) LIMIT CIRCLE, NON-OSCILLATORY ' STR(2) = 'AT b ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (4) LIMIT CIRCLE, OSCILLATORY AT b' STR(2) = ' ? *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (5) LIMIT POINT AT b ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * (6) NOT SPECIFIED (BUT NOT LIMIT C' STR(2) = 'IRCLE OSCILLATORY) WITH DEFAULT *' WRITE(*,9110) STR STR(1) = ' * BOUNDARY CONDITION AT b ? ' STR(2) = ' *' WRITE(*,9110) STR WRITE(*,9110) BLNK STR(1) = ' * ENTER THE NUMBER OF YOUR CHOICE: (h?' STR(2) = ') *' WRITE(*,9110) STR WRITE(*,9110) STAR WRITE(*,*) C C SPECIFY TYPE OF BOUNDARY CONDITION AT b. C READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 120 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.6) GO TO 120 C C SET CHARACTER STRING CHB ACCORDING TO BOUNDARY CONDITION AT b. C WRITE(*,*) IF (NANS.EQ.1) THEN REGB = .TRUE. CHB = CH1 IF (RITE) WRITE(2,*) ' Endpoint b is Regular. ' ELSE IF (NANS.EQ.2) THEN WREGB = .TRUE. CHB = CH2 IF (RITE) WRITE(2,*) ' Endpoint b is Weakly Regular. ' ELSE IF (NANS.EQ.3) THEN CIRCLB = 1.0D0 CHB = CH3 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Circle,', 1 ' Non-Oscillatory. ' ELSE IF (NANS.EQ.4) THEN CIRCLB = 1.0D0 OSCILB = 1.0D0 CHB = CH4 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Circle,', 1 ' Oscillatory. ' ELSE IF (NANS.EQ.5) THEN CHB = CH5 IF (RITE) WRITE(2,*) ' Endpoint b is Limit Point. ' ELSE CHB = CH6 IF (RITE) WRITE(2,*) ' Endpoint b is Singular, unspecified. ' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C IF (.NOT.REGB .AND. (INTAB.EQ.1 .OR. INTAB.EQ.3)) THEN 130 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * IS p = 0. AT b ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 130 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 130 IF (YEH) P0ATB = 1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' p is zero at b. ' ELSE WRITE(2,*) ' p is not zero at b. ' END IF END IF 140 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * ARE THE COEFFICIENT FUNCTIONS q & w * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * FINITE AT THE ENDPOINT b ? (Y/N) (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(11) GO TO 140 END IF READ(CHANS,9020) YN YEH = YN.EQ.'y' .OR. YN.EQ.'Y' IF (.NOT.(YEH .OR. YN.EQ.'n' .OR. YN.EQ.'N')) GO TO 140 IF (.NOT.YEH) QFATB = -1.0D0 IF (RITE) THEN IF (YEH) THEN WRITE(2,*) ' q and w are both finite at b. ' ELSE WRITE(2,*) ' q and w are not both finite at b. ' END IF END IF IF (P0ATB.LT.0.0D0 .AND. QFATB.GT.0.0D0) THEN IF (RITE) 1 WRITE(2,*) 'This problem appears to be Regular at b.' WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * THIS PROBLEM APPEARS TO BE REGULAR AT b. * ' WRITE(*,*) ' ********************************************* ' CHB = CH1 END IF END IF SINGB = .NOT.(REGB .OR. WREGB) IF (SINGB) SINGATB = 1.0D0 150 CONTINUE WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) ' ************************************************ ' WRITE(*,*) ' * THIS PROBLEM IS ON THE INTERVAL * ' WRITE(*,*) ' * * ' IF (INTAB.EQ.1) THEN WRITE(*,9070) A,B WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT a IS ',CHA WRITE(*,*) ' * ',FILLB IF (P0ATA.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATA.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * ENDPOINT b IS ',CHB WRITE(*,*) ' * ',FILLB IF (P0ATB.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATB.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF ELSE IF (INTAB.EQ.2) THEN WRITE(*,9080) A,INFP WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT a IS ',CHA WRITE(*,*) ' * ',FILLB IF (P0ATA.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATA.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT a ',FILLB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * ENDPT +INF IS ',CHB WRITE(*,*) ' * ',FILLB ELSE IF (INTAB.EQ.3) THEN WRITE(*,9090) INFM,B WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT -INF IS ',CHA WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPOINT b IS ',CHB WRITE(*,*) ' * ',FILLB IF (P0ATB.GT.0.0D0) THEN WRITE(*,*) ' * p IS ZERO AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF IF (QFATB.LT.0.0D0) THEN WRITE(*,*) ' * q & w ARE NOT BOUNDED AT b ',FILLB WRITE(*,*) ' * ',FILLB END IF ELSE WRITE(*,9100) INFM,INFP WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT -INF IS ',CHA WRITE(*,*) ' * ',FILLB WRITE(*,*) ' * ENDPT +INF IS ',CHB WRITE(*,*) ' * ',FILLB END IF WRITE(*,*) ' * IS THIS THE PROBLEM YOU WANT ? (Y/N) (h?) * ' WRITE(*,*) ' ************************************************ ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 150 END IF READ(CHANS,9020) YN IF (YN.NE.'y' .AND. YN.NE.'Y') THEN 160 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * DO YOU WANT TO RE-DO * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) ENDPOINT a * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) ENDPOINT b * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) BOTH ENDPOINTS a AND b ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 160 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 160 IF (NANS.EQ.1) THEN SKIPB = .TRUE. IF (RITE) WRITE(2,*) ' Redo endpoint a. ' GO TO 50 ELSE IF (NANS.EQ.2) THEN IF (RITE) WRITE(2,*) ' Redo endpoint b. ' GO TO 100 ELSE IF (RITE) WRITE(2,*) ' Redo both endpoints a and b. ' GO TO 30 END IF END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C AT THIS POINT THE DIFFERENTIAL EQUATION AND THE INTERVAL OF C INTEREST HAVE BEEN DEFINED AND CHARACTERIZED. C 170 CONTINUE IF (RITE) WRITE(2,*) '----------------------------------------' IF (RITE) WRITE(2,*) WRITE(*,*) WRITE(*,*) ' *************************************************' WRITE(*,*) ' * DO YOU WANT TO COMPUTE *' WRITE(*,*) ' * *' WRITE(*,*) ' * (1) AN EIGENVALUE, OR SERIES OF EIGENVALUES *' WRITE(*,*) ' * *' WRITE(*,*) ' * (2) SOLUTION TO AN INITIAL VALUE PROBLEM ? *' WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' *************************************************' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 170 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.2) GO TO 170 EIGV = .TRUE. IF (NANS.EQ.2) THEN EIGV = .FALSE. GO TO 350 END IF C C THIS IS THE ENTRY POINT FOR COMPUTING A NEW EIGENVALUE C OR A SERIES OF EIGENVALUES. C 180 CONTINUE IF ((REGA .OR. WREGA) .AND. (REGB .OR. WREGB)) THEN WRITE(*,*) ' ******************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION PERIODIC ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (I.E., y(b) = c*y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = (1/c)*p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ANSWER (Y/N): (h?) * ' WRITE(*,*) ' ******************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 180 END IF READ(CHANS,9020) YN PERIOD = YN.EQ.'y' .OR. YN.EQ.'Y' END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) IF (PERIOD) GO TO 310 IF (SINGATA.LT.0.0D0) THEN 190 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION AT a * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) THE DIRICHLET CONDITION * ' WRITE(*,*) ' * (I.E., y(a) = 0.0) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) THE NEUMANN CONDITION * ' WRITE(*,*) ' * (I.E., y''(a) = 0.0) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) A MORE GENERAL LINEAR * ' WRITE(*,*) ' * BOUNDARY CONDITION * ' WRITE(*,*) ' * A1*[y(a)] + A2*[py''](a) = 0 ? *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 190 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 190 IF (NANS.EQ.1) THEN A1 = 1.0D0 A2 = 0.0D0 IF (RITE) WRITE(2,*) ' Dirichlet B.C. at a. ' ELSE IF (NANS.EQ.2) THEN A1 = 0.0D0 A2 = 1.0D0 IF (RITE) WRITE(2,*) ' Neumann B.C. at a. ' ELSE 200 CONTINUE WRITE(*,*) ' *************************************** ' WRITE(*,*) ' * CHOOSE A1,A2: (h?) * ' WRITE(*,*) ' *************************************** ' WRITE(*,*) WRITE(*,*) ' A1,A2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 200 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) A1,A2 IF (RITE) WRITE(2,*) ' A1,A2 = ',a1,a2 END IF ELSE IF (CIRCLA.GT.0.0D0) THEN 210 CONTINUE IF (RITE) THEN WRITE(2,*) ' The B.C. at a is ' WRITE(2,*) ' A1*[y,u](a) + A2*[y,v](a) = 0. ' END IF WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * THE BOUNDARY CONDITION AT a IS * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * A1*[y,u](a) + A2*[y,v](a) = 0, * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS A1 AND A2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE A1,A2: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' A1,A2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 210 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) A1,A2 IF (RITE) WRITE(2,*) ' A1,A2 = ',A1,A2 END IF IF (SINGATB.LT.0.0D0) THEN 220 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * IS THE BOUNDARY CONDITION AT b * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) THE DIRICHLET CONDITION * ' WRITE(*,*) ' * (I.E., y(b) = 0.0) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) THE NEUMANN CONDITION * ' WRITE(*,*) ' * (I.E., y''(b) = 0.0) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) A MORE GENERAL LINEAR * ' WRITE(*,*) ' * BOUNDARY CONDITION * ' WRITE(*,*) ' * B1*[y(b)] + B2*[py''](b) = 0 ? *' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 220 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 220 IF (NANS.EQ.1) THEN B1 = 1.0D0 B2 = 0.0D0 IF (RITE) WRITE(2,*) ' Dirichlet B.C. at b. ' ELSE IF (NANS.EQ.2) THEN B1 = 0.0D0 B2 = 1.0D0 IF (RITE) WRITE(2,*) ' Neumann B.C. at b. ' ELSE 230 CONTINUE WRITE(*,*) ' *************************************** ' WRITE(*,*) ' * CHOOSE B1,B2: (h?) * ' WRITE(*,*) ' *************************************** ' WRITE(*,*) WRITE(*,*) ' B1,B2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 230 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) B1,B2 IF (RITE) WRITE(2,*) ' B1,B2 = ',b1,b2 END IF ELSE IF (CIRCLB.GT.0.0D0) THEN 240 CONTINUE IF (RITE) THEN WRITE(2,*) ' The B.C. at b is ' WRITE(2,*) ' B1*[y,u](b) + B2*[y,v](b) = 0. ' END IF WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * THE BOUNDARY CONDITION AT b IS * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * B1*[y,u](b) + B2*[y,v](b) = 0, * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS B1 AND B2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE B1,B2: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' B1,B2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 240 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) B1,B2 IF (RITE) WRITE(2,*) ' B1,B2 = ',B1,B2 END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C THIS IS THE ENTRY POINT FOR COMPUTING AN EIGENVALUE C OR A SERIES OF EIGENVALUES IN THE NON-PERIODIC CASE. C 250 CONTINUE IF (RITE) 1 WRITE(2,*) ' *******************************'//FILLA WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * DO YOU WANT TO COMPUTE * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) A SINGLE EIGENVALUE * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) A SERIES OF EIGENVALUES ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(13) GO TO 250 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.2) GO TO 250 IF (NANS.EQ.1) THEN 260 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT NUMEIG, EIG, TOL: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' NUMEIG,EIG,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(14) GO TO 260 END IF EIG = 0.0D0 TOL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.3) THEN I2 = ICOL(2) - ICOL(1) - 1 FMT = '(I'//COL(I1)//',1X,F'//COL(I2) 1 //'.0,1X,F'//COL(30-I1-I2)//'.0)' READ(CHANS,FMT) NUMEIG,EIG,TOL ELSE IF (I.EQ.2) THEN FMT = '(I'//COL(I1)//',1X,F'//COL(31-I1)//'.0)' READ(CHANS,FMT) NUMEIG,EIG ELSE FMT = '(I'//COL(I1)//')' READ(CHANS,FMT) NUMEIG END IF IF (RITE) WRITE(2,*) ' NUMEIG,EIG,TOL = ',NUMEIG,EIG,TOL WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C I2 = NUMEIG CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,I2,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IFLAG = MIN(IFLAG,4) WRITE(*,*) ' *******************************'//FILLA IF (IFLAG.LE.2) THEN WRITE(*,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG IF (RITE) THEN WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(2,9050) TOL,IFLAG WRITE(2,*) ' *******************************'//FILLA END IF ELSE WRITE(*,9040) NUMEIG,IFLAG IF (RITE) WRITE(2,9040) NUMEIG,IFLAG IF (IFLAG.EQ.3) THEN WRITE(*,9230) I2 WRITE(*,9250) EIG IF (RITE) THEN WRITE(2,9230) I2 WRITE(2,9250) EIG END IF END IF WRITE(*,*) ' *******************************'//FILLA END IF 270 CONTINUE IF (IFLAG.LE.2) THEN WRITE(*,*) ' * '//FILLB WRITE(*,*) ' * PLOT EIGENFUNCTION ? (Y/N) (h?)'// 1 ' *' WRITE(*,*) ' *******************************'//FILLA WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 270 END IF READ(CHANS,9020) YN PEIGF = YN.EQ.'y' .OR. YN.EQ.'Y' IF (PEIGF) GO TO 420 END IF ELSE 280 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT NUMEIG1, NUMEIG2, TOL (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) WRITE(*,*) ' NUMEIG1,NUMEIG2,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(14) GO TO 280 END IF TOLL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.3) THEN I2 = ICOL(2) - ICOL(1) - 1 FMT = '(I'//COL(I1)//',1X,I'//COL(I2) 1 //',1X,F'//COL(30-I1-I2)//'.0)' READ(CHANS,FMT) NUMEIG1,NUMEIG2,TOLL ELSE FMT = '(I'//COL(I1)//',1X,I'//COL(31-I1)//')' READ(CHANS,FMT) NUMEIG1,NUMEIG2 END IF IF (RITE) WRITE(2,*) ' NUMEIG1,NUMEIG2,TOL = ', 1 NUMEIG1,NUMEIG2,TOLL C I = 0 DO 290 NUMEIG = NUMEIG1,NUMEIG2 TOL = TOLL EIG = 0.0D0 I2 = NUMEIG CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,I2,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IFLAG = MIN(IFLAG,4) IF (IFLAG.LE.2) THEN WRITE(*,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG IF (RITE) THEN WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(2,9050) TOL,IFLAG END IF ELSE WRITE(*,9040) NUMEIG,IFLAG IF (RITE) WRITE(2,9040) NUMEIG,IFLAG IF (IFLAG.EQ.3 .AND. NUMEIG.EQ.NUMEIG2) THEN WRITE(*,9230) I2 WRITE(*,9250) EIG IF (RITE) THEN WRITE(2,9230) I2 WRITE(2,9250) EIG END IF END IF END IF I = I + 1 EES(I) = EIG TTS(I) = TOL IIS(I) = IFLAG 290 CONTINUE IF (RITE) 1 WRITE(2,*) ' *******************************'//FILLA WRITE(*,*) I = 0 DO 300 NUMEIG = NUMEIG1,NUMEIG2 I = I + 1 WRITE(*,9060) I+NUMEIG1-1,EES(I),TTS(I),IIS(I) 300 CONTINUE END IF WRITE(*,*) GO TO 430 C C THIS IS THE ENTRY POINT FOR COMPUTING AN EIGENVALUE C IN A PERIODIC TYPE PROBLEM. C 310 CONTINUE WRITE(*,*) ' ******************************************** ' WRITE(*,*) ' * IS THIS PROBLEM: * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) PERIODIC ? * ' WRITE(*,*) ' * (I.E., y(b) = y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SEMI-PERIODIC ? * ' WRITE(*,*) ' * (I.E., y(b) = -y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = -p(a)*y''(a) ) *' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) GENERAL PERIODIC TYPE ? * ' WRITE(*,*) ' * (I.E., y(b) = c*y(a) * ' WRITE(*,*) ' * & p(b)*y''(b) = p(a)*y''(a)/c *' WRITE(*,*) ' * for some number c .NE. 0. ) * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h)? * ' WRITE(*,*) ' ******************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 310 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.3) GO TO 310 IF (NANS.EQ.1) THEN CC = 1.0D0 IF (RITE) WRITE(2,*) ' The B.C. is Periodic. ' ELSE IF (NANS.EQ.2) THEN CC = -1.0D0 IF (RITE) WRITE(2,*) ' The B.C. is Semi-Periodic. ' ELSE 320 CONTINUE WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' * INPUT c: (h?) * ' WRITE(*,*) ' ****************************************** ' WRITE(*,*) ' c = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(7) GO TO 320 END IF READ(CHANS,'(F32.0)') CC IF (RITE) WRITE(2,*) ' The B.C. is General Periodic type. ' IF (RITE) WRITE(2,*) ' Parameter c = ',CC END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 330 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * INPUT NUMEIG,TOL: (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) WRITE(*,*) ' NUMEIG,TOL = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(17) GO TO 330 END IF TOL = 0.0D0 CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 IF (I.EQ.2) THEN FMT = '(I'//COL(I1)//',1X,F'//COL(31-I1)//'.0)' READ(CHANS,FMT) NUMEIG,TOL ELSE FMT = '(I'//COL(I1)//')' READ(CHANS,FMT) NUMEIG END IF IF (RITE) WRITE(2,*) ' NUMEIG,TOL = ',NUMEIG,TOL IF (NUMEIG.LT.0) THEN WRITE(*,*) ' NUMEIG MUST BE .GE. 0 ' GO TO 330 END IF CALL PERIO(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB, 1 A1,A2,B1,B2,NUMEIG,EIG,TOL,IFLAG,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IF (IFLAG.NE.1) IFLAG = 2 WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*)' **************************************************' WRITE(*,*)' * NUMEIG = ',NUMEIG,' EIG =',EIG WRITE(*,9050) TOL,IFLAG WRITE(*,*)' **************************************************' IF (RITE) WRITE(2,*) ' * NUMEIG = ',NUMEIG,' EIG =',EIG IF (RITE) WRITE(2,9050) TOL,IFLAG WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 340 CONTINUE WRITE(*,*) WRITE(*,*) ' *************************************************' WRITE(*,*) ' * PLOT EIGENFUNCTION ? (Y/N) (h?) *' WRITE(*,*) ' *************************************************' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 340 END IF READ(CHANS,9020) YN PEIGF = YN.EQ.'y' .OR. YN.EQ.'Y' IF (PEIGF) THEN THA = ATAN2(VB,CC-UB) IF (THA.LT.0.0D0) THA = THA + PI THB = ATAN(CC*CC*TAN(THA)) IF (THB.LE.0.0D0) THB = THB + PI I = MOD(NUMEIG,2) IF ((CC.GT.0.0D0 .AND. I.EQ.1) .OR. 1 (CC.LT.0.0D0 .AND. I.EQ.0)) NUMEIG = NUMEIG + 1 A1 = COS(THA) A2 = -SIN(THA) B1 = COS(THB) B2 = -SIN(THB) SLFN(1) = 0.0D0 SLFN(2) = -1.0D0 SLFN(3) = THA SLFN(4) = 0.0D0 SLFN(5) = 1.0D0 SLFN(6) = THB SLFN(7) = 0.0D0 SLFN(8) = .00001 SLFN(9) = Z GO TO 420 END IF C C END OF COMPUTING AN EIGENVALUE. C IF (RITE) WRITE(2,*) ' *******************************'//FILLA GO TO 430 C C THIS IS THE ENTRY POINT FOR PLOTTING A NEW INITIAL VALUE PROBLEM. C 350 CONTINUE WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) ' *********************************************** ' WRITE(*,*) ' * DO YOU WANT TO COMPUTE THE SOLUTION TO: * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (1) AN INITIAL VALUE PROBLEM FROM ONE * ' WRITE(*,*) ' * END OF THE INTERVAL TO THE OTHER * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) INITIAL VALUE PROBLEMS FROM BOTH * ' WRITE(*,*) ' * ENDS TO A MIDPOINT ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' *********************************************** ' WRITE(*,*) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 350 END IF READ(CHANS,'(I32)') NIVP IF (NIVP.LT.1 .OR. NIVP.GT.2) GO TO 350 IF (NIVP.EQ.1) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 360 CONTINUE WRITE(*,*) WRITE(*,*) ' ********************************************* ' WRITE(*,*) ' * WHICH IS THE INITIAL POINT: a OR b ? (h?) * ' WRITE(*,*) ' ********************************************* ' WRITE(*,*) WRITE(*,*) ' INITIAL POINT IS ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 360 END IF READ(CHANS,9020) ANSCH IF (ANSCH.EQ.'a' .OR. ANSCH.EQ.'A') THEN NEND = 1 IF (RITE) WRITE(2,*) ' The Initial Point for this', 1 ' Initial Value Problem is a. ' IF (SINGATA.LT.0.0D0 .OR. CIRCLA.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 370 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT a ARE * ' WRITE(*,*) ' * * ' IF (SINGATA.LT.0.0D0) THEN WRITE(*,*) ' * y(a)=alfa1, py''(a)=alfa2 *' ELSE WRITE(*,*) ' * [y,u](a)=alfa1, [y,v](a)=alfa2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS alfa1, alfa2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE alfa1,alfa2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' alfa1,alfa2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 370 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) ALFA1,ALFA2 IF (RITE) WRITE(2,*) ' alfa1,alfa2 = ',ALFA1,ALFA2 A1 = ALFA2 A2 = -ALFA1 END IF ELSE IF (ANSCH.EQ.'b' .OR. ANSCH.EQ.'B') THEN NEND = 2 IF (RITE) WRITE(2,*) ' The Initial Point for this', 1 ' Initial Value Problem is b. ' IF (SINGATB.LT.0.0D0 .OR. CIRCLB.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 380 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT b ARE * ' WRITE(*,*) ' * * ' IF (SINGATB.LT.0.0D0) THEN WRITE(*,*) ' * y(b)=beta1, py''(b)=beta2 *' ELSE WRITE(*,*) ' * [y,u](b)=beta1, [y,v](b)=beta2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS beta1, beta2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE beta1,beta2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' beta1,beta2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 380 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) BETA1,BETA2 IF (RITE) WRITE(2,*) ' beta1,beta2 = ',BETA1,BETA2 B1 = BETA2 B2 = -BETA1 END IF END IF ELSE IF (NIVP.EQ.2) THEN NEND = 3 IF (SINGATA.LT.0.0D0 .OR. CIRCLA.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 390 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT a ARE * ' WRITE(*,*) ' * * ' IF (SINGATA.LT.0.0D0) THEN WRITE(*,*) ' * y(a)=alfa1, py''(a)=alfa2 *' ELSE WRITE(*,*) ' * [y,u](a)=alfa1, [y,v](a)=alfa2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS alfa1, alfa2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE alfa1,alfa2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' alfa1,alfa2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 390 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) ALFA1,ALFA2 A1 = ALFA2 A2 = -ALFA1 END IF IF (SINGATB.LT.0.0D0 .OR. CIRCLB.GT.0.0D0) THEN WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) 400 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************ ' WRITE(*,*) ' * THE INITIAL CONDITIONS AT b ARE * ' WRITE(*,*) ' * * ' IF (SINGATB.LT.0.0D0) THEN WRITE(*,*) ' * y(b)=beta1, py''(b)=beta2 *' ELSE WRITE(*,*) ' * [y,u](b)=beta1, [y,v](b)=beta2 * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * WHERE THE CONSTANTS beta1, beta2 * ' WRITE(*,*) ' * MAY BE CHOSEN ARBITRARILY. * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * CHOOSE beta1,beta2: (h?) * ' WRITE(*,*) ' ************************************ ' WRITE(*,*) WRITE(*,*) ' beta1,beta2 = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 400 END IF CALL LSTDIR(CHANS,I,ICOL) I1 = ICOL(1) - 1 FMT = FMT2(I1) READ(CHANS,FMT) BETA1,BETA2 B1 = BETA2 B2 = -BETA1 END IF END IF WRITE(*,*) WRITE(*,*) WRITE(*,*) WRITE(*,*) C C THIS IS THE ENTRY POINT FOR PLOTTING A SOLUTION OF THE INITIAL C VALUE PROBLEM AFTER THE EIGENPARAMETER HAS BEEN CHOSEN. C 410 CONTINUE WRITE(*,*) WRITE(*,*) ' ************************************************ ' WRITE(*,*) ' * WHAT VALUE SHOULD BE USED FOR THE * ' WRITE(*,*) ' * EIGENPARAMETER, EIG ? * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * INPUT EIG = (h?) * ' WRITE(*,*) ' ************************************************ ' WRITE(*,*) WRITE(*,*) ' EIG = ' READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(12) GO TO 410 END IF READ(CHANS,'(F32.0)') EIG C C THE FOLLOWING CALL SETS THE STAGE IN SLEIGN2 -- I.E., SAMPLES C THE COEFFICIENTS AND SETS THE INITIAL INTERVAL. C NUMEIG = 0 TOL = .001 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,EIG,TOL,IFLAG,-1,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) IF (NIVP.EQ.1 .AND. NEND.EQ.1) TMID = BB IF (NIVP.EQ.1 .AND. NEND.EQ.2) TMID = AA C C ACTUALLY, WE MAY HAVE TO AVOID AA OR BB IN SOME CASES, C WHICH WILL BE TAKEN CARE OF LATER. C ALFA = 0.0D0 IF ((NIVP.EQ.1 .AND. NEND.EQ.1 .AND. .NOT.SINGA) .OR. NIVP.EQ.2) 1 ALFA = SLFN(3) BETA = PI IF ((NIVP.EQ.1 .AND. NEND.EQ.2 .AND. .NOT.SINGB) .OR. NIVP.EQ.2) 1 BETA = SLFN(6) SLFN(3) = ALFA SLFN(6) = BETA SLFN(4) = 0.0D0 SLFN(7) = 0.0D0 SLFN(8) = .01 C C THE FOLLOWING CALL COMPUTES VALUES OF THE SOLUTION FOR PLOTTING. C 420 CONTINUE WRITE(*,*) CALL DRAW(A1,A2,B1,B2,NUMEIG,EIG,SLFN,SINGATA,SINGATB,CIRCLA, 1 CIRCLB,OSCILA,OSCILB,REGA,REGB,NIVP,NEND,EIGV,RITE) WRITE(*,*) C 430 CONTINUE IF (EIGV) THEN WRITE(*,*) ' Press any key to continue. ' READ(*,9010) CHANS 440 CONTINUE CALL CHOICE(1) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 440 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.5) GO TO 440 IF (NANS.EQ.1 .AND. PERIOD) GO TO 330 IF (NANS.EQ.1 .AND. .NOT.PERIOD) GO TO 250 IF (NANS.EQ.2) GO TO 180 IF (NANS.EQ.3) GO TO 30 EIGV = .FALSE. IF (NANS.EQ.4) GO TO 350 GO TO 460 ELSE 450 CONTINUE WRITE(*,*) ' Press any key to continue. ' READ(*,9010) CHANS CALL CHOICE(2) READ(*,9010) CHANS READ(CHANS,9020) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') GO TO 460 IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 450 END IF READ(CHANS,'(I32)') NANS IF (NANS.LT.1 .OR. NANS.GT.5) GO TO 450 IF (NANS.EQ.1) GO TO 410 IF (NANS.EQ.2) GO TO 350 IF (NANS.EQ.3) GO TO 30 EIGV = .TRUE. IF (NANS.EQ.4) GO TO 180 END IF 460 CONTINUE CLOSE(21) CLOSE(2) STOP 9010 FORMAT(A32) 9020 FORMAT(A1) 9030 FORMAT(A70) 9040 FORMAT(1X,' NUMEIG = ',I5,' IFLAG = ',I3) 9050 FORMAT(1X,' * TOL = ',E14.5,2X,' IFLAG = ',I3,' *') 9060 FORMAT(1X,' NUMEIG = ',I5,2X,' EIG = ',E18.9,2X,' TOL = ', 1 E14.5,' IFLAG = ',I3) 9070 FORMAT(1X,1X,6H* (,F12.7,1H,,F12.7,1H),' *') 9080 FORMAT(1X,1X,6H* (,F12.7,1H,,A12 ,1H),' *') 9090 FORMAT(1X,1X,6H* (,A12 ,1H,,F12.7,1H),' *') 9100 FORMAT(1X,1X,6H* (,A12 ,1H,,A12 ,1H),' *') 9110 FORMAT(1X,2A39) 9230 FORMAT(1X,' * THERE SEEMS TO BE NO EIGENVALUE OF INDEX *'/ 1 1X,' * GREATER THAN',I5,' *') 9250 FORMAT(1X,' * THERE MAY BE A CONTINUOUS SPECTRUM BEGINNING *'/ 1 1X,' * AT ABOUT',1PE8.1,' *') END SUBROUTINE CHOICE(I) INTEGER I C ********** C THIS PROGRAM DISPLAYS THE CHOICES FOR PROBLEM CONTINUATION. C ********** WRITE(*,*) ' *********************************************** ' WRITE(*,*) ' * WHAT WOULD YOU LIKE TO DO NOW ? * ' WRITE(*,*) ' * * ' IF (I.EQ.1) THEN WRITE(*,*) ' * (1) SAME EIGENVALUE PROBLEM, DIFFERENT * ' WRITE(*,*) ' * NUMEIG, EIG, OR TOL * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) SAME EIGENVALUE PROBLEM, SAME (a,b) * ' WRITE(*,*) ' * AND p,q,w,u,v BUT DIFFERENT * ' WRITE(*,*) ' * BOUNDARY CONDITIONS A1,A2,B1,B2 * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) INTERVAL CHANGE, PROBLEM RESTART * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) AN INITIAL VALUE PROBLEM * ' ELSE WRITE(*,*) ' * (1) SAME INITIAL VALUE PROBLEM, * ' WRITE(*,*) ' * DIFFERENT LAMBDA * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (2) NEW INITIAL VALUE PROBLEM * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (3) INTERVAL CHANGE, PROBLEM RESTART * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * (4) AN EIGENVALUE PROBLEM * ' END IF WRITE(*,*) ' * * ' WRITE(*,*) ' * (5) QUIT * ' WRITE(*,*) ' * * ' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) * ' WRITE(*,*) ' *********************************************** ' WRITE(*,*) RETURN END SUBROUTINE DRAW(A1,A2,B1,B2, 1 NUMEIG,EIG,SLFN,SINGATA,SINGATB,CIRCLA,CIRCLB, 2 OSCILA,OSCILB,REGA,REGB,NIVP,NEND,EIGV,RITE) INTEGER NUMEIG,NIVP,NEND LOGICAL REGA,REGB,EIGV,RITE DOUBLE PRECISION A1,A2,B1,B2,EIG, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFN(10) C ********** C ********** C .. Scalars in Common .. INTEGER IND,MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,EIGSAV,HPI,PI,TMID,TWOPI C .. C .. Arrays in Common .. INTEGER NT(2) DOUBLE PRECISION TT(7,2),YY(7,3,2) C .. C .. Local Scalars .. INTEGER I,ISLFUN,JJ,K,KFLAG,MM,NF,NPTS,NV LOGICAL ENDA,ENDB,WREGA,WREGB,LCOA,LCOB,LCIRCA,LCIRCB, 1 OSCA,OSCB,SINGA,SINGB CHARACTER*1 HQ,YN CHARACTER*32 CHANS,TAPE DOUBLE PRECISION BRYU,BRYV,CA,CB,DD,EIGPI,FA,FB,FAC,FZ,GEE, 1 HU,HUI,HV,HVI,PHI,PUP,PUPI,PVP,PVPI,PYP,RHO,RHOZ, 2 SIG,SQ,T,THETAZ,TH,TI,TMP,U,UI,V,VI,X,XI,XJMP,XJMPS,Y,Z C .. C .. Local Arrays .. CHARACTER*55 XC(8) DOUBLE PRECISION SLFUN(1000,2),PLOTF(1000,6),XT(1000,2), 1 UTHZ(3),UTH(3) C .. C .. External Subroutines .. EXTERNAL DXDT,EIGENF,HELP,MESH,QPLOT,THZTOTH,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,INT C .. C .. Common blocks .. COMMON /TEMP/TT,YY,NT COMMON /DATAF/EIGSAV,IND COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C Definition of some logicals. C SINGA = SINGATA.GT.0.0D0 WREGA = .NOT.REGA .AND. .NOT.SINGA SINGB = SINGATB.GT.0.0D0 WREGB = .NOT.REGB .AND. .NOT.SINGB LCIRCA = CIRCLA.GT.0.0D0 LCIRCB = CIRCLB.GT.0.0D0 OSCA = OSCILA.GT.0.0D0 LCOA = LCIRCA .AND. OSCA OSCB = OSCILB.GT.0.0D0 LCOB = LCIRCB .AND. OSCB EIGPI = NUMEIG*PI C C Definition of some character strings. C XC(1) = ' * (1) THE SOLUTION Y * ' XC(2) = ' * (2) THE QUASI-DERIVATIVE p*Y'' *' XC(3) = ' * (3) THE BOUNDARY CONDITION FUNCTION Y OR [Y,U] * ' XC(4) = ' * (4) THE BOUNDARY CONDITION FUNCTION p*Y'' OR [Y,V]*' XC(5) = ' * (5) THE PRUFER ANGLE, THETA * ' XC(6) = ' * (6) THE PRUFER MODULUS, RHO * ' XC(7) = ' * (1) x IN THE INTERVAL (a,b) * ' XC(8) = ' * (2) t IN THE INTERVAL (-1,1) * ' C C NV = 1 MEANS THE INDEPENDENT VARIABLE IS X. C NV = 2 MEANS THE INDEPENDENT VARIABLE IS T. C C NF = 1 MEANS THE EIGENFUNCTION Y IS WANTED. C NF = 2 MEANS THE QUASI-DERIVATIVE P*Y' IS WANTED. C NF = 3 MEANS BOUNDARY CONDITION FUNCTION Y OR [Y,U] IS WANTED. C NF = 4 MEANS BOUNDARY CONDITION FUNCTION P*Y' OR [Y,V] IS WANTED. C NF = 5 MEANS THE PRUFER ANGLE THETA IS WANTED. C NF = 6 MEANS THE PRUFER MODULUS RHO IS WANTED. C C IF AN EIGENVALUE HAS BEEN COMPUTED (EIGV = .TRUE.), C THE RELEVANT VALUES HAVE BEEN STORED IN ARRAY SLFN, AND C NEED TO BE COPIED INTO THE FIRST COLUMN OF ARRAY SLFUN. C DO 10 I = 1,9 SLFUN(I,1) = SLFN(I) 10 CONTINUE C CALL MESH(EIG,SLFUN(10,1),ISLFUN) C C THE POINTS GENERATED BY MESH MAY NOT BE WITHIN THE INTERVAL C (AA,BB). WE WANT TO ENSURE THAT WE USE ONLY SUCH POINTS C AS ARE WITHIN THE INTERVAL. C K = 0 DO 20 I = 1,ISLFUN IF (SLFUN(9+I,1).GT.AA .AND. SLFUN(9+I,1).LT.BB) THEN K = K + 1 SLFUN(9+K,1) = SLFUN(9+I,1) END IF 20 CONTINUE ISLFUN = K C C WE ALSO WANT TO BE SURE AN INITIAL ENDPOINT IS AA OR BB UNLESS THE C POINT IS LIMIT CIRCLE, AND THAT THE LAST POINT IS NOT AA OR BB. C IF ((EIGV .OR. NEND.EQ.1 .OR. NIVP.EQ.2) .AND. .NOT.LCIRCA) THEN ISLFUN = ISLFUN + 1 DO 30 I = ISLFUN,2,-1 SLFUN(9+I,1) = SLFUN(8+I,1) 30 CONTINUE SLFUN(9+1,1) = AA END IF IF ((EIGV .OR. NEND.EQ.2 .OR. NIVP.EQ.2) .AND. .NOT.LCIRCB) THEN SLFUN(ISLFUN+10,1) = BB ISLFUN = ISLFUN + 1 END IF C C NEAR AN OSCILLATORY ENDPOINT THE POINTS MAY BE SO CLOSE THAT WE C COULDN'T SEE THE ACTUAL CURVE EVEN IF WE PLOTTED IT. SO WE WANT C TO REMOVE POINTS FROM THAT END UP TO WHERE THEY ARE NOT SO CLOSE. C IF (OSCA) THEN JJ = 0 DO 40 I = 1,ISLFUN IF (ABS(SLFUN(9+I,1)-SLFUN(10+I,1)).LT.0.0D001) JJ = JJ + 1 40 CONTINUE IF (JJ.GT.0) THEN ISLFUN = ISLFUN - JJ DO 50 I = 1,ISLFUN SLFUN(9+I,1) = SLFUN(9+I+JJ,1) 50 CONTINUE END IF END IF IF (OSCB) THEN JJ = 0 DO 60 I = ISLFUN,1,-1 IF (ABS(SLFUN(9+I,1)-SLFUN(8+I,1)).LT.0.0D001) JJ = JJ + 1 60 CONTINUE IF (JJ.GT.0) ISLFUN = ISLFUN - JJ END IF C C FINALLY, IN THE CASE OF AN INITIAL VALUE PROBLEM, C WE CANNOT AFFORD TO INTEGRATE TO THE OTHER END B (OR A) C UNLESS BOTH ENDS ARE REGULAR. C IF (NIVP.EQ.1 .AND. .NOT.(REGA .AND. REGB)) THEN ISLFUN = ISLFUN - 1 IF (NEND.EQ.2) THEN DO 70 I = 1,ISLFUN SLFUN(9+I,1) = SLFUN(10+I,1) 70 CONTINUE END IF END IF C DO 80 I = 1,ISLFUN XT(9+I,2) = SLFUN(9+I,1) 80 CONTINUE C C WARNING: THE VALUES RETURNED IN SLFUN BY EIGENF DEPEND C ON THE VALUE OF KFLAG IN THE CALL TO EIGENF: C C IF KFLAG = 1, THE VALUES IN SLFUN(9+I,1) ARE THE C EIGENFUNCTION Y ITSELF. C C IF KFLAG = 2, THE VALUES IN THE TWO COLUMNS OF SLFUN ARE C SLFUN(9+I,1) = THETA(9+I) C SLFUN(9+I,2) = EFF(9+I) C WHERE C RHO = EXP(EFF) C Y = RHO*SIN(THETA) C P*Y' = RHO*COS(THETA)*Z C C HERE, WE SET KFLAG = 2 SO THAT EIGENF WILL RETURN EFF, ENABLING C US TO DEAL WITH IT BEFORE FORMING THE FUNCTION Y = RHO*SIN . C KFLAG = 2 EIGSAV = EIG CALL EIGENF(EIGPI,A1,A2,B1,B2,REGA,SINGA,LCIRCA,OSCA, 1 REGB,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN,KFLAG) C C IT MAY HAPPEN THAT THETA(I) HAS A JUMP OF MM*PI AT TMID. C IN THIS CASE, WE NEED TO SUBTRACT MM*PI FROM THETA(I). C IF (EIGV) THEN JJ = 0 XJMPS = HPI DO 90 I = 1,ISLFUN-1 XJMP = SLFUN(10+I,1) - SLFUN(9+I,1) IF (ABS(XJMP).GT.XJMPS) THEN XJMPS = ABS(XJMP) JJ = I END IF 90 CONTINUE IF (JJ.NE.0) THEN XJMP = SLFUN(10+JJ,1) - SLFUN(9+JJ,1) MM = INT(XJMP/PI) IF ((SLFUN(10+JJ,1)-MM*PI).LT.SLFUN(9+JJ,1)) MM = MM - 1 DO 100 I = JJ,ISLFUN-1 SLFUN(10+I,1) = SLFUN(10+I,1) - MM*PI 100 CONTINUE END IF END IF C*********************************************************************** C * C SLEIGN2 NORMALIZES THE WAVEFUNCTION TO HAVE L2-NORM 1.0D0, BUT FOR AN C INITIAL VALUE PROBLEM WE WANT TO HAVE THE VALUE (Y) AND SLOPE (P*Y') C (OR [Y,U] AND [Y,V]) AT THE END TO BE THOSE SPECIFIED FOR THE C INITIAL CONDITIONS. SO HERE WE MUST RE-NORMALIZE FOR THIS PURPOSE. C C THE VALUES IN THE ARRAYS TT AND YY COME FROM THE INTEGRATIONS C IN SUBROUTINE WR. C ENDA = (NEND.EQ.1 .OR. NIVP.EQ.2) .AND. (LCIRCA .OR. WREGA) IF (ENDA) THEN NPTS = 7 IF (LCOA) NPTS = NT(1) DO 110 I = 2,NPTS T = TT(I,1) PHI = YY(I,1,1) GEE = YY(I,3,1) SIG = EXP(GEE) IF (LCIRCA) THEN CALL DXDT(T,TMP,X) CALL UV(X,U,PUP,V,PVP,HU,HV) DD = U*PVP - V*PUP SQ = SQRT(A1**2+A2**2) BRYU = -DD*SIN(PHI)*SIG*SQ BRYV = DD*COS(PHI)*SIG*SQ END IF 110 CONTINUE END IF ENDB = (NEND.EQ.2 .OR. NIVP.EQ.2) .AND. (LCIRCB .OR. WREGB) IF (ENDB) THEN NPTS = 7 IF (LCOB) NPTS = NT(2) DO 120 I = 2,NPTS T = TT(I,2) PHI = YY(I,1,2) GEE = YY(I,3,2) SIG = EXP(GEE) IF (LCIRCB) THEN CALL DXDT(T,TMP,X) CALL UV(X,U,PUP,V,PVP,HU,HV) DD = U*PVP - V*PUP SQ = SQRT(B1**2+B2**2) BRYU = -DD*SIN(PHI)*SIG*SQ BRYV = DD*COS(PHI)*SIG*SQ END IF 120 CONTINUE END IF C Z = SLFUN(9,1) ENDA = (NEND.EQ.1 .OR. NIVP.EQ.2) .AND. LCIRCA CA = 0.0D0 IF (.NOT.(EIGV .OR. ENDA) .AND. NEND.NE.2) THEN FA = SLFUN(4,1) CA = 0.5*LOG(A2**2+(A1/Z)**2) - FA END IF ENDB = (NEND.EQ.2 .OR. NIVP.EQ.2) .AND. LCIRCB CB = 0.0D0 IF (.NOT.(EIGV .OR. ENDB) .AND. NEND.NE.1) THEN FB = SLFUN(7,1) CB = 0.5*LOG(B2**2+(B1/Z)**2) - FB END IF C DO 130 I = 1,ISLFUN IF (XT(9+I,2).LE.TMID .AND. .NOT.LCIRCA) THEN SLFUN(9+I,2) = SLFUN(9+I,2) + CA ELSE IF (XT(9+I,2).GT.TMID .AND. .NOT.LCIRCB) THEN SLFUN(9+I,2) = SLFUN(9+I,2) + CB END IF 130 CONTINUE C UTHZ(2) = 0.0D0 UTHZ(3) = 0.0D0 DO 140 I = 1,ISLFUN TI = XT(9+I,2) CALL DXDT(TI,TMP,XI) XT(9+I,1) = XI THETAZ = SLFUN(9+I,1) FZ = SLFUN(9+I,2) RHOZ = EXP(FZ) Y = RHOZ*SIN(THETAZ) PYP = Z*RHOZ*COS(THETAZ) RHO = SQRT(Y**2+PYP**2) PLOTF(9+I,1) = Y PLOTF(9+I,2) = PYP PLOTF(9+I,3) = Y PLOTF(9+I,4) = PYP UTHZ(1) = THETAZ CALL THZTOTH(UTHZ,Z,UTH) TH = UTH(1) PLOTF(9+I,5) = TH PLOTF(9+I,6) = RHO C IF ((ENDA .AND. TI.LE.TMID) .OR. 1 (ENDB .AND .TI.GT.TMID)) THEN CALL UV(XI,UI,PUPI,VI,PVPI,HUI,HVI) DD = UI*PVPI - VI*PUPI BRYU = PUPI*Y - PYP*UI BRYV = PVPI*Y - PYP*VI C C RENORMALIZE. C IF (ENDA .AND. TI.LE.TMID) THEN FAC = SQRT(A1**2+A2**2) ELSE FAC = SQRT(B1**2+B2**2) END IF BRYU = FAC*BRYU BRYV = FAC*BRYV PLOTF(9+I,3) = BRYU PLOTF(9+I,4) = BRYV END IF 140 CONTINUE C C IN THE CASE OF NIVP = 2 WE HAVE COMPUTED THE SOLUTIONS C TO TWO INITIAL VALUE PROBLEMS FROM THE TWO ENDS. C IF (.NOT.ENDA .AND. .NOT.ENDB) WE SHOULD NOW HAVE C C Y(A) = -A2 (ALFA1) ; Y(B) = -B2 (BETA1) C PY'(A) = A1 (ALFA2) ; PY'(B) = B1 (BETA2) C C IT SOMETIMES HAPPENS THAT THE VALUES AT THE FINAL END HAVE GROWN C SO LARGE THAT THE REST OF THE CURVE IS TOTALLY SUBMERGED. C IN SUCH CASES WE WANT TO REMOVE THE POINTS WITH THE LARGE VALUES. C * C********************************************************************* 150 CONTINUE WRITE(*,*) ' ****************************************************' WRITE(*,*) ' * WHICH FUNCTION DO YOU WANT TO PLOT ? *' WRITE(*,*) ' * *' WRITE(*,*) XC(1) WRITE(*,*) XC(2) WRITE(*,*) XC(3) WRITE(*,*) XC(4) WRITE(*,*) XC(5) WRITE(*,*) XC(6) WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' ****************************************************' WRITE(*,*) READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') RETURN IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 150 END IF READ(CHANS,'(I32)') NF 160 CONTINUE WRITE(*,*) ' ****************************************************' WRITE(*,*) ' * WHICH DO YOU WANT AS THE INDEPENDENT VARIABLE ? *' WRITE(*,*) ' * *' WRITE(*,*) XC(7) WRITE(*,*) XC(8) WRITE(*,*) ' * *' WRITE(*,*) ' * ENTER THE NUMBER OF YOUR CHOICE: (h?) *' WRITE(*,*) ' ****************************************************' WRITE(*,*) C READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') RETURN IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 160 END IF READ(CHANS,'(I32)') NV CALL QPLOT(ISLFUN,XT,NV,PLOTF,NF) C 170 CONTINUE WRITE(*,*) WRITE(*,*) ' DO YOU WANT TO SAVE THE PLOT FILE ? (Y/N) (h?)' READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') STOP IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 170 END IF READ(CHANS,2) YN IF (YN.EQ.'y' .OR. YN.EQ.'Y') THEN WRITE(*,*) ' SPECIFY NAME OF FILE FOR PLOTTING ' READ(*,'(A)') TAPE OPEN(1,FILE=TAPE,STATUS='NEW') DO 180 I = 1,ISLFUN WRITE(1,*) XT(9+I,NV),PLOTF(9+I,NF) 180 CONTINUE CLOSE(1) WRITE(*,*) ' THE PLOT FILE HAS BEEN WRITTEN TO ',TAPE IF (RITE) WRITE(2,*) ' The plot file has been written to ',TAPE END IF WRITE(*,*) 190 CONTINUE WRITE(*,*) ' PLOT ANOTHER FUNCTION ? (Y/N) (h?)' READ(*,1) CHANS READ(CHANS,2) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') STOP IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(16) GO TO 190 END IF READ(CHANS,2) YN IF (YN.EQ.'y' .OR. YN.EQ.'Y') GO TO 150 RETURN 1 FORMAT(A32) 2 FORMAT(A1) END SUBROUTINE EIGENF(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN,KFLAG) INTEGER ISLFUN,KFLAG LOGICAL AOK,SINGA,LCIRCA,OSCA,BOK,SINGB,LCIRCB,OSCB DOUBLE PRECISION EIGPI,A1,A2,B1,B2 DOUBLE PRECISION SLFUN(1000,2) C ********** C WARNING: DANGER! The array SLFUN here is two-dimensional, whereas C it is one-dimensional in subroutine SLEIGN2. C ********** C .. Scalars in Common .. INTEGER MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,HPI,PI,TMID,TWOPI C .. C .. Local Scalars .. INTEGER I,IFLAG,J,NMID LOGICAL LCIRC,OK,SING DOUBLE PRECISION DTHDAT,DTHDBT,DTHDET,EFF,T,THT,TM C .. C .. Local Arrays .. DOUBLE PRECISION ERL(3),ERR(3),YL(3),YR(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC EXP,SIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C C WARNING: In this program it is assumed that the points T C in SLFUN all lie within the interval (AA,BB). C C Calculate selected eigenfunction values by integration (over T). C NMID = 0 DO 10 I=1,ISLFUN IF (SLFUN(9+I,1).LE.TMID) NMID = I 10 CONTINUE IF (NMID.GT.0) THEN T = AA YL(1) = SLFUN(3,1) YL(2) = 0.0D0 YL(3) = 0.0D0 LCIRC = LCIRCA OK = AOK SING = SINGA EFF = 0.0D0 DO 20 J=1,NMID TM = SLFUN(J+9,1) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YL(1) DTHDAT = DTHDAA*EXP(-2.0*EFF) DTHDET = YL(2) IF (TM.GT.AA) THEN CALL INTEG(T,THT,DTHDAT,DTHDET,TM,A1,A2,SLFUN(8,1), 1 YL,ERL,LCIRC,OK,SING,OSCA,IFLAG) IF (OSCA) THEN EFF = YL(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YL(3) END IF END IF IF (KFLAG.EQ.1) THEN SLFUN(J+9,1) = SIN(YL(1))*EXP(EFF+SLFUN(4,1)) ELSE SLFUN(J+9,1) = YL(1) SLFUN(J+9,2) = EFF + SLFUN(4,1) END IF T = TM IF (T.GT.-1.0D0) OK = .TRUE. IF (T.LT.-0.9 .AND .OSCA) THEN OK = .FALSE. T = AA YL(1) = SLFUN(3,1) YL(2) = 0.0D0 YL(3) = 0.0D0 END IF 20 CONTINUE END IF IF (NMID.LT.ISLFUN) THEN T = BB YR(1) = SLFUN(6,1) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 LCIRC = LCIRCB OK = BOK SING = SINGB EFF = 0.0D0 DO 30 J=ISLFUN,NMID+1,-1 TM = SLFUN(J+9,1) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YR(1) DTHDBT = DTHDBB*EXP(-2.0*EFF) DTHDET = YR(2) IF (TM.LT.BB) THEN CALL INTEG(T,THT,DTHDBT,DTHDET,TM,B1,B2,SLFUN(8,1), 1 YR,ERR,LCIRC,OK,SING,OSCB,IFLAG) IF (OSCB) THEN EFF = YR(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YR(3) END IF END IF IF (KFLAG.EQ.1) THEN SLFUN(J+9,1) = SIN(YR(1)+EIGPI)*EXP(EFF+SLFUN(7,1)) IF (ADDD) SLFUN(J+9,1) = -SLFUN(J+9,1) ELSE SLFUN(J+9,1) = YR(1) + EIGPI IF (ADDD) SLFUN(J+9,1) = SLFUN(J+9,1) + PI IF (OSCA .OR. OSCB) SLFUN(J+9,1) = 1 SLFUN(J+9,1) - MDTHZ*PI SLFUN(J+9,2) = EFF + SLFUN(7,1) END IF T = TM IF (T.LT.1.0D0) OK = .TRUE. IF (T.GT.0.9 .AND. OSCB) THEN OK = .FALSE. T = BB YR(1) = SLFUN(6,1) - EIGPI YR(2) = 0.0D0 YR(3) = 0.0D0 END IF 30 CONTINUE END IF RETURN END SUBROUTINE FZERO(F,B,C,R,RE,AE,IFLAG) INTEGER IFLAG DOUBLE PRECISION F,B,C,R,RE,AE EXTERNAL F C ********** C ********** C .. Local Scalars .. INTEGER IC,KOUNT DOUBLE PRECISION A,ACBS,ACMB,AW,CMB,DIF,DIFS,FA,FB,FC,FX,FZ, 1 P,Q,RW,TOL,Z C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX,MIN,SIGN C .. DIF = 1000.0D0 Z = R IF (R.LE.MIN(B,C).OR.R.GE.MAX(B,C)) Z = C RW = MAX(RE,0.0D0) AW = MAX(AE,0.0D0) IC = 0 FZ = F(Z) FB = F(B) KOUNT = 2 IF (FZ*FB.LT.0.0D0) THEN C = Z FC = FZ ELSE IF (Z.NE.C) THEN FC = F(C) KOUNT = 3 IF (FZ*FC.LT.0.0D0) THEN B = Z FB = FZ END IF END IF A = C FA = FC ACBS = ABS(B-C) FX = MAX(ABS(FB),ABS(FC)) C 10 CONTINUE IF (ABS(FC).LT.ABS(FB)) THEN A = B FA = FB B = C FB = FC C = A FC = FA END IF CMB = 0.5*(C-B) ACMB = ABS(CMB) TOL = RW*ABS(B) + AW IFLAG = 1 IF (ACMB.LE.TOL) THEN IF (FB*FC.GE.0.0D0) IFLAG = 4 IF (ABS(FB).GT.FX) IFLAG = 3 RETURN END IF IFLAG = 2 IF (FB.EQ.0.0D0) RETURN IFLAG = 5 IF (KOUNT.GE.500) RETURN C P = (B-A)*FB Q = FA - FB IF (P.LT.0.0D0) THEN P = -P Q = -Q END IF A = B FA = FB IC = IC + 1 IF (IC.GE.4) THEN IF (8.0*ACMB.GE.ACBS) B = 0.5*(C+B) ELSE IC = 0 ACBS = ACMB IF (P.LE.ABS(Q)*TOL) THEN B = B + SIGN(TOL,CMB) ELSE IF (P.GE.CMB*Q) THEN B = 0.5*(C+B) ELSE B = B + P/Q END IF END IF FB = F(B) DIFS = DIF DIF = FB - FC IF (DIF.EQ.DIFS) THEN IFLAG = 6 RETURN END IF KOUNT = KOUNT + 1 IF (FB*FC.GE.0.0D0) THEN C = A FC = FA END IF GO TO 10 END subroutine help(nh) integer i,n,nh character*36 x(23),y(23) character*1 ans c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),NH c 1 CONTINUE write(*,*) 'H1: Overview of HELP.' x(1)=' This ASCII text file is supplied a' y(1)='s a separate file with the SLEIGN2 ' x(2)='package; it can be accessed on-line ' y(2)='in both MAKEPQW (if used) and DRIVE.' x(3)=' HELP contains information to aid t' y(3)='he user in entering data on the ' x(4)='coefficient functions p,q,w; on the ' y(4)='limit circle boundary condition ' x(5)='functions u,v; on the end-point clas' y(5)='sifications of the differential ' x(6)='equation; on DEFAULT entry; on eigen' y(6)='value indexes; on IFLAG information;' x(7)='and on the general use of the progra' y(7)='m SLEIGN2. ' x(8)=' The 17 sections of HELP are: ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' H1: Overview of HELP. ' y(10)=' ' x(11)=' H2: File name entry. ' y(11)=' ' x(12)=' H3: The differential equation. ' y(12)=' ' x(13)=' H4: End-point classification. ' y(13)=' ' x(14)=' H5: DEFAULT entry. ' y(14)=' ' x(15)=' H6: Limit-circle boundary condit' y(15)='ions. ' do 101 i = 1,15 write(*,*) x(i),y(i) 101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' H7: General boundary conditions.' y(1)=' ' x(2)=' H8: Recording the results. ' y(2)=' ' x(3)=' H9: Type and choice of interval.' y(3)=' ' x(4)=' H10: Entry of end-points. ' y(4)=' ' x(5)=' H11: End-point values of p,q,w. ' y(5)=' ' x(6)=' H12: Initial value problems. ' y(6)=' ' x(7)=' H13: Indexing of eigenvalues. ' y(7)=' ' x(8)=' H14: Entry of eigenvalue index, i' y(8)='nitial guess, and tolerance. ' x(9)=' H15: IFLAG information. ' y(9)=' ' x(10)=' H16: Plotting. ' y(10)=' ' x(11)=' H17: Indexing of eigenvalues for ' y(11)='periodic-type problems. ' x(12)=' ' y(12)=' ' x(13)=' HELP can be accessed at each point' y(13)=' in MAKEPQW and DRIVE where the user' x(14)='is asked for input, by pressing "h <' y(14)='ENTER>"; this places the user at the' x(15)='appropriate HELP section. Once in H' y(15)='ELP, the user can scroll the further' x(16)='HELP sections by repeatedly pressing' y(16)=' "h ", or jump to a specific ' x(17)='HELP section Hn (n=1,2,...17) by typ' y(17)='ing "Hn "; to return to the ' x(18)='place in the program from which HELP' y(18)=' is called, press "r ". ' do 102 i = 1,18 write(*,*) x(i),y(i) 102 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 2 CONTINUE write(*,*) 'H2: File name entry.' x(1)=' MAKEPQW is used to create a FORTRA' y(1)='N file containing the coefficients ' x(2)='p(x),q(x),w(x), defining the differe' y(2)='ntial equation, and the boundary ' x(3)='condition functions u(x),v(x) if req' y(3)='uired. The file must be given a NEW' x(4)='filename which is acceptable to your' y(4)=' FORTRAN compiler. For example, it ' x(5)='might be called bessel.f or bessel.f' y(5)='or depending upon your compiler. ' x(6)=' The same naming considerations app' y(6)='ly if the FORTRAN file is prepared ' x(7)='other than with the use of MAKEPQW. ' y(7)=' ' do 201 i = 1,7 write(*,*) x(i),y(i) 201 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 3 CONTINUE write(*,*) 'H3: The differential equation.' x(1)=' The prompt "Input p (or q or w) ="' y(1)=' requests you to type in a FORTRAN ' x(2)='expression defining the function p(x' y(2)='), which is one of the three coeffi-' x(3)='cient functions defining the Sturm-L' y(3)='iouville differential equation ' x(4)=' ' y(4)=' ' x(5)=' -(p*y'')'' + q*y = ' y(5)=' lambda*w*y (*) ' x(6)=' ' y(6)=' ' x(7)='to be considered on some interval (a' y(7)=',b) of the real line. The actual ' x(8)='interval used in a particular proble' y(8)='m can be chosen later, and may be ' x(9)='either the whole interval (a,b) wher' y(9)='e the coefficient functions p,q,w, ' x(10)='etc. are defined or any sub-interval' y(10)=' (a'',b'') of (a,b); a = -infinity ' x(11)='and/or b = +infinity are allowable c' y(11)='hoices for the end-points. ' x(12)=' The coefficient functions p,q,w of' y(12)=' the differential equation may be ' x(13)='chosen arbitrarily but must satisfy ' y(13)='the following conditions: ' x(14)=' (1) p,q,w are real-valued througho' y(14)='ut (a,b). ' x(15)=' (2) p,q,w are piece-wise continuou' y(15)='s and defined throughout the ' x(16)=' interior of the interval (a,b)' y(16)='. ' x(17)=' (3) p and w are strictly positive ' y(17)='in (a,b). ' x(18)=' For better error analysis in the n' y(18)='umerical procedures, condition ' x(19)='(2) above is often replaced with ' y(19)=' ' x(20)=' (2'') p,q,w are four times continuo' y(20)='usly differentiable on (a,b). ' x(21)=' The behavior of p,q,w near the end' y(21)='-points a and b is critical to the ' x(22)='classification of the differential e' y(22)='quation (see H4 and H11). ' do 301 i = 1,22 write(*,*) x(i),y(i) 301 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 4 CONTINUE write(*,*) 'H4: End-point classification.' x(1)=' The correct classification of the ' y(1)='end-points a and b is essential to ' x(2)='the working of the SLEIGN2 program. ' y(2)=' To classify the end-points, it is ' x(3)='convenient to choose a point c in (a' y(3)=',b); i.e., a < c < b. Subject to ' x(4)='the general conditions on the coeffi' y(4)='cient functions p,q,w (see H3): ' x(5)=' (1) a is REGULAR (say R) if -infin' y(5)='ity < a, p,q,w are piece-wise ' x(6)=' continuous on [a,c], and p(a) ' y(6)='> 0 and w(a) > 0. ' x(7)=' (2) a is WEAKLY REGULAR (say WR) i' y(7)='f -infinity < a, a is not R, and ' x(8)=' |c ' y(8)=' ' x(9)=' integral | {1/p+|q|+w} < +infi' y(9)='nity. ' x(10)=' |a ' y(10)=' ' x(11)=' ' y(11)=' ' x(12)=' If end-point a is neither R nor ' y(12)='WR, then a is SINGULAR; that is, ' x(13)=' either -infinity = a, or -infinity' y(13)=' < a and ' x(14)=' |c ' y(14)=' ' x(15)=' integral | {1/p+|q|+w} = +infi' y(15)='nity. ' x(16)=' |a ' y(16)=' ' x(17)=' (3) The SINGULAR end-point a is LI' y(17)='MIT-CIRCLE NON-OSCILLATORY (say ' x(18)=' LCNO) if for some real lambda ' y(18)='ALL real-valued solutions y of the ' x(19)=' differential equation ' y(19)=' ' x(20)=' ' y(20)=' ' x(21)=' -(p*y'')'' + q*y = ' y(21)=' lambda*w*y on (a,c] (*) ' x(22)=' ' y(22)=' ' x(23)=' satisfy the conditions: ' y(23)=' ' do 401 i = 1,23 write(*,*) x(i),y(i) 401 continue read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' |c ' y(1)=' ' x(2)=' integral | { w*y*y } < +infini' y(2)='ty, and ' x(3)=' |a ' y(3)=' ' x(4)=' y has at most a finite number ' y(4)='of zeros in (a,c]. ' x(5)=' (4) The SINGULAR end-point a is LI' y(5)='MIT-CIRCLE OSCILLATORY (say LCO) if ' x(6)='for some real lambda ALL real-valued' y(6)=' solutions of the differential ' x(7)='equation (*) satisfy the conditions:' y(7)=' ' x(8)=' |c ' y(8)=' ' x(9)=' integral | { w*y*y } < +infini' y(9)='ty, and ' x(10)=' |a ' y(10)=' ' x(11)=' y has an infinite number of ze' y(11)='ros in (a,c]. ' x(12)=' (5) The SINGULAR end-point a is LI' y(12)='MIT POINT (say LP) if for some real ' x(13)='lambda at least one solution of the ' y(13)='differential equation (*) satisfies ' x(14)='the condition: ' y(14)=' ' x(15)=' |c ' y(15)=' ' x(16)=' integral | {w*y*y} = +infinity' y(16)='. ' x(17)=' |a ' y(17)=' ' x(18)=' There is a similar classification ' y(18)='of the end-point b into one of the ' x(19)='five distinct cases R, WR, LCNO, LCO' y(19)=', LP. ' do 402 i = 1,19 write(*,*) x(i),y(i) 402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Although the classification of sin' y(1)='gular end-points invokes a real ' x(2)='value of the parameter lambda, this ' y(2)='classification is invariant in ' x(3)='lambda; all real choices of lambda l' y(3)='ead to the same classification. ' x(4)=' In determining the classification ' y(4)='of singular end-points for the ' x(5)='differential equation (*), it is oft' y(5)='en convenient to start with the ' x(6)='choice lambda = 0 in attempting to f' y(6)='ind solutions (particularly when ' x(7)='q = 0 on (a,b)); however, see exampl' y(7)='e 7 below. ' x(8)=' See H6 on the use of maximal domai' y(8)='n functions to determine the ' x(9)='classification at singular end-point' y(9)='s. ' do 403 i = 1,9 write(*,*) x(i),y(i) 403 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' EXAMPLES: ' x(1)=' 1. -y'''' = lambda*y is R at both en' y(1)='d-points of (a,b) when a and b are ' x(2)=' finite. ' y(2)=' ' x(3)=' 2. -y'''' = lambda*y on (-infinity,i' y(3)='nfinity) is LP at both end-points. ' x(4)=' 3. -(sqrt(x)*y''(x))'' = lambda*(1./' y(4)='sqrt(x))*y(x) on (0,infinity) is ' x(5)=' WR at 0 and LP at +infinity (ta' y(5)='ke lambda = 0 in (*)). See ' x(6)=' examples.f, #10 (Weakly Regular' y(6)='). ' x(7)=' 4. -((1-x*x)*y''(x))'' = lambda*y(x)' y(7)=' on (-1,1) is LCNO at both ends ' x(8)=' (take lambda = 0 in (*)). See ' y(8)='xamples.f, #1 (Legendre). ' x(9)=' 5. -y''''(x) + C*(1/(x*x))*y(x) = la' y(9)='mbda*y(x) on (0,infinity) is LP at ' x(10)=' infinity and at 0 is (take lamb' y(10)='da = 0 in (*)): ' x(11)=' LP for C .ge. 3/4 ; ' y(11)=' ' x(12)=' LCNO for -1/4 .le. C .lt. 3/4' y(12)=' (but C .ne. 0); ' x(13)=' LCO for C .lt. -1/4. ' y(13)=' ' x(14)=' 6. -(x*y''(x))'' - (1/x)*y(x) = lamb' y(14)='da*y(x) on (0,infinity) is LCO at 0 ' x(15)=' and LP at +infinity (take lambd' y(15)='a = 0 in (*) with solutions ' x(16)=' cos(ln(x)) and sin(ln(x))). Se' y(16)='e xamples.f, #7 (BEZ). ' x(17)=' 7. -(x*y''(x))'' - x*y(x) = lambda*(' y(17)='1/x)*y(x) on (0,infinity) is LP at 0' x(18)=' and LCO at infinity (take lambd' y(18)='a = -1/4 in (*) with solutions ' x(19)=' cos(x)/sqrt(x) and sin(x)/sqrt(' y(19)='x)). See xamples.f, ' x(20)=' #6 (Sears-Titchmarsh). ' y(20)=' ' do 404 i = 1,20 write(*,*) x(i),y(i) 404 continue write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 5 CONTINUE write(*,*) 'H5: DEFAULT entry.' x(1)=' The complete range of problems for' y(1)=' which SLEIGN2 is applicable can ' x(2)='only be reached by appropriate entri' y(2)='es under end-point classification ' x(3)='and boundary conditions. However, t' y(3)='here is a DEFAULT application which ' x(4)='requires no detailed entry of end-po' y(4)='int classification or boundary ' x(5)='conditions, subject to: ' y(5)=' ' x(6)=' 1) The DEFAULT application CANNOT ' y(6)='be used at a LCO end-point. ' x(7)=' 2) If an end-point a is R, then th' y(7)='e Dirichlet boundary condition ' x(8)=' y(a) = 0 is automatically used.' y(8)=' ' x(9)=' 3) If an end-point a is WR, then t' y(9)='he following boundary condition ' x(10)=' is automatically applied: ' y(10)=' ' x(11)=' if p(a) = 0, and both q(a),w(' y(11)='a) are bounded, then the Dirichlet ' x(12)=' boundary condition y(a) = 0 i' y(12)='s used, or ' x(13)=' if p(a) > 0, and q(a) and/or ' y(13)='w(a)) are not bounded, then the ' x(14)=' Neumann boundary condition (p' y(14)='y'')(a) = 0 is used. ' x(15)=' If p(a) = 0, and q(a) and/or w(' y(15)='a) are not bounded, then no reliable' x(16)=' information can be given on the' y(16)=' DEFAULT boundary condition. ' x(17)=' 4) If an end-point is LCNO, then i' y(17)='n most cases the principal or ' x(18)=' Friedrichs boundary condition i' y(18)='s applied (see H6). ' x(19)=' 5) If an end-point is LP, then the' y(19)=' normal LP procedure is applied ' x(20)=' (see H7(1.)). ' y(20)=' ' x(21)='If you choose the DEFAULT condition,' y(21)=' then no entry is required for the ' x(22)='u,v boundary condition functions. ' y(22)=' ' do 501 i = 1,22 write(*,*) x(i),y(i) 501 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 6 CONTINUE write(*,*) 'H6: Limit-circle boundary conditions.' x(1)=' At an end-point a, the limit-circl' y(1)='e type separated boundary condition ' x(2)='is of the form (similar remarks thro' y(2)='ughout apply to the end-point b) ' x(3)=' ' y(3)=' ' x(4)=' A1*[y,u](a) + A2*[y,v](a) = 0' y(4)=', (**) ' x(5)=' ' y(5)=' ' x(6)='where y is a solution of the differe' y(6)='ntial equation ' x(7)=' ' y(7)=' ' x(8)=' -(p*y'')'' + q*y = lambda*w*y on' y(8)=' (a,b). (*) ' x(9)=' ' y(9)=' ' x(10)='Here A1, A2 are real numbers; u and ' y(10)='v are boundary condition functions; ' x(11)='and for real-valued y and u the form' y(11)=' [y,u] is defined by ' x(12)=' ' y(12)=' ' x(13)=' [y,u](x) = y(x)*(pu'')(x) - u(x' y(13)=')*(py'')(x) for x in (a,b). ' x(14)=' ' y(14)=' ' x(15)=' The object of this section is to p' y(15)='rovide help in choosing appropriate ' x(16)='functions u and v in (**), given the' y(16)=' differential equation (*). Full ' x(17)='details of the boundary conditions f' y(17)='or (*) are discussed in H7; here it ' x(18)='is sufficient to say that the limit-' y(18)='circle type boundary condition (**) ' x(19)='can be applied at any end-point in t' y(19)='he LCNO, LCO classification, but ' x(20)='also in the R, WR classification sub' y(20)='ject to the appropriate choice of ' x(21)='u and v. ' y(21)=' ' do 601 i = 1,21 write(*,*) x(i),y(i) 601 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Let (*) be R, WR, LCNO, or LCO at ' y(1)='end-point a and choose c in (a,b). ' x(2)='Then either ' y(2)=' ' x(3)=' u and v are a pair of linearly i' y(3)='ndependent solutions of (*) on (a,c]' x(4)=' for any chosen real values of lamb' y(4)='da, or ' x(5)=' u and v are a pair of real-value' y(5)='d maximal domain functions defined ' x(6)=' on (a,c] satisfying [u,v](a) .ne. ' y(6)='0. The maximal domain D(a,c] is ' x(7)=' defined by ' y(7)=' ' x(8)=' ' y(8)=' ' x(9)=' D(a,c] = {f:(a,c]->R:: f,pf'' ' y(9)='in AC(a,c]; ' x(10)=' f, ((-pf'')''+qf)/w' y(10)=' in L2((a,c;w)} ' x(11)=' ' y(11)=' ' x(12)=' It is known that for all f,g in D(' y(12)='a,c] the limit ' x(13)=' ' y(13)=' ' x(14)=' [f,g](a) = lim[f,g](x) as x->' y(14)='a ' x(15)=' ' y(15)=' ' x(16)=' exists and is finite. If (*) is L' y(16)='CNO or LCO at a, then all solutions ' x(17)=' of (*) belong to D(a,c] for all va' y(17)='lues of lambda. ' do 602 i = 1,17 write(*,*) x(i),y(i) 602 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' The boundary condition (**) is ess' y(1)='ential in the LCNO and LCO cases but' x(2)='can also be used with advantage in s' y(2)='ome R and WR cases. In the R, WR, ' x(3)='and LCNO cases, but not in the LCO c' y(3)='ase, the boundary condition ' x(4)='functions can always be chosen so th' y(4)='at ' x(5)=' lim u(x)/v(x) = 0 as x->a, ' y(5)=' ' x(6)='and it is recommended that this norm' y(6)='alisation be effected; this has been' x(7)='done in the examples given below. In' y(7)=' this case, the boundary condition ' x(8)='[y,u](a) = 0 (i.e., A1 = 1, A2 = 0 i' y(8)='n (**)) is called the principal or ' x(9)='Friedrichs boundary condition. ' y(9)=' ' x(10)=' ' y(10)=' ' x(11)=' In the case when end-points a and ' y(11)='b are, independently, in R, WR, ' x(12)='LCNO, or LCO classification, it may ' y(12)='be that symmetry or other reasons ' x(13)='permit one set of boundary condition' y(13)=' functions to be used at both end- ' x(14)='points (see xamples.f, #1 (Legendre)' y(14)='). In other cases, different pairs ' x(15)='must be chosen for each end-point (s' y(15)='ee xamples.f: #16 (Jacobi), ' x(16)='#18 (Dunsch), and #19 (Donsch)). ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' Note that a solution pair u,v is a' y(18)='lways a maximal domain pair, but not' x(19)='necessarily vice versa. ' y(19)=' ' do 603 i = 1,19 write(*,*) x(i),y(i) 603 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' EXAMPLES: ' y(1)=' ' x(2)='1. -y''''(x) = lambda*y(x) on [0,pi] i' y(2)='s R at 0 and R at pi. ' x(3)=' At 0, with lambda = 0, a solution' y(3)=' pair is u(x) = x, v(x) = 1. ' x(4)=' At pi, with lambda = 1, a solutio' y(4)='n pair is ' x(5)=' u(x) = sin(x), v(x) = cos(x). ' y(5) =' ' x(6)='2. -(sqrt(x)*y''(x))'' = lambda*y(x)/s' y(6)='qrt(x) on (0,1] is ' x(7)=' WR at 0 and R at 1. ' y(7)=' ' x(8)=' (The general solutions of this eq' y(8)='uation are ' x(9)=' u(x) = cos(2*sqrt(x*lambda)), v' y(9)='(x) = sin(2*sqrt(x*lambda)).) ' x(10)=' At 0, with lambda = 0, a solution' y(10)=' pair is ' x(11)=' u(x) = 2*sqrt(x), v(x) = 1. ' y(11)=' ' x(12)=' At 1, with lambda = pi*pi/4, a so' y(12)='lution pair is ' x(13)=' u(x) = sin(pi*sqrt(x)), v(x) = ' y(13)='cos(pi*sqrt(x)). ' x(14)=' At 1, with lambda = 0, a solution' y(14)=' pair is ' x(15)=' u(x) = 2*(1-sqrt(x)), v(x) = 1.' y(15)=' ' x(16)=' See also xamples.f, #10 (Weakly R' y(16)='egular). ' x(17)='3. -((1-x*x)*y''(x))'' = lambda*y(x) o' y(17)='n (-1,1) is LCNO at both ends. ' x(18)=' At +-1, with lambda = 0, a soluti' y(18)='on pair is ' x(19)=' u(x) = 1, v(x) = 0.5*log((1+x)/' y(19)='(1-x)). ' x(20)=' At 1, a maximal domain pair is u(' y(20)='x) = 1, v(x) = log(1-x) ' x(21)=' At -1, a maximal domain pair is u' y(21)='(x) = 1, v(x) = log(1+x). ' x(22)=' See also xamples.f, #1 (Legendre)' y(22)='. ' do 604 i = 1,22 write(*,*) x(i),y(i) 604 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)='4. -y''''(x) - (1/(4x*x))*y(x) = lambd' y(1)='a*y(x) on (0,infinity) is ' x(2)=' LCNO at 0 and LP at +infinity. ' y(2)=' ' x(3)=' At 0, a maximal domain pair is ' y(3)=' ' x(4)=' u(x) = sqrt(x), v(x) = sqrt(x)*' y(4)='log(x). ' x(5)=' See also xamples.f, #2 (Bessel). ' y(5)=' ' x(6)='5. -y''''(x) - 5*(1/(4*x*x))*y(x) = la' y(6)='mbda*y(x) on (0,infinity) is ' x(7)=' LCO at 0 and LP at +infinity. ' y(7)=' ' x(8)=' At 0, with lambda = 0, a solution' y(8)=' pair is ' x(9)=' u(x) = sqrt(x)*cos(log(x)), v(x' y(9)=') = sqrt(x)*sin(log(x)) ' x(10)=' See also xamples.f, #20 (Krall). ' y(10)=' ' x(11)='6. -y''''(x) - (1/x)*y(x) = lambda*y(x' y(11)=') on (0,infinity) is ' x(12)=' LCNO at 0 and LP at +infinity.' y(12)=' ' x(13)=' At 0, a maximal domain pair is ' y(13)=' ' x(14)=' u(x) = x, v(x) = 1 -x*log(x). ' y(14)=' ' x(15)=' See also xamples.f, #4(Boyd). ' y(15)=' ' x(16)='7. -((1/x)*y''(x))'' + (k/(x*x) + k*k/' y(16)='x)*y(x) = lambda*y(x) on (0,1], ' x(17)=' with k real and .ne. 0, is LCNO' y(17)=' at 0 and R at 1. ' x(18)=' At 0, a maximal domain pair is ' y(18)=' ' x(19)=' u(x) = x*x, v(x) = x - 1/k. ' y(19)=' ' x(20)=' See also xamples.f, #8 (Laplace T' y(20)='idal Wave). ' do 605 i = 1,20 write(*,*) x(i),y(i) 605 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 7 CONTINUE write(*,*) 'H7: General boundary conditions.' x(1)=' Boundary conditions for Sturm-Liou' y(1)='ville boundary value problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='on an interval (a,b) are either ' y(5)=' ' x(6)=' SEPARATED, with at most one cond' y(6)='ition at end-point a and at most ' x(7)=' one condition at end-point b, or ' y(7)=' ' x(8)=' COUPLED, when both a and b are, ' y(8)='independently, in one of the end- ' x(9)=' point classifications R, WR, LCNO,' y(9)=' LCO, in which case two independent ' x(10)=' ent boundary conditions are requir' y(10)='ed which link the solution values ' x(11)=' near a to those near b. ' y(11)=' ' x(12)='The SLEIGN2 program allows for all s' y(12)='eparated conditions; and special ' x(13)='cases of the coupled conditions -- t' y(13)='he so-called periodic boundary ' x(14)='conditions applicable only when the ' y(14)='interval (a,b) is finite and both ' x(15)='a and b are R. ' y(15)=' ' do 701 i = 1,15 write(*,*) x(i),y(i) 701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' Separated Conditions: ' write(*,*) ' --------------------- ' x(1)=' The boundary conditions to be sele' y(1)='cted depend upon the classification ' x(2)='of the differential equation at the ' y(2)='end-point, say, a: ' x(3)=' 1. If the end-point a is LP, the' y(3)='n no boundary condition is required ' x(4)=' or allowed. ' y(4)=' ' x(5)=' 2. If the end-point a is R or WR' y(5)=', then a separated boundary ' x(6)=' condition is of the form ' y(6)=' ' x(7)=' A1*y(a) + A2*(py'')(a) = 0,' y(7)=' ' x(8)=' where A1, A2 are real constants yo' y(8)='u must choose, not both zero. ' x(9)=' 3. If the end-point a is LCNO or' y(9)=' LCO, then a separated boundary ' x(10)=' condition is of the form ' y(10)=' ' x(11)=' A1*[y,u](a) + A2*[y,v](a) =' y(11)=' 0, ' x(12)=' where A1, A2 are real constants yo' y(12)='u must choose, not both zero; ' x(13)=' here, u,v are the pair of boundary' y(13)=' condition functions you have ' x(14)=' previously selected when the input' y(14)=' FORTRAN file was being prepared. ' x(15)=' 4. If the end-point a is LCNO an' y(15)='d the boundary condition pair ' x(16)=' u,v has been chosen so that ' y(16)=' ' x(17)=' lim u(x)/v(x) = 0 as x->a ' y(17)=' ' x(18)=' (which is always possible), then A' y(18)='1 = 1, A2 = 0 (i.e., [y,u](a) = 0) ' x(19)=' gives the principal (Friedrichs) b' y(19)='oundary condition at a. ' do 702 i = 1,19 write(*,*) x(i),y(i) 702 continue write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 5. If a is R or WR and boundary ' y(1)='condition functions u,v have been ' x(2)=' entered in the FORTRAN input file,' y(2)=' then (3.,4.) above apply to ' x(3)=' entering separated boundary condit' y(3)='ions at such an end-point; the ' x(4)=' boundary conditions in this form a' y(4)='re equivalent to the point-wise ' x(5)=' conditions in (2.) (subject to car' y(5)='e in choosing A1, A2). This ' x(6)=' singular form of a regular boundar' y(6)='y condition may be particularly ' x(7)=' effective in the WR case if the bo' y(7)='undary condition form in (2.) leads ' x(8)=' to numerical difficulties. ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' Conditions (2.,3.,4.,5.) apply sim' y(10)='ilarly at end-point b. ' x(11)=' ' y(11)=' ' x(12)=' 6. If a is R, WR, LCNO, or LCO a' y(12)='nd b is LP, then only a separated ' x(13)=' condition at a is required and all' y(13)='owed (or instead at b if a and b ' x(14)=' are interchanged). ' y(14)=' ' x(15)=' 7. If both end-points a and b ar' y(15)='e LP, then no boundary conditions ' x(16)=' are required or allowed. ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' The indexing of eigenvalues for bo' y(18)='undary value problems with separated' x(19)=' conditions is discussed in H13. ' y(19)=' ' do 703 i = 1,19 write(*,*) x(i),y(i) 703 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),n write(*,*) ' Coupled Conditions: ' write(*,*) ' ------------------- ' x(1)=' 8. Periodic-type boundary condit' y(1)='ions on (a,b) apply only when ' x(2)=' both end-points a and b are R; the' y(2)='se conditions are of the form ' x(3)=' ' y(3)=' ' x(4)=' y(b) = c*y(a), (py'')(b) = (' y(4)='py'')(a)/c, ' x(5)=' ' y(5)=' ' x(6)=' where c may be chosen to be any re' y(6)='al number not equal to 0. The case ' x(7)=' c = 1 is called periodic, the case' y(7)=' c = -1 is called semi-periodic. ' x(8)=' ' y(8)=' ' x(9)=' The indexing of eigenvalues for pe' y(9)='riodic-type boundary conditions is ' x(10)=' discussed in H17. ' y(10)=' ' do 704 i = 1,10 write(*,*) x(i),y(i) 704 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 8 CONTINUE write(*,*) 'H8: Recording the results.' x(1)=' If you choose to have a record kep' y(1)='t of the results, then the following' x(2)='information is stored in a file with' y(2)=' the name you select: ' x(3)=' ' y(3)=' ' x(4)=' 1. The file name. ' y(4)=' ' x(5)=' 2. The header line prompted for (u' y(5)='p to 32 characters of your choice). ' x(6)=' 3. The interval (a,b) which was us' y(6)='ed. ' x(7)=' ' y(7)=' ' x(8)=' For SEPARATED boundary conditions:' y(8)=' ' x(9)=' 4. The end-point classification. ' y(9)=' ' x(10)=' 5. A summary of coefficient inform' y(10)='ation at WR, LCNO, LCO end-points. ' x(11)=' 6. The boundary condition constant' y(11)='s (A1,A2), (B1,B2) if entered. ' x(12)=' 7. (NUMEIG,EIG,TOL) or (NUMEIG1,NU' y(12)='MEIG2,TOL), as entered. ' x(13)=' ' y(13)=' ' x(14)=' For COUPLED boundary conditions: ' y(14)=' ' x(15)=' 8. The boundary condition paramete' y(15)='r, c. ' x(16)=' ' y(16)=' ' x(17)=' For ALL boundary conditions: ' y(17)=' ' x(18)=' 9. The computed eigenvalue, EIG, a' y(18)='nd its estimated accuracy, TOL. ' x(19)=' 10. IFLAG reported (see H15). ' y(19)=' ' do 801 i = 1,19 write(*,*) x(i),y(i) 801 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 9 CONTINUE write(*,*) 'H9: Type and choice of interval.' x(1)=' You may enter any interval (a,b) f' y(1)='or which the coefficients p,q,w are ' x(2)='well defined by your FORTRAN stateme' y(2)='nts in the input file, provided that' x(3)='(a,b) contains no interior singulari' y(3)='ities. ' do 901 i = 1,3 write(*,*) x(i),y(i) 901 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 10 CONTINUE write(*,*) 'H10: Entry of end-points.' x(1)=' End-points a and b must be entered' y(1)=' as real numbers. There is no ' x(2)='symbolic entry; e.g., pi must be ent' y(2)='ered as 3.14159... to an appropriate' x(3)='number of decimal places. ' y(3)=' ' do 1001 i = 1,3 write(*,*) x(i),y(i) 1001 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 11 CONTINUE write(*,*) 'H11: End-point values of p,q,w.' x(1)=' The program SLEIGN2 needs to know ' y(1)='whether the coefficient functions ' x(2)='p(x),q(x),w(x) defined by the FORTRA' y(2)='N expressions entered in the input ' x(3)='file can be evaluated numerically wi' y(3)='thout running into difficulty. If, ' x(4)='for example, either q or w is unboun' y(4)='ded at a, or p(a) is 0, then SLEIGN2' x(5)='needs to know this so that a is not ' y(5)='chosen for functional evaluation. ' do 1101 i = 1,5 write(*,*) x(i),y(i) 1101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 12 CONTINUE write(*,*) 'H12: Initial value problems.' x(1)=' The initial value problem facility' y(1)=' for Sturm-Liouville problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='allows for the computation of a solu' y(5)='tion of (*) with a user-chosen ' x(6)='value lambda and any one of the foll' y(6)='owing initial conditions: ' x(7)=' 1. From end-point a of any classif' y(7)='ication except LP towards ' x(8)='end-point b of any classification, ' y(8)=' ' x(9)=' 2. From end-point b of any classif' y(9)='ication except LP back towards ' x(10)='end-point a of any classification, ' y(10)=' ' x(11)=' 3. From end-points a and b of any ' y(11)='classifications except LP towards an' x(12)='interior point of (a,b) selected by ' y(12)='the program. ' x(13)=' ' y(13)=' ' x(14)=' Initial values at a are of the for' y(14)='m y(a) = alpha1, (p*y'')a = alpha2, ' x(15)='when a is R or WR; and [y,u](a) = al' y(15)='pha1, [y,v](a) = alpha2, when a is ' x(16)='LCNO or LCO. ' y(16)=' ' x(17)=' Initial values at b are of the for' y(17)='m y(b) = beta1, (p*y'')b = beta2, ' x(18)='when b is R or WR; and [y,u](b) = be' y(18)='ta1, [y,v](b) = beta2, when b is ' x(19)='LCNO or LCO. ' y(19)=' ' x(20)=' In (*), lambda is a user-chosen re' y(20)='al number; while in the above ' x(21)='initial values, (alpha1,alpha2) and ' y(21)='(beta1,beta2) are user-chosen pairs ' x(22)='of real numbers not both zero. ' y(22)=' ' do 1201 i = 1,22 write(*,*) x(i),y(i) 1201 continue write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In the initial value case (3.) abo' y(1)='ve when the interval (a,b) is ' x(2)='finite, the interior point selected ' y(2)='by the program is generally near the' x(3)='midpoint of (a,b); when (a,b) is inf' y(3)='inite, no general rule can be given.' x(4)='Also if, given (alpha1,alpha2) and (' y(4)='beta1,beta2), the lambda chosen is ' x(5)='an eigenvalue of the associated boun' y(5)='dary value problem, the computed ' x(6)='solution may not be the correspondin' y(6)='g eigenfunction -- the signs of the ' x(7)='computed solutions on either side of' y(7)=' the interior point may be opposite.' x(8)=' The output for a solution of an in' y(8)='itial value problem is in the form ' x(9)='of stored numerical data which can b' y(9)='e plotted on the screen (see H16), ' x(10)='or printed out in graphical form if ' y(10)='graphics software is available. ' do 1202 i = 1,10 write(*,*) x(i),y(i) 1202 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 13 continue write(*,*) 'H13: Indexing of eigenvalues.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general results hold for t' y(2)='he separated boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' 1. If neither end-point a or b is ' y(4)='LP or LCO, then the spectrum of the ' x(5)='eigenvalue problem is discrete (eige' y(5)='nvalues only), simple (eigenvalues ' x(6)='all of multiplicity 1), and bounded ' y(6)='below with a single cluster point at' x(7)='+infinity. The eigenvalues are inde' y(7)='xed as {lambda(n): n=0,1,2,...}, ' x(8)='where lambda(n) < lambda(n+1) (n=0,1' y(8)=',2,...), lim lambda(n) -> +infinity;' x(9)='and if {psi(n): n=0,1,2,...} are the' y(9)=' corresponding eigenfunctions, then ' x(10)='psi(n) has exactly n zeros in the op' y(10)='en interval (a,b). ' x(11)=' 2. If neither end-point a or b is ' y(11)='LP but at least one end-point is ' x(12)='LCO, then the spectrum is discrete a' y(12)='nd simple as for (1.), but with ' x(13)='cluster points at both +infinity and' y(13)=' -infinity. The eigenvalues are ' x(14)='indexed as {lambda(n): n=0,1,-1,2,-2' y(14)=',...}, where ' x(15)='lambda(n) < lambda(n+1) (n=...-2,-1,' y(15)=',0,1,2,...) with lambda(0) the ' x(16)='smallest non-negative eigenvalue and' y(16)=' lim lambda(n) -> +infinity or ' x(17)='-> -infinity with n; and if {psi(n):' y(17)=' n=0,1,-1,2,-2,...} are the ' x(18)='corresponding eigenfunctions, then e' y(18)='very psi(n) has infinitely many ' x(19)='zeros in (a,b). ' y(19)=' ' do 1301 i = 1,19 write(*,*) x(i),y(i) 1301 continue write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 3. If one or both end-points is LP' y(1)=', then there can be one or more ' x(2)='intervals of continuous spectrum for' y(2)=' the boundary value problem in ' x(3)='addition to some (necessarily simple' y(3)=') eigenvalues. For these ' x(4)='essentially more difficult problems,' y(4)=' SLEIGN2 can be used as an ' x(5)='investigative tool to give qualitati' y(5)='ve and possibly quantitative ' x(6)='information on the spectrum. ' y(6)=' ' x(7)=' For example, if a problem has a' y(7)=' single interval of continuous ' x(8)='spectrum bounded below by K, then th' y(8)='ere may be any number of eigenvalues' x(9)='below K. In some cases, SLEIGN2 can' y(9)=' compute K, and determine the number' x(10)='of these eigenvalues and compute the' y(10)='m. In this respect, see xamples.f: ' x(11)='#13 (Hydrogen Atom), #17 (Morse Osci' y(11)='llator), #21 (Fourier), and ' x(12)='#27 (Joergens) as examples of succes' y(12)='s; and #2 (Mathieu), #14 (Marletta),' x(13)='and #28 (Behnke-Goerisch) as example' y(13)='s of failure. ' x(14)=' The problem need not have a con' y(14)='tinuous spectrum, in which case if ' x(15)='its discrete spectrum is bounded bel' y(15)='ow, then the eigenvalues are indexed' x(16)='and the eigenfunctions have zero cou' y(16)='nts as in (1.). If, on the other ' x(17)='hand, the discrete spectrum is unbou' y(17)='nded below, then all the ' x(18)='eigenfunctions have infinitely many ' y(18)='zeros in the interval. ' do 1302 i = 1,18 write(*,*) x(i),y(i) 1302 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In respect to the three classes of' y(1)=' end-points, the following ' x(2)='identified examples from xamples.f i' y(2)='llustrate the spectral property ' x(3)='of these boundary value problems: ' y(3)=' ' x(4)=' 1. Neither end-point is LP or LCO.' y(4)=' ' x(5)=' #1 (Legendre) ' y(5)=' ' x(6)=' #2 (Bessel) with -1/4 < c < 3' y(6)='/4 ' x(7)=' #4 (Boyd) ' y(7)=' ' x(8)=' #5 (Latzko) ' y(8)=' ' x(9)=' 2. Neither end-point is LP, but at' y(9)=' least one is LCO. ' x(10)=' #6 (Sears-Titchmarsh) ' y(10)=' ' x(11)=' #7 (BEZ) ' y(11)=' ' x(12)=' #19 (Donsch) ' y(12)=' ' x(13)=' 3. At least one end-point is LP. ' y(13)=' ' x(14)=' #13 (Hydrogen Atom) ' y(14)=' ' x(15)=' #14 (Marletta) ' y(15)=' ' x(16)=' #20 (Krall) ' y(16)=' ' x(17)=' #21 (Fourier) on [0,infinity) ' y(17)=' ' do 1303 i = 1,17 write(*,*) x(i),y(i) 1303 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 14 CONTINUE write(*,*) 'H14: Entry of eigenvalue index, initial guess,'// 1 ' and tolerance.' x(1)=' For SEPARATED boundary condition p' y(1)='roblems (see H7), SLEIGN2 calls for ' x(2)='input information options to compute' y(2)=' either ' x(3)=' 1. a single eigenvalue, or ' y(3)=' ' x(4)=' 2. a series of eigenvalues. ' y(4)=' ' x(5)='In each case indexing of eigenvalues' y(5)=' is called for (see H13). ' x(6)=' (1.) above asks for data triples N' y(6)='UMEIG, EIG, TOL separated by commas.' x(7)='Here NUMEIG is the integer index of ' y(7)='the desired eigenvalue; NUMEIG can ' x(8)='be negative only when the problem is' y(8)=' LCO at one or both end-points. ' x(9)='EIG allows for the entry of an initi' y(9)='al guess for the requested ' x(10)='eigenvalue (if an especially good on' y(10)='e is available), or can be set to 0 ' x(11)='in which case an initial guess is ge' y(11)='nerated by SLEIGN2 itself. ' x(12)='TOL is the desired accuracy of the c' y(12)='omputed eigenvalue. It is an ' x(13)='absolute accuracy if the magnitude o' y(13)='f the eigenvalue is 1 or less, and ' x(14)='is a relative accuracy otherwise. T' y(14)='ypical values might be .001 for ' x(15)='moderate accuracy and .0000001 for h' y(15)='igh accuracy in single precision. ' x(16)='If TOL is set to 0, the maximum achi' y(16)='evable accuracy is requested. ' x(17)=' If the input data list is truncate' y(17)='d with a "/" after NUMEIG or EIG, ' x(18)='then the remaining elements default ' y(18)='to 0. ' do 1401 i = 1,18 write(*,*) x(i),y(i) 1401 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' (2.) above asks for data triples N' y(1)='UMEIG1, NUMEIG2, TOL separated by ' x(2)='commas. Here NUMEIG1 and NUMEIG2 ar' y(2)='e the first and last integer indices' x(3)='of the sequence of desired eigenvalu' y(3)='es, NUMEIG1 < NUMEIG2; they can be ' x(4)='negative only when the problem is LC' y(4)='O at one or both end-points. ' x(5)='TOL is the desired accuracy of the c' y(5)='omputed eigenvalues. It is an ' x(6)='absolute accuracy if the magnitude o' y(6)='f an eigenvalue is 1 or less, and ' x(7)='is a relative accuracy otherwise. T' y(7)='ypical values might be .001 for ' x(8)='moderate accuracy and .0000001 for h' y(8)='igh accuracy in single precision. ' x(9)='If TOL is set to 0, the maximum achi' y(9)='evable accuracy is requested. ' x(10)=' If the input data list is truncate' y(10)='d with a "/" after NUMEIG2, then TOL' x(11)='defaults to 0. ' y(11)=' ' x(12)=' ' y(12)=' ' x(13)=' For COUPLED periodic-type boundary' y(13)=' condition problems (see H7 and ' x(14)='H17), SLEIGN2 asks only for NUMEIG, ' y(14)='the non-negative integer index of ' x(15)='the desired eigenvalue; TOL is set i' y(15)='nternally. ' do 1402 i = 1,15 write(*,*) x(i),y(i) 1402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 15 CONTINUE write(*,*) 'H15: IFLAG information.' x(1)=' All results are reported by SLEIGN' y(1)='2 with a flag identification. There' x(2)='are four values of IFLAG: ' y(2)=' ' x(3)=' ' y(3)=' ' x(4)=' 1 - The computed eigenvalue has an' y(4)=' estimated accuracy within the ' x(5)=' tolerance requested. ' y(5)=' ' x(6)=' ' y(6)=' ' x(7)=' 2 - The computed eigenvalue does n' y(7)='ot have an estimated accuracy within' x(8)=' the tolerance requested, but i' y(8)='s the best the program could obtain.' x(9)=' ' y(9)=' ' x(10)=' 3 - There seems to be no eigenvalu' y(10)='e of index equal to NUMEIG. ' x(11)=' ' y(11)=' ' x(12)=' 4 - The program has been unable to' y(12)=' compute the requested eigenvalue. ' do 1501 i = 1,12 write(*,*) x(i),y(i) 1501 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 16 CONTINUE write(*,*) 'H16: Plotting.' x(1)=' After computing a single eigenvalu' y(1)='e (see H14(1.)), but not a sequence ' x(2)='of eigenvalues (see H14(2.)), the ei' y(2)='genfunction can be plotted. If this' x(3)='is desired, respond "y" when asked s' y(3)='o that SLEIGN2 will compute some ' x(4)='eigenfunction data and store them. ' y(4)=' ' x(5)=' One can ask that the eigenfunction' y(5)=' data be in the form of either ' x(6)='points (x,y) for x in (a,b), or poin' y(6)='ts (t,y) for t in the standardized ' x(7)='interval (-1,1) mapped onto from (a,' y(7)='b); the t- choice can be especially ' x(8)='helpful when the original interval i' y(8)='s infinite. Additionally, one can ' x(9)='ask for a plot of the so-called Pruf' y(9)='er angle, in x- or t- variables. ' x(10)=' In both forms, once the choice has' y(10)=' been made of the function to be ' x(11)='plotted, a crude plot is displayed o' y(11)='n the monitor screen and you are ' x(12)='asked whether you wish to save the c' y(12)='omputed plot points in a file. ' do 1601 i = 1,12 write(*,*) x(i),y(i) 1601 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 17 CONTINUE write(*,*) 'H17: Indexing of eigenvalues for'// 1 ' periodic-type problems.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general result holds for t' y(2)='he periodic-type boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' The spectrum of the eigenvalue pro' y(4)='blem is discrete (eigenvalues only),' x(5)='and bounded below with a single clus' y(5)='ter point at +infinity. In general,' x(6)='the spectrum is not simple, but no e' y(6)='igenvalue exceeds multiplicity 2. ' x(7)='The eigenvalues are indexed as {lamb' y(7)='da(n): n=0,1,2,...}, where ' x(8)='lambda(n) .le. lambda(n+1) (n=0,1,2,' y(8)='...), lim lambda(n) -> +infinity. ' x(9)=' The connection between the index n' y(9)=' and the number of zeros of the ' x(10)='corresponding eigenfunction psi(x,n)' y(10)=' is not as simple as for separated ' x(11)='conditions; that is, psi(x,n) need n' y(11)='ot have exactly n zeros in (a,b). ' x(12)=' The following identified examples ' y(12)='from xamples.f are of special ' x(13)='interest: ' y(13)=' ' x(14)=' #11 (Plum) on [0,pi] ' y(14)=' ' x(15)=' #21 (Fourier) on [0,pi] ' y(15)=' ' x(16)=' #25 (Meissner) on [-0.5,0.5] ' y(16)=' ' do 1701 i = 1,16 write(*,*) x(i),y(i) 1701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N go to 1 999 FORMAT(A1,I2) end SUBROUTINE MESH(EIG,TS,NN) INTEGER NN DOUBLE PRECISION EIG DOUBLE PRECISION TS(991) C ********** C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER I,IJ,IMAX,IMAXP,J,JJ,JM,JP,M PARAMETER (IMAX = 100) PARAMETER (IMAXP = IMAX + 1) DOUBLE PRECISION DELL,DELL0,DEN,DT,FACTOR,PX,QQ,QX, 1 SAV,SUM,S1,T1,WX,X C .. C .. Local Arrays .. INTEGER JL(5) DOUBLE PRECISION TT(IMAXP),DELT(IMAXP),T(1000),S(1000) C .. C .. External Subroutines .. EXTERNAL DXDT C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. Intrinsic Functions .. INTRINSIC MIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TT(1) = -1.0D0 SAV = -1.0D0 M = 0 DO 10 I = 2,IMAX TT(I) = -1.0D0 + (2.0*(I-1))/IMAX CALL DXDT(TT(I),DT,X) PX = P(X) QX = Q(X) WX = W(X) QQ = DT**2*(EIG*WX-QX)/PX DEN = 3.0*HPI IF (QQ.GT.HPI**2) DEN = 3.0*SQRT(QQ) DELT(I) = 1.0D0/DEN IF (QQ*SAV.LT.0.0D0) THEN M = M + 1 JL(M) = I IF (QQ.LT.0.0D0) JL(M) = -I SAV = -SAV END IF 10 CONTINUE TT(IMAXP) = 1.0D0 DELT(1) = DELT(2) DELT(IMAXP) = DELT(IMAX) DO 30 I = 1,M DO 20 J = 1,8 IJ = J + JL(I) - 6 IF (JL(I).LT.0) IJ = J - JL(I) - 4 IF (IJ.GE.1.AND.IJ.LE.IMAXP) DELT(IJ) = MIN(.033D0,DELT(IJ)) 20 CONTINUE 30 CONTINUE SUM = 0.0D0 DO 40 I = 1,IMAXP SUM = SUM + DELT(I) 40 CONTINUE FACTOR = 5.0/SUM C ------------------------------------------------------ C GENERATE MESH POINTS IN (0,1): C J = 1 T(J) = .001 DO 50 I = 1,IMAX IF (TT(I).LE.T(J) .AND. TT(I+1).GE.T(J)) THEN JJ = I GO TO 60 END IF 50 CONTINUE 60 CONTINUE T1 = T(1) 70 CONTINUE DELL0 = MIN(DELT(JJ),DELT(JJ+1)) DELL = FACTOR*DELL0 80 CONTINUE IF (T1.LE.TT(JJ+1)) T1 = T1 + DELL IF (T1.LE.TT(JJ+1)) THEN J = J + 1 T(J) = T1 IF (J.LE.495) GO TO 80 ELSE IF (T1.GT.TT(JJ+1) .AND. T1.LE.TT(JJ+2)) THEN J = J + 1 T(J) = T1 END IF JJ = JJ + 1 IF (JJ.LT.IMAXP .AND. J.LE.495) GO TO 70 JP = J C ------------------------------------------------------ C GENERATE MESH POINTS IN (-1,0): C J = 1 S(J) = -.001 DO 90 I = 1,IMAX IF (TT(I).LE.S(J) .AND. TT(I+1).GE.S(J)) THEN JJ = I + 1 GO TO 100 END IF 90 CONTINUE 100 CONTINUE S1 = S(J) 110 CONTINUE DELL0 = MIN(DELT(JJ-1),DELT(JJ)) DELL = FACTOR*DELL0 120 CONTINUE IF (S1.GE.TT(JJ-1)) S1 = S1 - DELL IF (S1.GE.TT(JJ-1)) THEN J = J + 1 S(J) = S1 IF (J.LE.495) GO TO 120 ELSE IF (S1.LT.TT(JJ-1) .AND. S1.GE.TT(JJ-2)) THEN J = J + 1 S(J) = S1 END IF JJ = JJ - 1 IF (JJ.GT.1 .AND. J.LE.495) GO TO 110 JM = J C ------------------------------------------------------ DO 130 I = 1,JM TS(I) = S(JM+1-I) 130 CONTINUE DO 140 I = 1,JP TS(JM+I) = T(I) 140 CONTINUE C NN = JM + JP RETURN END SUBROUTINE QPLOT(ISLFUN,XT,NV,PLOTF,NF) INTEGER ISLFUN,NV,NF DOUBLE PRECISION PLOTF(1000,6),XT(1000,2) C ********** C THIS PROGRAM TRIES TO DRAW GRAPHS. C ********** C .. Local Scalars .. INTEGER I,II,IZ,J,K,L,MMAX,NMAX PARAMETER (NMAX = 75, MMAX = 22) DOUBLE PRECISION DZ,REM,X,XK,XKP,XMAX,XMIN,Y,YK,YKP,YMAX,YMIN C .. C .. Local Arrays .. DOUBLE PRECISION A(1000,2) CHARACTER*1 AX(NMAX,MMAX) C .. C .. Intrinsic Functions .. INTRINSIC ABS,INT,MAX,MIN C .. XMAX = -1000000. XMIN = 1000000. YMAX = -1000000. YMIN = 1000000. DZ = YMIN DO 10 I = 1,ISLFUN X = XT(9+I,NV) Y = PLOTF(9+I,NF) XMAX = MAX(XMAX,X) XMIN = MIN(XMIN,X) YMAX = MAX(YMAX,Y) YMIN = MIN(YMIN,Y) A(I,1) = X A(I,2) = Y IF (ABS(Y).LT.DZ) THEN DZ = ABS(Y) IZ = I END IF 10 CONTINUE C IF (YMIN*YMAX.LE.0.0D0) THEN Y = MAX(1.0D0,YMAX-YMIN) ELSE Y = MAX(1.0D0,ABS(YMIN),ABS(YMAX)) END IF DO 20 I = 1,ISLFUN A(I,2) = A(I,2)/Y 20 CONTINUE YMAX = YMAX/Y YMIN = YMIN/Y C DO 30 I = 1,ISLFUN A(I,1) = A(I,1) - XMIN IF (YMIN*YMAX.LE.0.0D0) A(I,2) = A(I,2) - YMIN 30 CONTINUE C C NOW MIN(X) = 0. AND MIN(Y) = 0. C X = XMAX - XMIN DO 40 I = 1,ISLFUN A(I,1) = NMAX*A(I,1)/X A(I,2) = MMAX*A(I,2) 40 CONTINUE C DO 60 J = 1,NMAX DO 50 K = 1,MMAX AX(J,K) = ' ' 50 CONTINUE 60 CONTINUE C DO 80 J = 2,NMAX II = 0 X = J - 0.5 DO 70 I = 1,ISLFUN IF (A(I,1).LE.X) II = I 70 CONTINUE C C LINE PK,PKP IS: Y-YK = (X-XK)*(YKP-YK)/(XKP-XK) C THIS LINE MEETS THE LINE X = J - 0.5 WHERE: C XK = A(II,1) XKP = A(II+1,1) YK = A(II,2) YKP = A(II+1,2) Y = YK + (X-XK)*(YKP-YK)/(XKP-XK) C K = MMAX - INT(Y) REM = Y + (K-MMAX) IF (REM.LE.0.25) THEN AX(J,K) = '_' ELSE IF (REM.LE.0.50) THEN AX(J,K) = '.' ELSE IF (REM.LE.0.75) THEN AX(J,K) = '+' ELSE AX(J,K) = '"' END IF 80 CONTINUE C IF (YMIN*YMAX.LT.0.0D0) THEN L = INT(A(IZ,2)) ELSE IF (YMAX.GT.0.0D0) THEN L = 0 ELSE L = 22 END IF K = MMAX - L DO 90 J = 1,NMAX IF (AX(J,K).EQ.' ') AX(J,K) = '.' 90 CONTINUE WRITE(*,*) DO 100 K = 1,MMAX WRITE(*,'(1X,80A1)') (AX(J,K),J=1,NMAX) 100 CONTINUE RETURN END SUBROUTINE LSTDIR(CHANS,I,ICOL) INTEGER I,ICOL(2) CHARACTER*32 CHANS C .. Local Scalars .. INTEGER J C .. I = 1 DO 10 J = 1,32 IF (CHANS(J:J).EQ.',' .OR. CHANS(J:J).EQ.'/') THEN ICOL(I) = J IF (CHANS(J:J).EQ.'/') THEN CHANS(J:J) = ' ' RETURN END IF I = I + 1 END IF 10 CONTINUE RETURN END CHARACTER*32 FUNCTION FMT2(I1) INTEGER I1 C .. Local Arrays .. CHARACTER*2 COL(32) C .. DATA COL/'01','02','03','04','05','06','07','08','09','10','11', 1 '12','13','14','15','16','17','18','19','20','21','22', 2 '23','24','25','26','27','28','29','30','31','32'/ C FMT2 = '(F'//COL(I1)//'.0,1X,F'//COL(31-I1)//'.0)' RETURN END SHAR_EOF fi # end of overwriting check if test -f 'makepqwd.f' then echo shar: will not over-write existing file "'makepqwd.f'" else cat << SHAR_EOF > 'makepqwd.f' PROGRAM MAKEPQW C C THIS PROGRAM IS DATED AUGUST 11, 1995, AND GENERATES THE FORTRAN C COEFFICIENT FUNCTIONS P(X), Q(X), W(X), AND SUBROUTINE UV WHICH C DEFINES THE BOUNDARY CONDITION FUNCTIONS U(X), V(X) FOR SLEIGN2. C C THE DIFFERENTIAL EQUATION IS OF THE FORM C C -(p*y')' + q*y = lambda*w*y C C .. Local Scalars .. CHARACTER*1 HQ CHARACTER*16 CHANS,TAPE1 CHARACTER*62 STR DOUBLE PRECISION C C .. C .. External Subroutines .. EXTERNAL LC C .. WRITE(*,*) WRITE(*,*) ' HELP may be called at any point where the program ' WRITE(*,*) ' halts and displays (h?) by pressing "h ". ' WRITE(*,*) ' To RETURN from HELP, press "r ". ' WRITE(*,*) ' To QUIT at any program halt, press "q ". ' WRITE(*,*) ' WOULD YOU LIKE AN OVERVIEW OF HELP ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(1) END IF C 100 CONTINUE WRITE(*,*) ' SPECIFY OUTPUT FILE NAME (h?) ' READ(*,16) CHANS IF (CHANS.EQ.'q' .OR. CHANS.EQ.'Q') THEN STOP ELSE IF (CHANS.EQ.'h' .OR. CHANS.EQ.'H') THEN CALL HELP(2) GO TO 100 ELSE TAPE1 = CHANS END IF OPEN(1,FILE=TAPE1,STATUS='NEW') WRITE(1,'(A)') 'C' WRITE(1,'(A)') 'C ' // TAPE1 C WRITE(*,*) ' THE DIFFERENTIAL EQUATION IS OF THE FORM: ' WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y ' WRITE(*,*) C 200 CONTINUE WRITE(*,*) ' INPUT (h?) p = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 200 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION P(X)' WRITE(1,'(A)') ' DOUBLE PRECISION P,X' WRITE(1,'(A)') ' P = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 300 CONTINUE WRITE(*,*) ' INPUT (h?) q = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 300 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION Q(X)' WRITE(1,'(A)') ' DOUBLE PRECISION Q,X' WRITE(1,'(A)') ' Q = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 400 CONTINUE WRITE(*,*) ' INPUT (h?) w = ' READ(*,62) STR HQ = STR IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(3) GO TO 400 ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' FUNCTION W(X)' WRITE(1,'(A)') ' DOUBLE PRECISION W,X' WRITE(1,'(A)') ' W = ' // STR WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' END IF C 500 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON END-POINT ' WRITE(*,*) ' CLASSIFICATION ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(4) GO TO 500 ELSE IF (HQ.EQ.'e' .OR. HQ.EQ.'E') THEN GO TO 800 ELSE END IF C 600 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON DEFAULT CLASSIFI-' WRITE(*,*) ' CATION AND BOUNDARY CONDITIONS ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(5) GO TO 600 ELSE END IF C 700 CONTINUE WRITE(*,*) ' DO YOU REQUIRE INFORMATION ON LIMIT CIRCLE ' WRITE(*,*) ' BOUNDARY CONDITIONS ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y' .OR. 1 HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 700 ELSE END IF C 800 CONTINUE WRITE(*,*) ' DO YOU WANT TO USE A LIMIT CIRCLE ' WRITE(*,*) ' BOUNDARY CONDITION ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 800 ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y') THEN WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE UV(X,U,PUP,V,PVP,HU,HV)' WRITE(1,'(A)') ' DOUBLE PRECISION X,U,PUP,V,PVP,HU,HV' 900 CONTINUE WRITE(*,*) ' DO YOU WANT TO USE TWO DIFFERENT PAIRS OF ' WRITE(*,*) ' FUNCTIONS U(X),V(X) ? (Y/N) (h?) ' READ(*,1) HQ IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 900 ELSE IF (HQ.EQ.'y' .OR. HQ.EQ.'Y') THEN 1000 CONTINUE WRITE(*,*) ' ASSUMING THAT ONE PAIR OF FUNCTIONS ' WRITE(*,*) ' U(X),V(X) IS FOR a < X < c, AND ' WRITE(*,*) ' THE OTHER PAIR IS FOR c <= X < b, ' WRITE(*,*) ' WHAT IS THE VALUE OF c ? (h?) ' WRITE(*,*) WRITE(*,*) ' c = ' READ(*,16) CHANS HQ = CHANS IF (HQ.EQ.'q' .OR. HQ.EQ.'Q') THEN STOP ELSE IF (HQ.EQ.'h' .OR. HQ.EQ.'H') THEN CALL HELP(6) GO TO 1000 ELSE READ(CHANS,'(F16.0)') C END IF WRITE(*,*) WRITE(*,*) ' FOR a < X < c :' WRITE(*,*) WRITE(1,'(A,1PE12.5,A)') ' IF (X.LT.',C,') THEN' CALL LC(9) WRITE(*,*) WRITE(*,*) ' FOR c <= X < b :' WRITE(*,*) WRITE(1,'(A)') ' ELSE' CALL LC(9) WRITE(1,'(A)') ' END IF' ELSE WRITE(*,*) CALL LC(6) END IF ELSE WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE UV' END IF WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' C WRITE(1,'(A)') 'C' WRITE(1,'(A)') ' SUBROUTINE EXAMP' WRITE(1,'(A)') ' RETURN' WRITE(1,'(A)') ' END' CLOSE(1) STOP 1 FORMAT(A1) 16 FORMAT(A16) 62 FORMAT(A62) END C SUBROUTINE LC(INDENT) INTEGER INDENT C .. Local Scalars .. CHARACTER*57 STR C .. IF (INDENT.EQ.6) THEN WRITE(*,*) ' INPUT u = ' READ(*,57) STR WRITE(1,'(A)') ' U = ' // STR WRITE(*,*) ' INPUT v = ' READ(*,57) STR WRITE(1,'(A)') ' V = ' // STR WRITE(*,*) ' INPUT pu'' = ' READ(*,57) STR WRITE(1,'(A)') ' PUP = ' // STR WRITE(*,*) ' INPUT pv'' = ' READ(*,57) STR WRITE(1,'(A)') ' PVP = ' // STR WRITE(*,*) ' INPUT -(pu'')'' + q*u = ' READ(*,57) STR WRITE(1,'(A)') ' HU = ' // STR WRITE(*,*) ' INPUT -(pv'')'' + q*v = ' READ(*,57) STR WRITE(1,'(A)') ' HV = ' // STR ELSE WRITE(*,*) ' INPUT u = ' READ(*,57) STR WRITE(1,'(A)') ' U = ' // STR WRITE(*,*) ' INPUT v = ' READ(*,57) STR WRITE(1,'(A)') ' V = ' // STR WRITE(*,*) ' INPUT pu'' = ' READ(*,57) STR WRITE(1,'(A)') ' PUP = ' // STR WRITE(*,*) ' INPUT pv'' = ' READ(*,57) STR WRITE(1,'(A)') ' PVP = ' // STR WRITE(*,*) ' INPUT -(pu'')'' + q*u = ' READ(*,57) STR WRITE(1,'(A)') ' HU = ' // STR WRITE(*,*) ' INPUT -(pv'')'' + q*v = ' READ(*,57) STR WRITE(1,'(A)') ' HV = ' // STR END IF RETURN 57 FORMAT(A57) END c subroutine help(nh) integer i,n,nh character*36 x(23),y(23) character*1 ans c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),NH c 1 CONTINUE write(*,*) 'H1: Overview of HELP.' x(1)=' This ASCII text file is supplied a' y(1)='s a separate file with the SLEIGN2 ' x(2)='package; it can be accessed on-line ' y(2)='in both MAKEPQW (if used) and DRIVE.' x(3)=' HELP contains information to aid t' y(3)='he user in entering data on the ' x(4)='coefficient functions p,q,w; on the ' y(4)='limit circle boundary condition ' x(5)='functions u,v; on the end-point clas' y(5)='sifications of the differential ' x(6)='equation; on DEFAULT entry; on eigen' y(6)='value indexes; on IFLAG information;' x(7)='and on the general use of the progra' y(7)='m SLEIGN2. ' x(8)=' The 17 sections of HELP are: ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' H1: Overview of HELP. ' y(10)=' ' x(11)=' H2: File name entry. ' y(11)=' ' x(12)=' H3: The differential equation. ' y(12)=' ' x(13)=' H4: End-point classification. ' y(13)=' ' x(14)=' H5: DEFAULT entry. ' y(14)=' ' x(15)=' H6: Limit-circle boundary condit' y(15)='ions. ' do 101 i = 1,15 write(*,*) x(i),y(i) 101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' H7: General boundary conditions.' y(1)=' ' x(2)=' H8: Recording the results. ' y(2)=' ' x(3)=' H9: Type and choice of interval.' y(3)=' ' x(4)=' H10: Entry of end-points. ' y(4)=' ' x(5)=' H11: End-point values of p,q,w. ' y(5)=' ' x(6)=' H12: Initial value problems. ' y(6)=' ' x(7)=' H13: Indexing of eigenvalues. ' y(7)=' ' x(8)=' H14: Entry of eigenvalue index, i' y(8)='nitial guess, and tolerance. ' x(9)=' H15: IFLAG information. ' y(9)=' ' x(10)=' H16: Plotting. ' y(10)=' ' x(11)=' H17: Indexing of eigenvalues for ' y(11)='periodic-type problems. ' x(12)=' ' y(12)=' ' x(13)=' HELP can be accessed at each point' y(13)=' in MAKEPQW and DRIVE where the user' x(14)='is asked for input, by pressing "h <' y(14)='ENTER>"; this places the user at the' x(15)='appropriate HELP section. Once in H' y(15)='ELP, the user can scroll the further' x(16)='HELP sections by repeatedly pressing' y(16)=' "h ", or jump to a specific ' x(17)='HELP section Hn (n=1,2,...17) by typ' y(17)='ing "Hn "; to return to the ' x(18)='place in the program from which HELP' y(18)=' is called, press "r ". ' do 102 i = 1,18 write(*,*) x(i),y(i) 102 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 2 CONTINUE write(*,*) 'H2: File name entry.' x(1)=' MAKEPQW is used to create a FORTRA' y(1)='N file containing the coefficients ' x(2)='p(x),q(x),w(x), defining the differe' y(2)='ntial equation, and the boundary ' x(3)='condition functions u(x),v(x) if req' y(3)='uired. The file must be given a NEW' x(4)='filename which is acceptable to your' y(4)=' FORTRAN compiler. For example, it ' x(5)='might be called bessel.f or bessel.f' y(5)='or depending upon your compiler. ' x(6)=' The same naming considerations app' y(6)='ly if the FORTRAN file is prepared ' x(7)='other than with the use of MAKEPQW. ' y(7)=' ' do 201 i = 1,7 write(*,*) x(i),y(i) 201 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 3 CONTINUE write(*,*) 'H3: The differential equation.' x(1)=' The prompt "Input p (or q or w) ="' y(1)=' requests you to type in a FORTRAN ' x(2)='expression defining the function p(x' y(2)='), which is one of the three coeffi-' x(3)='cient functions defining the Sturm-L' y(3)='iouville differential equation ' x(4)=' ' y(4)=' ' x(5)=' -(p*y'')'' + q*y = ' y(5)=' lambda*w*y (*) ' x(6)=' ' y(6)=' ' x(7)='to be considered on some interval (a' y(7)=',b) of the real line. The actual ' x(8)='interval used in a particular proble' y(8)='m can be chosen later, and may be ' x(9)='either the whole interval (a,b) wher' y(9)='e the coefficient functions p,q,w, ' x(10)='etc. are defined or any sub-interval' y(10)=' (a'',b'') of (a,b); a = -infinity ' x(11)='and/or b = +infinity are allowable c' y(11)='hoices for the end-points. ' x(12)=' The coefficient functions p,q,w of' y(12)=' the differential equation may be ' x(13)='chosen arbitrarily but must satisfy ' y(13)='the following conditions: ' x(14)=' (1) p,q,w are real-valued througho' y(14)='ut (a,b). ' x(15)=' (2) p,q,w are piece-wise continuou' y(15)='s and defined throughout the ' x(16)=' interior of the interval (a,b)' y(16)='. ' x(17)=' (3) p and w are strictly positive ' y(17)='in (a,b). ' x(18)=' For better error analysis in the n' y(18)='umerical procedures, condition ' x(19)='(2) above is often replaced with ' y(19)=' ' x(20)=' (2'') p,q,w are four times continuo' y(20)='usly differentiable on (a,b). ' x(21)=' The behavior of p,q,w near the end' y(21)='-points a and b is critical to the ' x(22)='classification of the differential e' y(22)='quation (see H4 and H11). ' do 301 i = 1,22 write(*,*) x(i),y(i) 301 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 4 CONTINUE write(*,*) 'H4: End-point classification.' x(1)=' The correct classification of the ' y(1)='end-points a and b is essential to ' x(2)='the working of the SLEIGN2 program. ' y(2)=' To classify the end-points, it is ' x(3)='convenient to choose a point c in (a' y(3)=',b); i.e., a < c < b. Subject to ' x(4)='the general conditions on the coeffi' y(4)='cient functions p,q,w (see H3): ' x(5)=' (1) a is REGULAR (say R) if -infin' y(5)='ity < a, p,q,w are piece-wise ' x(6)=' continuous on [a,c], and p(a) ' y(6)='> 0 and w(a) > 0. ' x(7)=' (2) a is WEAKLY REGULAR (say WR) i' y(7)='f -infinity < a, a is not R, and ' x(8)=' |c ' y(8)=' ' x(9)=' integral | {1/p+|q|+w} < +infi' y(9)='nity. ' x(10)=' |a ' y(10)=' ' x(11)=' ' y(11)=' ' x(12)=' If end-point a is neither R nor ' y(12)='WR, then a is SINGULAR; that is, ' x(13)=' either -infinity = a, or -infinity' y(13)=' < a and ' x(14)=' |c ' y(14)=' ' x(15)=' integral | {1/p+|q|+w} = +infi' y(15)='nity. ' x(16)=' |a ' y(16)=' ' x(17)=' (3) The SINGULAR end-point a is LI' y(17)='MIT-CIRCLE NON-OSCILLATORY (say ' x(18)=' LCNO) if for some real lambda ' y(18)='ALL real-valued solutions y of the ' x(19)=' differential equation ' y(19)=' ' x(20)=' ' y(20)=' ' x(21)=' -(p*y'')'' + q*y = ' y(21)=' lambda*w*y on (a,c] (*) ' x(22)=' ' y(22)=' ' x(23)=' satisfy the conditions: ' y(23)=' ' do 401 i = 1,23 write(*,*) x(i),y(i) 401 continue read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' |c ' y(1)=' ' x(2)=' integral | { w*y*y } < +infini' y(2)='ty, and ' x(3)=' |a ' y(3)=' ' x(4)=' y has at most a finite number ' y(4)='of zeros in (a,c]. ' x(5)=' (4) The SINGULAR end-point a is LI' y(5)='MIT-CIRCLE OSCILLATORY (say LCO) if ' x(6)='for some real lambda ALL real-valued' y(6)=' solutions of the differential ' x(7)='equation (*) satisfy the conditions:' y(7)=' ' x(8)=' |c ' y(8)=' ' x(9)=' integral | { w*y*y } < +infini' y(9)='ty, and ' x(10)=' |a ' y(10)=' ' x(11)=' y has an infinite number of ze' y(11)='ros in (a,c]. ' x(12)=' (5) The SINGULAR end-point a is LI' y(12)='MIT POINT (say LP) if for some real ' x(13)='lambda at least one solution of the ' y(13)='differential equation (*) satisfies ' x(14)='the condition: ' y(14)=' ' x(15)=' |c ' y(15)=' ' x(16)=' integral | {w*y*y} = +infinity' y(16)='. ' x(17)=' |a ' y(17)=' ' x(18)=' There is a similar classification ' y(18)='of the end-point b into one of the ' x(19)='five distinct cases R, WR, LCNO, LCO' y(19)=', LP. ' do 402 i = 1,19 write(*,*) x(i),y(i) 402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Although the classification of sin' y(1)='gular end-points invokes a real ' x(2)='value of the parameter lambda, this ' y(2)='classification is invariant in ' x(3)='lambda; all real choices of lambda l' y(3)='ead to the same classification. ' x(4)=' In determining the classification ' y(4)='of singular end-points for the ' x(5)='differential equation (*), it is oft' y(5)='en convenient to start with the ' x(6)='choice lambda = 0 in attempting to f' y(6)='ind solutions (particularly when ' x(7)='q = 0 on (a,b)); however, see exampl' y(7)='e 7 below. ' x(8)=' See H6 on the use of maximal domai' y(8)='n functions to determine the ' x(9)='classification at singular end-point' y(9)='s. ' do 403 i = 1,9 write(*,*) x(i),y(i) 403 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' EXAMPLES: ' x(1)=' 1. -y'''' = lambda*y is R at both en' y(1)='d-points of (a,b) when a and b are ' x(2)=' finite. ' y(2)=' ' x(3)=' 2. -y'''' = lambda*y on (-infinity,i' y(3)='nfinity) is LP at both end-points. ' x(4)=' 3. -(sqrt(x)*y''(x))'' = lambda*(1./' y(4)='sqrt(x))*y(x) on (0,infinity) is ' x(5)=' WR at 0 and LP at +infinity (ta' y(5)='ke lambda = 0 in (*)). See ' x(6)=' examples.f, #10 (Weakly Regular' y(6)='). ' x(7)=' 4. -((1-x*x)*y''(x))'' = lambda*y(x)' y(7)=' on (-1,1) is LCNO at both ends ' x(8)=' (take lambda = 0 in (*)). See ' y(8)='xamples.f, #1 (Legendre). ' x(9)=' 5. -y''''(x) + C*(1/(x*x))*y(x) = la' y(9)='mbda*y(x) on (0,infinity) is LP at ' x(10)=' infinity and at 0 is (take lamb' y(10)='da = 0 in (*)): ' x(11)=' LP for C .ge. 3/4 ; ' y(11)=' ' x(12)=' LCNO for -1/4 .le. C .lt. 3/4' y(12)=' (but C .ne. 0); ' x(13)=' LCO for C .lt. -1/4. ' y(13)=' ' x(14)=' 6. -(x*y''(x))'' - (1/x)*y(x) = lamb' y(14)='da*y(x) on (0,infinity) is LCO at 0 ' x(15)=' and LP at +infinity (take lambd' y(15)='a = 0 in (*) with solutions ' x(16)=' cos(ln(x)) and sin(ln(x))). Se' y(16)='e xamples.f, #7 (BEZ). ' x(17)=' 7. -(x*y''(x))'' - x*y(x) = lambda*(' y(17)='1/x)*y(x) on (0,infinity) is LP at 0' x(18)=' and LCO at infinity (take lambd' y(18)='a = -1/4 in (*) with solutions ' x(19)=' cos(x)/sqrt(x) and sin(x)/sqrt(' y(19)='x)). See xamples.f, ' x(20)=' #6 (Sears-Titchmarsh). ' y(20)=' ' do 404 i = 1,20 write(*,*) x(i),y(i) 404 continue write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 5 CONTINUE write(*,*) 'H5: DEFAULT entry.' x(1)=' The complete range of problems for' y(1)=' which SLEIGN2 is applicable can ' x(2)='only be reached by appropriate entri' y(2)='es under end-point classification ' x(3)='and boundary conditions. However, t' y(3)='here is a DEFAULT application which ' x(4)='requires no detailed entry of end-po' y(4)='int classification or boundary ' x(5)='conditions, subject to: ' y(5)=' ' x(6)=' 1) The DEFAULT application CANNOT ' y(6)='be used at a LCO end-point. ' x(7)=' 2) If an end-point a is R, then th' y(7)='e Dirichlet boundary condition ' x(8)=' y(a) = 0 is automatically used.' y(8)=' ' x(9)=' 3) If an end-point a is WR, then t' y(9)='he following boundary condition ' x(10)=' is automatically applied: ' y(10)=' ' x(11)=' if p(a) = 0, and both q(a),w(' y(11)='a) are bounded, then the Dirichlet ' x(12)=' boundary condition y(a) = 0 i' y(12)='s used, or ' x(13)=' if p(a) > 0, and q(a) and/or ' y(13)='w(a)) are not bounded, then the ' x(14)=' Neumann boundary condition (p' y(14)='y'')(a) = 0 is used. ' x(15)=' If p(a) = 0, and q(a) and/or w(' y(15)='a) are not bounded, then no reliable' x(16)=' information can be given on the' y(16)=' DEFAULT boundary condition. ' x(17)=' 4) If an end-point is LCNO, then i' y(17)='n most cases the principal or ' x(18)=' Friedrichs boundary condition i' y(18)='s applied (see H6). ' x(19)=' 5) If an end-point is LP, then the' y(19)=' normal LP procedure is applied ' x(20)=' (see H7(1.)). ' y(20)=' ' x(21)='If you choose the DEFAULT condition,' y(21)=' then no entry is required for the ' x(22)='u,v boundary condition functions. ' y(22)=' ' do 501 i = 1,22 write(*,*) x(i),y(i) 501 continue write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 6 CONTINUE write(*,*) 'H6: Limit-circle boundary conditions.' x(1)=' At an end-point a, the limit-circl' y(1)='e type separated boundary condition ' x(2)='is of the form (similar remarks thro' y(2)='ughout apply to the end-point b) ' x(3)=' ' y(3)=' ' x(4)=' A1*[y,u](a) + A2*[y,v](a) = 0' y(4)=', (**) ' x(5)=' ' y(5)=' ' x(6)='where y is a solution of the differe' y(6)='ntial equation ' x(7)=' ' y(7)=' ' x(8)=' -(p*y'')'' + q*y = lambda*w*y on' y(8)=' (a,b). (*) ' x(9)=' ' y(9)=' ' x(10)='Here A1, A2 are real numbers; u and ' y(10)='v are boundary condition functions; ' x(11)='and for real-valued y and u the form' y(11)=' [y,u] is defined by ' x(12)=' ' y(12)=' ' x(13)=' [y,u](x) = y(x)*(pu'')(x) - u(x' y(13)=')*(py'')(x) for x in (a,b). ' x(14)=' ' y(14)=' ' x(15)=' The object of this section is to p' y(15)='rovide help in choosing appropriate ' x(16)='functions u and v in (**), given the' y(16)=' differential equation (*). Full ' x(17)='details of the boundary conditions f' y(17)='or (*) are discussed in H7; here it ' x(18)='is sufficient to say that the limit-' y(18)='circle type boundary condition (**) ' x(19)='can be applied at any end-point in t' y(19)='he LCNO, LCO classification, but ' x(20)='also in the R, WR classification sub' y(20)='ject to the appropriate choice of ' x(21)='u and v. ' y(21)=' ' do 601 i = 1,21 write(*,*) x(i),y(i) 601 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' Let (*) be R, WR, LCNO, or LCO at ' y(1)='end-point a and choose c in (a,b). ' x(2)='Then either ' y(2)=' ' x(3)=' u and v are a pair of linearly i' y(3)='ndependent solutions of (*) on (a,c]' x(4)=' for any chosen real values of lamb' y(4)='da, or ' x(5)=' u and v are a pair of real-value' y(5)='d maximal domain functions defined ' x(6)=' on (a,c] satisfying [u,v](a) .ne. ' y(6)='0. The maximal domain D(a,c] is ' x(7)=' defined by ' y(7)=' ' x(8)=' ' y(8)=' ' x(9)=' D(a,c] = {f:(a,c]->R:: f,pf'' ' y(9)='in AC(a,c]; ' x(10)=' f, ((-pf'')''+qf)/w' y(10)=' in L2((a,c;w)} ' x(11)=' ' y(11)=' ' x(12)=' It is known that for all f,g in D(' y(12)='a,c] the limit ' x(13)=' ' y(13)=' ' x(14)=' [f,g](a) = lim[f,g](x) as x->' y(14)='a ' x(15)=' ' y(15)=' ' x(16)=' exists and is finite. If (*) is L' y(16)='CNO or LCO at a, then all solutions ' x(17)=' of (*) belong to D(a,c] for all va' y(17)='lues of lambda. ' do 602 i = 1,17 write(*,*) x(i),y(i) 602 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' The boundary condition (**) is ess' y(1)='ential in the LCNO and LCO cases but' x(2)='can also be used with advantage in s' y(2)='ome R and WR cases. In the R, WR, ' x(3)='and LCNO cases, but not in the LCO c' y(3)='ase, the boundary condition ' x(4)='functions can always be chosen so th' y(4)='at ' x(5)=' lim u(x)/v(x) = 0 as x->a, ' y(5)=' ' x(6)='and it is recommended that this norm' y(6)='alisation be effected; this has been' x(7)='done in the examples given below. In' y(7)=' this case, the boundary condition ' x(8)='[y,u](a) = 0 (i.e., A1 = 1, A2 = 0 i' y(8)='n (**)) is called the principal or ' x(9)='Friedrichs boundary condition. ' y(9)=' ' x(10)=' ' y(10)=' ' x(11)=' In the case when end-points a and ' y(11)='b are, independently, in R, WR, ' x(12)='LCNO, or LCO classification, it may ' y(12)='be that symmetry or other reasons ' x(13)='permit one set of boundary condition' y(13)=' functions to be used at both end- ' x(14)='points (see xamples.f, #1 (Legendre)' y(14)='). In other cases, different pairs ' x(15)='must be chosen for each end-point (s' y(15)='ee xamples.f: #16 (Jacobi), ' x(16)='#18 (Dunsch), and #19 (Donsch)). ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' Note that a solution pair u,v is a' y(18)='lways a maximal domain pair, but not' x(19)='necessarily vice versa. ' y(19)=' ' do 603 i = 1,19 write(*,*) x(i),y(i) 603 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' EXAMPLES: ' y(1)=' ' x(2)='1. -y''''(x) = lambda*y(x) on [0,pi] i' y(2)='s R at 0 and R at pi. ' x(3)=' At 0, with lambda = 0, a solution' y(3)=' pair is u(x) = x, v(x) = 1. ' x(4)=' At pi, with lambda = 1, a solutio' y(4)='n pair is ' x(5)=' u(x) = sin(x), v(x) = cos(x). ' y(5) =' ' x(6)='2. -(sqrt(x)*y''(x))'' = lambda*y(x)/s' y(6)='qrt(x) on (0,1] is ' x(7)=' WR at 0 and R at 1. ' y(7)=' ' x(8)=' (The general solutions of this eq' y(8)='uation are ' x(9)=' u(x) = cos(2*sqrt(x*lambda)), v' y(9)='(x) = sin(2*sqrt(x*lambda)).) ' x(10)=' At 0, with lambda = 0, a solution' y(10)=' pair is ' x(11)=' u(x) = 2*sqrt(x), v(x) = 1. ' y(11)=' ' x(12)=' At 1, with lambda = pi*pi/4, a so' y(12)='lution pair is ' x(13)=' u(x) = sin(pi*sqrt(x)), v(x) = ' y(13)='cos(pi*sqrt(x)). ' x(14)=' At 1, with lambda = 0, a solution' y(14)=' pair is ' x(15)=' u(x) = 2*(1-sqrt(x)), v(x) = 1.' y(15)=' ' x(16)=' See also xamples.f, #10 (Weakly R' y(16)='egular). ' x(17)='3. -((1-x*x)*y''(x))'' = lambda*y(x) o' y(17)='n (-1,1) is LCNO at both ends. ' x(18)=' At +-1, with lambda = 0, a soluti' y(18)='on pair is ' x(19)=' u(x) = 1, v(x) = 0.5*log((1+x)/' y(19)='(1-x)). ' x(20)=' At 1, a maximal domain pair is u(' y(20)='x) = 1, v(x) = log(1-x) ' x(21)=' At -1, a maximal domain pair is u' y(21)='(x) = 1, v(x) = log(1+x). ' x(22)=' See also xamples.f, #1 (Legendre)' y(22)='. ' do 604 i = 1,22 write(*,*) x(i),y(i) 604 continue write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)='4. -y''''(x) - (1/(4x*x))*y(x) = lambd' y(1)='a*y(x) on (0,infinity) is ' x(2)=' LCNO at 0 and LP at +infinity. ' y(2)=' ' x(3)=' At 0, a maximal domain pair is ' y(3)=' ' x(4)=' u(x) = sqrt(x), v(x) = sqrt(x)*' y(4)='log(x). ' x(5)=' See also xamples.f, #2 (Bessel). ' y(5)=' ' x(6)='5. -y''''(x) - 5*(1/(4*x*x))*y(x) = la' y(6)='mbda*y(x) on (0,infinity) is ' x(7)=' LCO at 0 and LP at +infinity. ' y(7)=' ' x(8)=' At 0, with lambda = 0, a solution' y(8)=' pair is ' x(9)=' u(x) = sqrt(x)*cos(log(x)), v(x' y(9)=') = sqrt(x)*sin(log(x)) ' x(10)=' See also xamples.f, #20 (Krall). ' y(10)=' ' x(11)='6. -y''''(x) - (1/x)*y(x) = lambda*y(x' y(11)=') on (0,infinity) is ' x(12)=' LCNO at 0 and LP at +infinity.' y(12)=' ' x(13)=' At 0, a maximal domain pair is ' y(13)=' ' x(14)=' u(x) = x, v(x) = 1 -x*log(x). ' y(14)=' ' x(15)=' See also xamples.f, #4(Boyd). ' y(15)=' ' x(16)='7. -((1/x)*y''(x))'' + (k/(x*x) + k*k/' y(16)='x)*y(x) = lambda*y(x) on (0,1], ' x(17)=' with k real and .ne. 0, is LCNO' y(17)=' at 0 and R at 1. ' x(18)=' At 0, a maximal domain pair is ' y(18)=' ' x(19)=' u(x) = x*x, v(x) = x - 1/k. ' y(19)=' ' x(20)=' See also xamples.f, #8 (Laplace T' y(20)='idal Wave). ' do 605 i = 1,20 write(*,*) x(i),y(i) 605 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 7 CONTINUE write(*,*) 'H7: General boundary conditions.' x(1)=' Boundary conditions for Sturm-Liou' y(1)='ville boundary value problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='on an interval (a,b) are either ' y(5)=' ' x(6)=' SEPARATED, with at most one cond' y(6)='ition at end-point a and at most ' x(7)=' one condition at end-point b, or ' y(7)=' ' x(8)=' COUPLED, when both a and b are, ' y(8)='independently, in one of the end- ' x(9)=' point classifications R, WR, LCNO,' y(9)=' LCO, in which case two independent ' x(10)=' ent boundary conditions are requir' y(10)='ed which link the solution values ' x(11)=' near a to those near b. ' y(11)=' ' x(12)='The SLEIGN2 program allows for all s' y(12)='eparated conditions; and special ' x(13)='cases of the coupled conditions -- t' y(13)='he so-called periodic boundary ' x(14)='conditions applicable only when the ' y(14)='interval (a,b) is finite and both ' x(15)='a and b are R. ' y(15)=' ' do 701 i = 1,15 write(*,*) x(i),y(i) 701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N write(*,*) ' Separated Conditions: ' write(*,*) ' --------------------- ' x(1)=' The boundary conditions to be sele' y(1)='cted depend upon the classification ' x(2)='of the differential equation at the ' y(2)='end-point, say, a: ' x(3)=' 1. If the end-point a is LP, the' y(3)='n no boundary condition is required ' x(4)=' or allowed. ' y(4)=' ' x(5)=' 2. If the end-point a is R or WR' y(5)=', then a separated boundary ' x(6)=' condition is of the form ' y(6)=' ' x(7)=' A1*y(a) + A2*(py'')(a) = 0,' y(7)=' ' x(8)=' where A1, A2 are real constants yo' y(8)='u must choose, not both zero. ' x(9)=' 3. If the end-point a is LCNO or' y(9)=' LCO, then a separated boundary ' x(10)=' condition is of the form ' y(10)=' ' x(11)=' A1*[y,u](a) + A2*[y,v](a) =' y(11)=' 0, ' x(12)=' where A1, A2 are real constants yo' y(12)='u must choose, not both zero; ' x(13)=' here, u,v are the pair of boundary' y(13)=' condition functions you have ' x(14)=' previously selected when the input' y(14)=' FORTRAN file was being prepared. ' x(15)=' 4. If the end-point a is LCNO an' y(15)='d the boundary condition pair ' x(16)=' u,v has been chosen so that ' y(16)=' ' x(17)=' lim u(x)/v(x) = 0 as x->a ' y(17)=' ' x(18)=' (which is always possible), then A' y(18)='1 = 1, A2 = 0 (i.e., [y,u](a) = 0) ' x(19)=' gives the principal (Friedrichs) b' y(19)='oundary condition at a. ' do 702 i = 1,19 write(*,*) x(i),y(i) 702 continue write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 5. If a is R or WR and boundary ' y(1)='condition functions u,v have been ' x(2)=' entered in the FORTRAN input file,' y(2)=' then (3.,4.) above apply to ' x(3)=' entering separated boundary condit' y(3)='ions at such an end-point; the ' x(4)=' boundary conditions in this form a' y(4)='re equivalent to the point-wise ' x(5)=' conditions in (2.) (subject to car' y(5)='e in choosing A1, A2). This ' x(6)=' singular form of a regular boundar' y(6)='y condition may be particularly ' x(7)=' effective in the WR case if the bo' y(7)='undary condition form in (2.) leads ' x(8)=' to numerical difficulties. ' y(8)=' ' x(9)=' ' y(9)=' ' x(10)=' Conditions (2.,3.,4.,5.) apply sim' y(10)='ilarly at end-point b. ' x(11)=' ' y(11)=' ' x(12)=' 6. If a is R, WR, LCNO, or LCO a' y(12)='nd b is LP, then only a separated ' x(13)=' condition at a is required and all' y(13)='owed (or instead at b if a and b ' x(14)=' are interchanged). ' y(14)=' ' x(15)=' 7. If both end-points a and b ar' y(15)='e LP, then no boundary conditions ' x(16)=' are required or allowed. ' y(16)=' ' x(17)=' ' y(17)=' ' x(18)=' The indexing of eigenvalues for bo' y(18)='undary value problems with separated' x(19)=' conditions is discussed in H13. ' y(19)=' ' do 703 i = 1,19 write(*,*) x(i),y(i) 703 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),n write(*,*) ' Coupled Conditions: ' write(*,*) ' ------------------- ' x(1)=' 8. Periodic-type boundary condit' y(1)='ions on (a,b) apply only when ' x(2)=' both end-points a and b are R; the' y(2)='se conditions are of the form ' x(3)=' ' y(3)=' ' x(4)=' y(b) = c*y(a), (py'')(b) = (' y(4)='py'')(a)/c, ' x(5)=' ' y(5)=' ' x(6)=' where c may be chosen to be any re' y(6)='al number not equal to 0. The case ' x(7)=' c = 1 is called periodic, the case' y(7)=' c = -1 is called semi-periodic. ' x(8)=' ' y(8)=' ' x(9)=' The indexing of eigenvalues for pe' y(9)='riodic-type boundary conditions is ' x(10)=' discussed in H17. ' y(10)=' ' do 704 i = 1,10 write(*,*) x(i),y(i) 704 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 8 CONTINUE write(*,*) 'H8: Recording the results.' x(1)=' If you choose to have a record kep' y(1)='t of the results, then the following' x(2)='information is stored in a file with' y(2)=' the name you select: ' x(3)=' ' y(3)=' ' x(4)=' 1. The file name. ' y(4)=' ' x(5)=' 2. The header line prompted for (u' y(5)='p to 32 characters of your choice). ' x(6)=' 3. The interval (a,b) which was us' y(6)='ed. ' x(7)=' ' y(7)=' ' x(8)=' For SEPARATED boundary conditions:' y(8)=' ' x(9)=' 4. The end-point classification. ' y(9)=' ' x(10)=' 5. A summary of coefficient inform' y(10)='ation at WR, LCNO, LCO end-points. ' x(11)=' 6. The boundary condition constant' y(11)='s (A1,A2), (B1,B2) if entered. ' x(12)=' 7. (NUMEIG,EIG,TOL) or (NUMEIG1,NU' y(12)='MEIG2,TOL), as entered. ' x(13)=' ' y(13)=' ' x(14)=' For COUPLED boundary conditions: ' y(14)=' ' x(15)=' 8. The boundary condition paramete' y(15)='r, c. ' x(16)=' ' y(16)=' ' x(17)=' For ALL boundary conditions: ' y(17)=' ' x(18)=' 9. The computed eigenvalue, EIG, a' y(18)='nd its estimated accuracy, TOL. ' x(19)=' 10. IFLAG reported (see H15). ' y(19)=' ' do 801 i = 1,19 write(*,*) x(i),y(i) 801 continue write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 9 CONTINUE write(*,*) 'H9: Type and choice of interval.' x(1)=' You may enter any interval (a,b) f' y(1)='or which the coefficients p,q,w are ' x(2)='well defined by your FORTRAN stateme' y(2)='nts in the input file, provided that' x(3)='(a,b) contains no interior singulari' y(3)='ities. ' do 901 i = 1,3 write(*,*) x(i),y(i) 901 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 10 CONTINUE write(*,*) 'H10: Entry of end-points.' x(1)=' End-points a and b must be entered' y(1)=' as real numbers. There is no ' x(2)='symbolic entry; e.g., pi must be ent' y(2)='ered as 3.14159... to an appropriate' x(3)='number of decimal places. ' y(3)=' ' do 1001 i = 1,3 write(*,*) x(i),y(i) 1001 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 11 CONTINUE write(*,*) 'H11: End-point values of p,q,w.' x(1)=' The program SLEIGN2 needs to know ' y(1)='whether the coefficient functions ' x(2)='p(x),q(x),w(x) defined by the FORTRA' y(2)='N expressions entered in the input ' x(3)='file can be evaluated numerically wi' y(3)='thout running into difficulty. If, ' x(4)='for example, either q or w is unboun' y(4)='ded at a, or p(a) is 0, then SLEIGN2' x(5)='needs to know this so that a is not ' y(5)='chosen for functional evaluation. ' do 1101 i = 1,5 write(*,*) x(i),y(i) 1101 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 12 CONTINUE write(*,*) 'H12: Initial value problems.' x(1)=' The initial value problem facility' y(1)=' for Sturm-Liouville problems ' x(2)=' ' y(2)=' ' x(3)=' -(p*y'')'' + q*y = ' y(3)=' lambda*w*y (*) ' x(4)=' ' y(4)=' ' x(5)='allows for the computation of a solu' y(5)='tion of (*) with a user-chosen ' x(6)='value lambda and any one of the foll' y(6)='owing initial conditions: ' x(7)=' 1. From end-point a of any classif' y(7)='ication except LP towards ' x(8)='end-point b of any classification, ' y(8)=' ' x(9)=' 2. From end-point b of any classif' y(9)='ication except LP back towards ' x(10)='end-point a of any classification, ' y(10)=' ' x(11)=' 3. From end-points a and b of any ' y(11)='classifications except LP towards an' x(12)='interior point of (a,b) selected by ' y(12)='the program. ' x(13)=' ' y(13)=' ' x(14)=' Initial values at a are of the for' y(14)='m y(a) = alpha1, (p*y'')a = alpha2, ' x(15)='when a is R or WR; and [y,u](a) = al' y(15)='pha1, [y,v](a) = alpha2, when a is ' x(16)='LCNO or LCO. ' y(16)=' ' x(17)=' Initial values at b are of the for' y(17)='m y(b) = beta1, (p*y'')b = beta2, ' x(18)='when b is R or WR; and [y,u](b) = be' y(18)='ta1, [y,v](b) = beta2, when b is ' x(19)='LCNO or LCO. ' y(19)=' ' x(20)=' In (*), lambda is a user-chosen re' y(20)='al number; while in the above ' x(21)='initial values, (alpha1,alpha2) and ' y(21)='(beta1,beta2) are user-chosen pairs ' x(22)='of real numbers not both zero. ' y(22)=' ' do 1201 i = 1,22 write(*,*) x(i),y(i) 1201 continue write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In the initial value case (3.) abo' y(1)='ve when the interval (a,b) is ' x(2)='finite, the interior point selected ' y(2)='by the program is generally near the' x(3)='midpoint of (a,b); when (a,b) is inf' y(3)='inite, no general rule can be given.' x(4)='Also if, given (alpha1,alpha2) and (' y(4)='beta1,beta2), the lambda chosen is ' x(5)='an eigenvalue of the associated boun' y(5)='dary value problem, the computed ' x(6)='solution may not be the correspondin' y(6)='g eigenfunction -- the signs of the ' x(7)='computed solutions on either side of' y(7)=' the interior point may be opposite.' x(8)=' The output for a solution of an in' y(8)='itial value problem is in the form ' x(9)='of stored numerical data which can b' y(9)='e plotted on the screen (see H16), ' x(10)='or printed out in graphical form if ' y(10)='graphics software is available. ' do 1202 i = 1,10 write(*,*) x(i),y(i) 1202 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 13 continue write(*,*) 'H13: Indexing of eigenvalues.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general results hold for t' y(2)='he separated boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' 1. If neither end-point a or b is ' y(4)='LP or LCO, then the spectrum of the ' x(5)='eigenvalue problem is discrete (eige' y(5)='nvalues only), simple (eigenvalues ' x(6)='all of multiplicity 1), and bounded ' y(6)='below with a single cluster point at' x(7)='+infinity. The eigenvalues are inde' y(7)='xed as {lambda(n): n=0,1,2,...}, ' x(8)='where lambda(n) < lambda(n+1) (n=0,1' y(8)=',2,...), lim lambda(n) -> +infinity;' x(9)='and if {psi(n): n=0,1,2,...} are the' y(9)=' corresponding eigenfunctions, then ' x(10)='psi(n) has exactly n zeros in the op' y(10)='en interval (a,b). ' x(11)=' 2. If neither end-point a or b is ' y(11)='LP but at least one end-point is ' x(12)='LCO, then the spectrum is discrete a' y(12)='nd simple as for (1.), but with ' x(13)='cluster points at both +infinity and' y(13)=' -infinity. The eigenvalues are ' x(14)='indexed as {lambda(n): n=0,1,-1,2,-2' y(14)=',...}, where ' x(15)='lambda(n) < lambda(n+1) (n=...-2,-1,' y(15)=',0,1,2,...) with lambda(0) the ' x(16)='smallest non-negative eigenvalue and' y(16)=' lim lambda(n) -> +infinity or ' x(17)='-> -infinity with n; and if {psi(n):' y(17)=' n=0,1,-1,2,-2,...} are the ' x(18)='corresponding eigenfunctions, then e' y(18)='very psi(n) has infinitely many ' x(19)='zeros in (a,b). ' y(19)=' ' do 1301 i = 1,19 write(*,*) x(i),y(i) 1301 continue write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' 3. If one or both end-points is LP' y(1)=', then there can be one or more ' x(2)='intervals of continuous spectrum for' y(2)=' the boundary value problem in ' x(3)='addition to some (necessarily simple' y(3)=') eigenvalues. For these ' x(4)='essentially more difficult problems,' y(4)=' SLEIGN2 can be used as an ' x(5)='investigative tool to give qualitati' y(5)='ve and possibly quantitative ' x(6)='information on the spectrum. ' y(6)=' ' x(7)=' For example, if a problem has a' y(7)=' single interval of continuous ' x(8)='spectrum bounded below by K, then th' y(8)='ere may be any number of eigenvalues' x(9)='below K. In some cases, SLEIGN2 can' y(9)=' compute K, and determine the number' x(10)='of these eigenvalues and compute the' y(10)='m. In this respect, see xamples.f: ' x(11)='#13 (Hydrogen Atom), #17 (Morse Osci' y(11)='llator), #21 (Fourier), and ' x(12)='#27 (Joergens) as examples of succes' y(12)='s; and #2 (Mathieu), #14 (Marletta),' x(13)='and #28 (Behnke-Goerisch) as example' y(13)='s of failure. ' x(14)=' The problem need not have a con' y(14)='tinuous spectrum, in which case if ' x(15)='its discrete spectrum is bounded bel' y(15)='ow, then the eigenvalues are indexed' x(16)='and the eigenfunctions have zero cou' y(16)='nts as in (1.). If, on the other ' x(17)='hand, the discrete spectrum is unbou' y(17)='nded below, then all the ' x(18)='eigenfunctions have infinitely many ' y(18)='zeros in the interval. ' do 1302 i = 1,18 write(*,*) x(i),y(i) 1302 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' In respect to the three classes of' y(1)=' end-points, the following ' x(2)='identified examples from xamples.f i' y(2)='llustrate the spectral property ' x(3)='of these boundary value problems: ' y(3)=' ' x(4)=' 1. Neither end-point is LP or LCO.' y(4)=' ' x(5)=' #1 (Legendre) ' y(5)=' ' x(6)=' #2 (Bessel) with -1/4 < c < 3' y(6)='/4 ' x(7)=' #4 (Boyd) ' y(7)=' ' x(8)=' #5 (Latzko) ' y(8)=' ' x(9)=' 2. Neither end-point is LP, but at' y(9)=' least one is LCO. ' x(10)=' #6 (Sears-Titchmarsh) ' y(10)=' ' x(11)=' #7 (BEZ) ' y(11)=' ' x(12)=' #19 (Donsch) ' y(12)=' ' x(13)=' 3. At least one end-point is LP. ' y(13)=' ' x(14)=' #13 (Hydrogen Atom) ' y(14)=' ' x(15)=' #14 (Marletta) ' y(15)=' ' x(16)=' #20 (Krall) ' y(16)=' ' x(17)=' #21 (Fourier) on [0,infinity) ' y(17)=' ' do 1303 i = 1,17 write(*,*) x(i),y(i) 1303 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 14 CONTINUE write(*,*) 'H14: Entry of eigenvalue index, initial guess,'// 1 ' and tolerance.' x(1)=' For SEPARATED boundary condition p' y(1)='roblems (see H7), SLEIGN2 calls for ' x(2)='input information options to compute' y(2)=' either ' x(3)=' 1. a single eigenvalue, or ' y(3)=' ' x(4)=' 2. a series of eigenvalues. ' y(4)=' ' x(5)='In each case indexing of eigenvalues' y(5)=' is called for (see H13). ' x(6)=' (1.) above asks for data triples N' y(6)='UMEIG, EIG, TOL separated by commas.' x(7)='Here NUMEIG is the integer index of ' y(7)='the desired eigenvalue; NUMEIG can ' x(8)='be negative only when the problem is' y(8)=' LCO at one or both end-points. ' x(9)='EIG allows for the entry of an initi' y(9)='al guess for the requested ' x(10)='eigenvalue (if an especially good on' y(10)='e is available), or can be set to 0 ' x(11)='in which case an initial guess is ge' y(11)='nerated by SLEIGN2 itself. ' x(12)='TOL is the desired accuracy of the c' y(12)='omputed eigenvalue. It is an ' x(13)='absolute accuracy if the magnitude o' y(13)='f the eigenvalue is 1 or less, and ' x(14)='is a relative accuracy otherwise. T' y(14)='ypical values might be .001 for ' x(15)='moderate accuracy and .0000001 for h' y(15)='igh accuracy in single precision. ' x(16)='If TOL is set to 0, the maximum achi' y(16)='evable accuracy is requested. ' x(17)=' If the input data list is truncate' y(17)='d with a "/" after NUMEIG or EIG, ' x(18)='then the remaining elements default ' y(18)='to 0. ' do 1401 i = 1,18 write(*,*) x(i),y(i) 1401 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N x(1)=' (2.) above asks for data triples N' y(1)='UMEIG1, NUMEIG2, TOL separated by ' x(2)='commas. Here NUMEIG1 and NUMEIG2 ar' y(2)='e the first and last integer indices' x(3)='of the sequence of desired eigenvalu' y(3)='es, NUMEIG1 < NUMEIG2; they can be ' x(4)='negative only when the problem is LC' y(4)='O at one or both end-points. ' x(5)='TOL is the desired accuracy of the c' y(5)='omputed eigenvalues. It is an ' x(6)='absolute accuracy if the magnitude o' y(6)='f an eigenvalue is 1 or less, and ' x(7)='is a relative accuracy otherwise. T' y(7)='ypical values might be .001 for ' x(8)='moderate accuracy and .0000001 for h' y(8)='igh accuracy in single precision. ' x(9)='If TOL is set to 0, the maximum achi' y(9)='evable accuracy is requested. ' x(10)=' If the input data list is truncate' y(10)='d with a "/" after NUMEIG2, then TOL' x(11)='defaults to 0. ' y(11)=' ' x(12)=' ' y(12)=' ' x(13)=' For COUPLED periodic-type boundary' y(13)=' condition problems (see H7 and ' x(14)='H17), SLEIGN2 asks only for NUMEIG, ' y(14)='the non-negative integer index of ' x(15)='the desired eigenvalue; TOL is set i' y(15)='nternally. ' do 1402 i = 1,15 write(*,*) x(i),y(i) 1402 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 15 CONTINUE write(*,*) 'H15: IFLAG information.' x(1)=' All results are reported by SLEIGN' y(1)='2 with a flag identification. There' x(2)='are four values of IFLAG: ' y(2)=' ' x(3)=' ' y(3)=' ' x(4)=' 1 - The computed eigenvalue has an' y(4)=' estimated accuracy within the ' x(5)=' tolerance requested. ' y(5)=' ' x(6)=' ' y(6)=' ' x(7)=' 2 - The computed eigenvalue does n' y(7)='ot have an estimated accuracy within' x(8)=' the tolerance requested, but i' y(8)='s the best the program could obtain.' x(9)=' ' y(9)=' ' x(10)=' 3 - There seems to be no eigenvalu' y(10)='e of index equal to NUMEIG. ' x(11)=' ' y(11)=' ' x(12)=' 4 - The program has been unable to' y(12)=' compute the requested eigenvalue. ' do 1501 i = 1,12 write(*,*) x(i),y(i) 1501 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 16 CONTINUE write(*,*) 'H16: Plotting.' x(1)=' After computing a single eigenvalu' y(1)='e (see H14(1.)), but not a sequence ' x(2)='of eigenvalues (see H14(2.)), the ei' y(2)='genfunction can be plotted. If this' x(3)='is desired, respond "y" when asked s' y(3)='o that SLEIGN2 will compute some ' x(4)='eigenfunction data and store them. ' y(4)=' ' x(5)=' One can ask that the eigenfunction' y(5)=' data be in the form of either ' x(6)='points (x,y) for x in (a,b), or poin' y(6)='ts (t,y) for t in the standardized ' x(7)='interval (-1,1) mapped onto from (a,' y(7)='b); the t- choice can be especially ' x(8)='helpful when the original interval i' y(8)='s infinite. Additionally, one can ' x(9)='ask for a plot of the so-called Pruf' y(9)='er angle, in x- or t- variables. ' x(10)=' In both forms, once the choice has' y(10)=' been made of the function to be ' x(11)='plotted, a crude plot is displayed o' y(11)='n the monitor screen and you are ' x(12)='asked whether you wish to save the c' y(12)='omputed plot points in a file. ' do 1601 i = 1,12 write(*,*) x(i),y(i) 1601 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N 17 CONTINUE write(*,*) 'H17: Indexing of eigenvalues for'// 1 ' periodic-type problems.' x(1)=' The indexing of eigenvalues is an ' y(1)='automatic facility in SLEIGN2. The ' x(2)='following general result holds for t' y(2)='he periodic-type boundary condition ' x(3)='problem (see H7): ' y(3)=' ' x(4)=' The spectrum of the eigenvalue pro' y(4)='blem is discrete (eigenvalues only),' x(5)='and bounded below with a single clus' y(5)='ter point at +infinity. In general,' x(6)='the spectrum is not simple, but no e' y(6)='igenvalue exceeds multiplicity 2. ' x(7)='The eigenvalues are indexed as {lamb' y(7)='da(n): n=0,1,2,...}, where ' x(8)='lambda(n) .le. lambda(n+1) (n=0,1,2,' y(8)='...), lim lambda(n) -> +infinity. ' x(9)=' The connection between the index n' y(9)=' and the number of zeros of the ' x(10)='corresponding eigenfunction psi(x,n)' y(10)=' is not as simple as for separated ' x(11)='conditions; that is, psi(x,n) need n' y(11)='ot have exactly n zeros in (a,b). ' x(12)=' The following identified examples ' y(12)='from xamples.f are of special ' x(13)='interest: ' y(13)=' ' x(14)=' #11 (Plum) on [0,pi] ' y(14)=' ' x(15)=' #21 (Fourier) on [0,pi] ' y(15)=' ' x(16)=' #25 (Meissner) on [-0.5,0.5] ' y(16)=' ' do 1701 i = 1,16 write(*,*) x(i),y(i) 1701 continue write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) write(*,*) '-----------------------------------------------' read(*,999) ans,n if (ans.eq.'r' .or. ans.eq.'R') return GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17),N go to 1 999 FORMAT(A1,I2) end SHAR_EOF fi # end of overwriting check if test -f 'sleign2.doc' then echo shar: will not over-write existing file "'sleign2.doc'" else cat << SHAR_EOF > 'sleign2.doc' H0: File name entry: This program will create a FORTRAN file containing the coefficients p(x),q(x),w(x), defining the differential equation, and the boundary condition functions u(x),v(x) if required. This file has to be given a filename which is acceptable to your FORTRAN compiler. For example, it might be called bessel.f or bessel.for depending upon your compiler. ----------------------------------------------- H1: The differential equation: The prompt "Input p (or q or w) =" requests you to type in a FORTRAN expression defining the function p(x), which is one of the three coeffi- cient functions defining the Sturm-Liouville differential equation -(p*y')' + q*y = lambda*w*y (*) to be considered on some interval (a,b) of the real line. The actual interval used in a particular problem can be chosen later, and may be either the whole interval (a,b) where the coefficient functions p,q,w, etc. are defined or any sub-interval (a',b') of (a,b); a = -infinity and/or b = +infinity are allowable choices for the end-points. The coefficient functions p,q,w of the differential equation may be chosen arbitrarily but must satisfy the following conditions: (1) p,q,w must be real-valued throughout (a,b) (2) p,q,w are piece-wise continuous and defined throughout the interior of the interval (a,b) (3) both p and w must be strictly positive in (a,b) For reliable error analysis in the numerical procedures condition (iii) above is often replaced with (iii)' p,q,w are four times continuously differentiable on (a,b). The values of p,q,w at the end-points a and b are critical to the classification of the differential equation. (See H2 and H9.) ----------------------------------------------- H2: End-point classification: The correct classification of the end-points a and b is essential to a correct working of the SLEIGN2 program. To classify the end-points it is convenient to choose a point c in (a,b); i.e. a < c < b. Subject to the general conditions on the coefficients p,q,w above: (1) a is REGULAR (say R) if -infinity < a, and p,q,w are piece-wise continuous on [a,c], and p(a) > 0 and w(a) > 0. (2) a is WEAKLY REGULAR (say WR) if -infinity < a, a is not R, and |c integral | {1/p+|q|+w} < +infinity. |a Note: if end-point a is not R or WR, then a is SINGULAR. I.e. either -infinity = a, or -infinity < a and |c integral | {1/p+|q|+w} = +infinity. |a (3) SINGULAR end-point a is LIMIT CIRCLE NON-OSCILLATORY (say LCNO) if for some real lambda ALL solutions y of the differential equation -(p*y')' + q*y = lambda*w*y on (a,c] (*) satisfy the two conditions: |c 1. integral | { w*y*y } < +infinity. |a 2. y has at most a finite number of zeros in (a,c] (4) SINGULAR end-point a is LIMIT-CIRCLE OSCILLATORY (say LCO) if for some real lambda ALL solutions y of the differential equation (*) satis- fy the two conditions: |c 1. integral | { w*y*y } < +infinity. |a 2. y has an infinite number of zeros in (a,c] (5) SINGULAR end-point a is LIMIT POINT (say LP) if for some real lambda at least one solution of the differential equation (*) satisfies the condition: |c integral | {w*y*y} = +infinity |a There is a similar classification of the end-point b into one of the five distinct cases R, WR, LCNO, LCO, LP. Although the classification of singular end-points invokes a real value of the parameter lambda, the classification is invariant in lambda; all real choices of lambda lead to the same classification. In determining the classification of singular end-points invoking the differential equation (*), it is often convenient to start with the choice lambda=0 in attempting to find solutions (particularly is this the case when q =0 on (a,b)); however see example 7 below. See H4 below on the use of maximal domain functions to determine the classification at singular end-points. EXAMPLES: 1. -y'' = lambda*y is R at both end-points of (a,b) when a & b are fin- ite. 2. -y'' = lambda*y on (-infinity, +infinity) is LP at both end-points. 3. -(sqrt(x)*y'(x))' = lambda*(1./sqrt(x))*y(x) on (0,+infinity) is WR at 0 and LP at +infinity. (take lambda = 0 in (*)); see xamples.x, #10 (weakly regular). 4. -((1-x*x)*y'(x))' = lambda*y(x) on (-1,1) is LCNO at both ends (take lambda=0 in (*)); see xamples.x #1 (Legendre). 5. -y''(x) + C*(1/(x*x))*y(x) = lambda*y(x) on (0,+infinity) is LP at +infinity (take lambda = 0 in (*)), and at 0 is: (i) LP for C .ge. 3/4 ; (ii) LCNO for -1/4 .le. C .lt. 3/4 (but C .ne. 0); (iii) LCO for C .lt. -1/4 (in all cases take lambda = 0 in (*)); 6. -(x*y'(x))' - (1/x)*y(x) = lambda*y(x) on (0,+infinity) is LCO at 0 and LP at +infinity (take lambda = 0 in (*) with solutions cos(ln(x)) and sin(ln(x))); see xamples.x #7 (BEZ) 7. -(x*y'(x))' - x*y(x) = lambda*(1/x)*y(x) on (0,+infinity) is LP at 0 and LCO at +infinity (take lambda = -1/4 in (*) with solutions cos(x)/ sqrt(x) and sin(x)/sqrt(x)); see xamples.x #6 (Sears-Titchmarsh) ----------------------------------------------- H3: DEFAULT entry: The complete range of problems for which SLEIGN2 is applicable can only be reached by appropriate entries under end-point classification and boundary conditions. However there is a DEFAULT application which re- quires no detailed entry of end-point classification or boundary condi- tions, subject to: (i) the DEFAULT application CAN NOT be used at a LCO end-point (ii) if an end-point a is R, then the Dirichlet boundary condition y(a) = 0 is automatically used. (iii) if an end-point a is WR, then the following boundary conditions are automatically applied: (1) if p(a)=0, and both q(a),w(a) are bounded, then Dirichlet y(a) = 0. (2) if p(a) > 0, and q(a) and/or w(a) are not bounded, then Neumann (py')(a) = 0. (3) if p(a)=0, and q(a) and/or w( a) are not bounded, then no reliable information can be given on the DEFAULT boundary condition. (iv) if an end-point is LCNO, then in most cases the principal or Friedr ichs boundary condition is applied (see H4). (v) if an end-point is LP, then in most cases the normal LP procedure is applied. If you choose the DEFAULT condition , then no entry is required for the u,v boundary condition functions. ----------------------------------------------- H4: Limit-circle boundary conditions: At an end-point a the limit-circle type separated boundary condition is of the form (similar remarks throughout apply to the end-point b) A1*[y,u](a) + A2*[y,v](a) = 0 (**) where y is a solution of the differential equation -(p*y')' + q*y = lambda*w*y on (a,b); (*) here A1, A2 are real numbers (not both zero); u and v are boundary con- dition functions; and for real-valued y and u the form [y,u] is defined by [y,u](x) = y(x)*(pu')(x) - u(x)*(py')(x) for x in (a,b). The object of this section is to provide help in choosing appropriate functions u and v in (**), given the differential equation (*). Full details of the boundary conditions for (*) are discussed in H5; here it is sufficient to say that the limit-circle type boundary condition (**) can be applied at any end-point in the LCNO, LCO classification, but also in the R, WR classification subject to the appropriate choice of u and v. Let (*) be R, WR, LCNO at end-point a; choose c in (a,b); then either (i) u and v are a pair of linearly independent solutions of (*) on (a,c] for any chosen real values of lambda, or (ii) u and v are a pair of real-valued maximal domain functions defined on (a,c] satisfying [u,v](a) .ne. 0. The maximal domain D(a,c] is defined by D(a,c] = {f:(a,c]->R:: f,pf' in AC(a,c]; f, ((-pf')'+qf)/w in L2((a,c;w)} It is known that for all f,g in D(a,c] the limit [f,g](a) = lim[f,g](x) as x->a exists and is finite. If (*) is LCNO or LCO at a, then all solutions of (*) belong to D(a,c] for all values of lambda. The boundary condition (**) is essential in the LCNO and LCO cases but can also be used with advantage in some R and WR cases. In the R, WR and LCNO cases but not in the LCO case, the boundary condi- tion functions can always be chosen so that lim u(x)/v(x) = 0 as x->a, and it is recommended that this normalisation be effected; this has been done in the examples given below. In this case the boundary condition [y ,u](a)=0 (i.e.A1=1,A2=0 in (**)) is called the principal or Friedrichs b oundary condition. There are similar definitions when the end-point b is R, WR, LCNO or LCO In the case when both end-points a and b are, independently, in R, WR, LCNO or LCO classification it may be that symmetry allows for one set of boundary condition functions to be used at both end-points (see Example 3 (Legendre) below); in other cases different pairs have to be chosen, one pair for each end-point; see xamples.x #16(Jacobi), #18(Dunsch), #19 (Donsch). Note that a solution pair u,v is always a maximal domain pair, but not necessarily vice versa. EXAMPLES: 1. -y''(x) = lambda*y(x) on [0,pi] is R at 0 and R at pi. At 0, with lambda=0, a solution pair is u(x) = x, v(x) = 1. At pi, with lambda=1, a solution pair is u(x) = sin(x),v(x) = cos(x). 2. -(sqrt(x)*y'(x))' = lambda*y(x)/sqrt(x) on (0,1] is WR at 0 and R at 1. (The general solutions of this equation are cos(2*sqrt(x*lambda)), sin(2*sqrt(x*lambda)) At 0 with lambda = 0, a solution pair is u(x) = 2*sqrt(x), v(x) = 1. At 1 with lambda = pi*pi/4 a solution pair is u(x) = sin(pi*sqrt(x)), v(x) = cos(pi*sqrt(x)). At 1 with lambda = 0, a solution pair is u(x) = 2*(1-sqrt(x)), v(x) = 1. See also xamples.x #10 (Weakly Regular). 3. -((1-x*x)*y'(x))' = lambda*y(x) on (-1,1) is LCNO at both ends. At +-1, with lambda = 0, a solution pair is u(x) = 1, v(x) = 0.5*log((1+x)/(1-x)). At +1 a maximal domain pair is u(x) = 1 , v(x) = log(1-x) At -1 a maximal domain pair is u(x) = 1, v(x) = log(1+x). See also xamples.x #1 (Legendre). 4. -y''(x) - (1/(4x*x))*y(x) = lambda*y(x) on (0,+infinity) is LCNO at 0 and LP at +infinity. At 0 a maximal domain pair is u(x) = sqrt(x), v(x) = sqrt(x)*log(x). See also xamples.x #2 (Bessel). 5. -y''(x) - 5*(1/(4*x*x))*y(x) = lambda*y(x) on (0,+infinity) is LCO at 0 and LP at +infinity. At 0 with lambda = 0, a solution pair is u(x) = sqrt(x)*cos(log(x)), v(x) = sqrt(x)*sin(log(x)) See also xamples.x #20 (Krall). 6. -y''(x) - (1/x)*y(x) = lambda*y(x) on (0,+infinity) is LCNO at 0 and LP at +infinity. At 0 a maximal domain pair is u(x) = x, v(x) = 1 -x*log(x) . See xamples.x #4(Boyd). 7. -((1/x)*y'(x))' + (k/(x*x) + k*k/x)*y(x) = lambda*y(x) on (0,1], with k real and .ne. 0, is LCNO at 0 and R at 1. At 0 a maximal domain pair is u(x) = x*x, v(x) = x - 1/k . See also xamples.x #8 (Laplace Tidal Wave). ----------------------------------------------- H5: Boundary conditions: Boundary conditions for Sturm-Liouville boundary value problems on an interval (a,b) are either (i) separated, with at most one condition at end-point a and at most one condition at end-point b, or (ii) coupled, when both a and b are, independently, in one of the end- point classifications R, WR, LCNO, LCO, in which case two independ- ent boundary conditions are required which link the solution values near a to those near b. The SLEIGN2 program allows for all separated conditions; and special cases of the coupled conditions--the periodic-type boundary condi- tions applicable only when the interval (a,b) is finite and both a and b are R. Separated Conditions -------------------- 2. The boundary conditions to be selected depend upon the classification of the differential equation at the end-point. 3. If the end-point is LP, then no boundary condition is required or allowed. 4. If the end-point a is R or WR, then a separated boundary condition is of the form A1*y(a) + A2*(py')(a) = 0, where A1, A2 are real constants you must choose, but not both zero. 5. If the end-point a is LCNO or LCO, then a separated boundary condi- tion is of the form A1*[y,u](a) + A2*[y,v](a) = 0, where A1, A2 are real constants you must choose, but not both zero; here u,v are the pair of boundary condition functions you have previously se- lected when the program MAKEPQW was being run. 6. If the end-point a is LCNO and the boundary condition pair u,v has been chosen so that lim u(x)/v(x) = 0 as x->a (which is always possible) then A1 =1, A2 = 0 ( i.e. [y,u](a) = 0 ) gives the principal (Friedrichs) boundary condition at a. 7. If a is R or WR and boundary condition functions u,v have been enter- ed in MAKEPQW, then both 5. and 6. above apply to entering separated boundary conditions at such an end-point; the boundary conditions in this form are equivalent to the point-wise conditions in 4. (subject to care in choosing A1, A2); this singular form of a regular boundary con- dition may be particularly effective in the WR case if the boundary con- dition form in 4. leads to numerical difficulties. 8. Conditions 4., 5., 6., 7. apply similarly at end-point b. 9. If a is R, WR, LCNO, or LCO and b is LP, then only a separated condi tion at a is required and allowed; similarly if a and b are interchanged 10. If both end-points a and b are LP, then no boundary conditions are required or allowed. 11. The indexing of eigenvalues for boundary value problems with sepa- rated conditions is discussed below in H11. Coupled Conditions ------------------ 12. The periodic-type boundary conditions on (a,b) apply only when both end-points a and b are R; these conditions are of the form y(b) = c*y(a) & (py')(b) = (py')(a)/c , where c may be chosen to be any real number not equal to 0. 13. The case c = 1 is called periodic; the case c = -1 is called semi- periodic. 14. The indexing of eigenvalues for periodic-type boundary conditions is discussed below in H15 . ---------------------------------------------- H6: Recording the results: If you choose to have a record kept of the results, then the following information is stored in a file with the name you select: (i) the file name (ii) the interval (a,b) which was used. For SEPARATED boundary conditions, (iii) the end-point classification (iv) a summary of coefficient information at WR, LCNO, LCO end-points (v) boundary condition constants (A1,A2), (B1,B2) if entered (vi) NUMEIG, EIG, TOL or NUMEIG1, NUMEIG2, TOL as entered (vii) the computed eigenvalue, EIG, and its estimated accuracy, TOL (viii) IFLAG reported. For COUPLED boundary conditions (ix) boundary condition parameter c (x) EIG value computed; TOL report (xi) IFLAG report. ---------------------------------------------- H7: Type and choice of interval: ---------------------- You may enter any interval (a,b) for which the coefficients p,q,w are well defined by your FORTRAN statements in MAKEPQW, provided that (a,b) contains no interior singularities. ---------------------------------------------- H8: Entry of end-points: ---------- End-points a and b must be entered as real numbers; there is no sym- bolic entry, e.g. pi must be entered as 3.14159... to a chosen number of decimal places. ---------------------------------------------- H9: End-point values of p,q,w: --------------------- The program SLEIGN2 needs to know whether or not the coefficient func- tions p(x), q(x), w(x) defined by the FORTRAN expressions you entered in MAKEPQW can be evaluated numerically without running into difficulty. If, for example, either q or w has an infinite limit at a, or if p(a) is 0, then SLEIGN2 needs to know so that only nearby values of x are used. ---------------------------------------------- H10: Initial Value Problems ---------------------- (1) The boundary value problems consist of the Sturm-Liouville differen- tial equation -(p*y')' + q*y = lambda*w*y on(a,b) (*) with either separate or coupled boundary conditions, as given in H5. (2) The initial value problem facility allows for the computation of a solution of (*), with a user-chosen value of lambda, for user-chosen in- itial conditions either (i) from end-point a, if R,WR,LCNO,LCO but not LP, towards end- point b of any classification or (ii) from end-point b, if R,WR,LCNO,LCO but not LP, towards end- point a of any classification or (iii) from end-points a and b, both satisfying the end-point re- quirements in (i) and (ii) above respectively, towards an in- terior point of the interval (a,b), selected by the program. The initial values to determine uniquely the computed solution are of the form (iv) at end-point a if a is R or WR then y(a)=alpha1, (p*y')(a)=alpha2 if a is LCNO or LCO then [y,u](a)=alpha1, [y,v](a)=alpha2 (v) at end-point b if b is R or WR then y(b)= beta1, (p*y')(b)=beta2 if b is LCNO or LCO then [y,u](b)=beta1, [y,v](b)=beta2 where alpha1,alpha2,beta1,beta2 are user-chosen real numbers with alpha1,alpha2 not both zero, and beta1,beta2 not both zero. Note that the value of the parameter lambda in (*) has to be chosen by the user, and may be any real number. In the case (iii) above when the interval (a,b) is finite, the inter- ior point selected by the program is generally near to the mid-point of (a,b); when (a,b) is not finite no general rule can be given. In the case (iii) above if, given alpha1,alpha2 and beta1,beta2, the parameter lambda is chosen to be an eigenvalue of the associated bound- ary value problem, the computed solution may or may not be a given eig- enfunction; the signs of the two computed solutions either side of the interior point, may be different. The output for a solution of an initial value problem is in the form of stored numerical data. This leads to a screen plot, or can be print- ed out in graph form if graphics software is available. ---------------------------------------------- H11: Indexing of Eigenvalues ----------------------- The indexing of eigenvalues is an automatic facility in SLEIGN2. The following general results hold for the separated boundary condition problem (see H5 above): 1. If both end-points a and b are independently R, WR, LCNO, then the spectrum of the eigenvalue problem is discrete (consists only of eigen- values), simple (all eigenvalues are of multiplicity one), bounded below with a single cluster point at +infinity. These eigenvalues are index- ed as {lambda(n): n=0,1,2,...}, where (i) lambda(n) < lambda(n+1) (n=0,1,2,...), lim lambda(n) = +infinity. (ii) if {psi(x,n): n=0,1,2...} are the corresponding eigenfunctions, th en psi(x,n) has exactly n zeros in the open interval (a,b). 2. If both end-points a and b are independently in R, WR, LCNO, LCO and at least one end-point is LCO, then the spectrum is discrete, simple, but with cluster points at both +infinity and -infinity; the eigenvalues are indexed as {lambda(n): n=0,1,-1,2,-2,..}, where (i) lambda(n) < lambda(n+1) (n=..-2,-1,0,1,2,..) lambda(n) -> +infinity or -infinity with n tending to + - infinity (ii) the program automatically indexes lambda(0) as the smallest non- negative eigenvalue. (iii) if {psi(n): n=0,1,-1,2,-2,..} are the corresponding eigenfunc- tions, then every psi(n) has infinitely many zeros in (a,b) 3. If one or both end-points is LP, then the spectral sets of the bound- ary value problem can contain one or more intervals of continuous spec- trum, with possibly some (necessarily simple) eigenvalues. For these essentially more difficult spectral problems, SLEIGN2 can be used as an investigative tool to give qualitative information on the spectrum. If the continuous spectrum is bounded below, then there may be a fin- ite or infinite number of eigenvalues below the lower bound, and SLEIGN2 may be able to detect these eigenvalue's indices and compute their val- ues. It can happen in this case, i.e. at least one end-point is LP, that the spectrum is discrete, consisting only of simple eigenvalues with cluster at one or both of +infinity, -infinity. If also the spectrum is bounded below, then the eigenvalues can be indexed as in 1. above; i.e. {lambda(n): n=0,1,2,..} with lambda(n) -> +infinity. In these circumstances, if {psi(x,n): n=0,1,2..} represents the corre- sponding set of eigenfunctions, then psi(n) has exactly n zeros in the open interval (a,b). If the discrete spectrum is unbounded below, then all the eigenfunc- tions have infinitely many zeros in the open interval (a,b). EXAMPLES. In respect of the points 1,2 and 3 above, the following identified ex- amples illustrate the spectral properties of these boundary value prob- lems. 1. See xamples.x: #1 (Legendre) #2 (Bessel) with -1/4 < c < 3/4 #4 (Boyd) #5 (Latzko) 2. See xamples.x: #6 (Sears-Titchmarsh) #7 (BEZ) #19 (Donsch) 3. See xamples.x: #21 (Fourier) on [0,+infinity) #13 (Hydrogen atom) #14 (Marletta) #20 (Krall) ---------------------------------------------- H12: Entry for eigenvalue index and tolerance: ------------------------------ For SEPARATED boundary condition problems (see H5 above), SLEIGN2 calls for input information options to compute (1) A single eigenvalue (2) A series of eigenvalues. In each case indexing of eigenvalues is called for; see H11 above. Entry (1) above asks you to supply data in the form (1') NUMEIG, EIG, TOL Here NUMEIG is the index of the desired eigenvalue, and requires input of a positive, negative, or zero integer; negative integers are allowed only in the case when the problem is LCO at one or both end-points. EIG allows for the entry of an initial guess for the requested eigenval- ue, if an especially good one is available, or one can enter 0. as defau lt input--i.e. no initial guess is provided. In the latter case an init ial guess is computed by SLEIGN2. If the guess desired is zero, enter any small number, like 0.001. TOL is the accuracy you are asking for in the computed eigenvalue. It is an absolute accuracy if the magnitude of the eigenvalue is less than or equal to 1, but is a relative accuracy otherwise. Typical values would be .001 for nominal accuracy, or perhaps .0000001 for extreme accuracy. There are DEFAULT entries: NUMEIG/ for which the program sets EIG and TOL, and NUMEIG,EIG/ for which the program sets TOL. Entry (2) above asks you to supply data in the form (2') NUMEIG1, NUMEIG2, TOL Here two integers n1, n2 should be entered with n1 < n2; as with (1') above negative integers are allowed only in the LCO case. TOL has the same meaning as above. There is a DEFAULT entry NUMEIG1,NUMEIG2/ for which the program sets TOL. In all these DEFAULT modes the program tries to get the most accur- acy it is capable of. For COUPLED periodic-type boundary conditions (see H5 and H15) the program calls for data in the form NUMEIG = Here NUMEIG is the index of the requested eigenvalue and requires input of a non-negative integer. In this mode the program sets its own TOL. ---------------------------------------------- H13: IFLAG information All results are reported with a flag identification. The flags carry the following meanings: IFLAG = 1 - successful problem solution. = 2 - integrator tolerance cannot be reduced further. = 3 - no more improvement = 4 - An internal consistency check failed = 6 - in SECANT-METHOD, ABS(DE) .LT. EPSMIN = 7 - iterations are stuck in a loop = 8 - number of iterations has reached the set limit = 9 - residual truncation error dominates = 10 - improper input parameters = 11 - NUMEIG exceeds actual highest eigenvalue index = 12 - failed to get a bracket = 13 - AA cannot be moved in any further. = 14 - BB cannot be moved in any further. = 51 - integration failure after 1st call to INTEG = 52 - integration failure after 2nd call to INTEG = 53 - integration failure after 3rd call to INTEG = 54 - integration failure after 4th call to INTEG ---------------------------------------------- H14: Plotting After computing a single eigenvalue, see H12 (1) above, (but NOT after computing a series of eigenvalues, see H12 (2) ) it is possible to have the eigenfunction plotted. If this is desired, enter 'y' for yes, so that SLEIGN2 will compute some points on the eigenfunction and store the data. One can have the eigenfunction data in the form of points (xi,yi) with the xi selected points in (a,b), or in the form of points (ti,yi) where the ti are points in a standardized interval (-1,1): i.e. the int- erval (a,b) has been mapped onto (-1,1). This latter choice can be es- pecially helpful when the original interval is infinite. Additionally, one can have a plot of the so-called Pruefer angle or mo dulus in either the x- or t- variable. In either case, once the choice has been made of which function is to be plotted, a crude plot is displayed on the monitor screen before ask- ing whether or not you wish to save the computed plot points in a file. ---------------------------------------------- H15: Periodic-type problems The indexing of eigenvalues is an automatic facility in SLEIGN2. The following general result holds for the periodic-type boundary condition problem. Recall that these problems require both the end-points a and b to be R. The spectrum of the boundary value problem is discrete (consists only of eigenvalues), bounded below with a single cluster point at +infinity. In general the spectrum is not simple; there may be one or more eigen- values of multiplicity two, but none of higher multiplicity. These eigenvalues are indexed as {lambda(n): n=0,1,2,...} where lambda(0).le.lambda(1).le.lambda(2).le.....le.lambda(n).le... (*) and lambda(n)->+infinity as n->+infinity. Note that in (*) there can be at most two consecutive .le. since the multiplicity of any eigenvalue cannot exceed 2. The connection between the index n and the number of zeros of the cor- responding eigenfunction psi(x,n) is not as simple as it is in the case of separated conditions; in particular psi(x,n) need not have exactly n zeros in the open interval (a,b). Examples of special interest: (i) xamples.x #21 (Fourier) on [0,pi] (ii) xamples.x #11 (Plum) on [0,pi] (iii) xamples.x #25 (Meissner) on [-0.5,0.5] . ---------------------------------------------- SHAR_EOF fi # end of overwriting check if test -f 'sleign2.hlp' then echo shar: will not over-write existing file "'sleign2.hlp'" else cat << SHAR_EOF > 'sleign2.hlp' There are four fortran files in the SLEIGN2 package: makepqw.f, drive.f, SLEIGN2.f and xamples.f. To run one of the examples in the examples.f file on a UNIX machine with a fortran compiler do the following: f77 examples.f drive.f sleign2.f -o xamples.x then run examples.x whenever you want to work an example from this list. To run your own problem proceed as follows: Step1: f77 makepqw.f -o makepqw.x Step2: makepqw.x (This interactive program will ask you for a file name - this must end in .f e.g. problem.f) This file contains the subroutines for p,q,w and, if nessecary, the functions u and v which are used to define singular boundary conditions. Step3: f77 problem.f drive.f sleign2.f -o problem.x Step4: problem.x (You will be asked to provide the information the code needs to identify and run the S-L problem. (At each point where input is requested help is available - just type h return. Type r, return, to get back to the point where help was requested.) Continue. The above procedures may have to be modified slightly for non UNIX environments, e.g. DOS or APPLE. Enjoy and good luck! Paul Bailey, Norrie Everitt and Tony Zettl. SHAR_EOF fi # end of overwriting check if test -f 'sleign2.txt' then echo shar: will not over-write existing file "'sleign2.txt'" else cat << SHAR_EOF > 'sleign2.txt' From: CBS%UK.AC.CRANFIELD::EDU.NIU.MATH::ZETTL 2-OCT-1994 22:11:38.56 To: PRYCE CC: Subj: Re: sleign2 Via: UK.AC.CRANFIELD; Sun, 2 Oct 94 22:11 BST Received: from clinch.math.niu.edu by xss001.ccc.cranfield.ac.uk with SMTP (PP) id <17221-0@xss001.ccc.cranfield.ac.uk>; Sun, 2 Oct 1994 22:10:07 +0100 Received: from eiger.niu.edu (eiger.math.niu.edu) by clinch.math.niu.edu (4.1/SMI-4.1) id AA19431; Sun, 2 Oct 94 16:09:17 CDT From: zettl@edu.niu.math (Anton Zettl) Message-Id: <9410022109.AA19431@clinch.math.niu.edu> Subject: Re: sleign2 To: PRYCE@uk.ac.cranfield.rmcs (JOHN PRYCE, APPLIED & COMPUTATIONAL MATHS GROUP, RMCS SHRIVENHAM, SWINDON SN6 8LA, UK) Date: Sun, 2 Oct 1994 16:07:39 -0500 (CDT) In-Reply-To: <"xss001.ccc.296:06.08.94.09.05.44"@cranfield.ac.uk> from "JOHN PRYCE, APPLIED & COMPUTATIONAL MATHS GROUP, RMCS SHRIVENHAM, SWINDON SN6 8LA, UK" at Sep 6, 94 10:07:00 am X-Mailer: ELM [version 2.4 PL23] Mime-Version: 1.0 Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Length: 7677 Sender: zettl@edu.niu.math Introduction to SLEIGN2. The main purpose of this program is to compute eigenvalues and eigenfunctions of regular and singular Sturm-Liouville problems. These consist of a second order linear differential equation -(py')' + qy = (lambda) w y on (a,b) together with boundary conditions (BC). The nature of the BC depends on the regular or singular classification of the end points. For both cases the BC fall into two major classes : separated and coupled. The former are two separate conditions, one at each end-point; the latter are two coupled conditions linking the values of the solution at the two end-points a and b. A number lambda for which there is a nontrivial solution satisfying the BC is called an eigenvalue and such a solution is a (corresponding) eigenfunction. If one or both endpoints are LP (see below or section 2 of "HELP" for a definition) there may be points lambda in the spectrum in addition to eigenvalues i.e. there may be continuous spectrum. In the theory of S-L problems the coefficients 1/p and q and the weight function w are assumed to be real valued and locally Lebesgue integrable. To meet the needs of numerical computing techniques we make the stronger assumptions : (i) The interval (a,b) of R may be bounded or unbounded; in the regular case it is compact and denoted by [a,b]. (ii) p, q, and w are real-valued functions on (a,b) (iii) p,q,w, are piecewise continuous on (a,b) (iv) p and w are strictly positive on (a,b). For reliable error analysis in the numerical procedures condition (iii) above is often replaced with (iii)' p,q,w are four times continuously differentiable on (a,b). To study S-L problems using operator theory one associates a self-adjoint operator in the w-weighted Hilbert space of square-integrable functions on (a,b) with each S-L problem in such a way that the spectrum of the problem is the spectrum of the operator. In the case of a regular problem the spectrum consists entirely of eigenvalues and these are bounded below. This is still so for the case when each end-point is either regular or singular limit-circle nonoscillatory (LCNO). In case one end-point is limit-circle oscillatory (LCO) and the other is not limit-point (LP) then there are still only eigenvalues in the spectrum but these are not bounded below. (The spectrum is never bounded above.) If one or both endpoints is LP the spectrum may be extremely complicated. There may be no eigenvalues, finitely many, or infinitely many. Some may be embedded in the continuous spectrum. For p=1,w=1, q(x) =sin(x) on (-inf,+inf) there are no eigenvalues and the continuous spectrum consists of the union of an infinite number of disjoint compact intervals. (SLEIGN2 can be used to compute this spectrum - see example 12 in the code.) See "HELP" for a definition of the terms LCO etc. S-L problems are classified into various classes based on the classification of the end-points and on whether the boundary conditions are separated(S) or coupled(C). We have the following categories: 1. R/R, S 2. R/R, C 3. R/LCNO or LCNO/R, S 4. R/LCNO or LCNO/R, C 5. R/LCO or LCO/R , S 6. R/LCO or LCO/R , C 7. LCNO/LCO or LCO/LCNO or LCO/LCO, S 8. LCNO/LCO or LCO/LCNO or LCO/LCO, C 9. LP/R or LP/LCNO or LP/LCO or R/LP or LCNO/LP or LCO/LP 10. LP/LP For 9. there is only a separated condition condition at the non-LP end-point and for 10. there are no boundary conditions at either end. There are only three other major general purpose codes for computing eigenvalues and eigenfunctions of Sturm-Liouville problems : The NAG library code, SLEDGE, and the earlier code SLEIGN. We have not had an opportunity to use the newly revised version of the NAG code (the earlier version was modeled on SLEIGN) so our comments here are confined to the other two codes. SLEDGE uses a method based on piecewise constant approximations of the coefficients of the differential equation; SLEIGN and SLEIGN2 both are based on the Pruefer transformation. Both SLEIGN and SLEDGE are designed to automatically handle end-points which are either regular or singular but non-oscillatory. And in the latter case if an end-point is LCNO the Friedrichs condition is usually the one chosen by the code. SLEDGE can also determine the LP/LC classification; SLEIGN and SLEIGN2 do not. For problems with LC end-points, whether LCNO or LCO, SLEIGN2 is the only general purpose code in existence which can handle arbitrary separated boundary conditions. It is also the only code which can handle coupled boundary conditions, in particular periodic-type conditions including the classical periodic and semi-periodic ones. In addition to the above mentioned capabilities to compute eigenvalues and eigenfunctions SLEIGN2 also computes the solution of an initial value problem with the users choice of lambda and either a regular or SINGULAR initial condition. When combined with the algorithm established in [BEWZ] SLEIGN2 can be used to approximate the continuous spectrum. An important feature of the SLEIGN2 program is its user friendly interface. The whole package consists of the following files: 1. A brief "readme" file with basic information on how to run the code. 2. This intoduction 3.makepqw.f - This is an interactive fortran file to input the coefficient functions p,q,w and,if necessary, the functions u,v which define the singular boundary conditions. 4.drive.f - This is an interactive fortran file containing the driver, parts of "help", and a "user friendly" interface. 5.sleign2.f - The main code for the computation of eigenvalues and eigenfunctions. 6.xamples.f - A fortran file with 25 examples ready to run. These examples were chosen to illustrate various features of the code. 7.xamples.comm - Contains information about the examples. 8. HELP - A file with information about end-point classifications, boundary conditions etc. It is a separate text file and parts of it can also be accessed from both makepqw and drive : At each point where the user is asked for some input there is an option for help - just type "h" return and you will be placed at the appropriate section of HELP; to return to the point in the program where help was called just type "r" return. The 16 components of HELP are: H0 File name entry H1 The Sturm-Liouville differential equation H2 End-point classifications with examples H3 Default classification and boundary condition entry H4 LC(limit-circle) boundary conditions with examples H5 Regular and singular, separated and coupled boundary conditions H6 Recording results H7 Type and choice of intervals H8 Entry of end-points H9 Value of coefficients p,q,w at end points a and b H10 Boundary and initial value problems H11 Indexing of eigenvalues H12 Entry for eigenvalues and for tolerances H13 Flag information for output H14 Plotting results H15 Periodic-type boundary conditions When an eigenfunction has been computed it is stored and can be examined: (i) by printing out the numerical data (ii) by using the discrete graph plotter in the program (iii) by using a local graph plotter. THIS SINGLE PRECISION VERSION OF THE CODE HAS BEEN PREPARED FOR TESTING PRIOR TO RELEASE. IT IS INTENDED TO BE USED TO TEST THE VIABILITY OF THE ALGORITHMS USED ON THE CLASSES OF PROBLEMS MENTIONS ABOVE. THE FINAL VERSION WILL BE AVAILABLE IN SINGLE AND IN DOUBLE PRECISION. SHAR_EOF fi # end of overwriting check if test -f 'sleign2d.f' then echo shar: will not over-write existing file "'sleign2d.f'" else cat << SHAR_EOF > 'sleign2d.f' C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C C This program is for an equation of the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) C SUBROUTINE SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,EIG,TOL,IFLAG,ISLFUN,SLFUN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) INTEGER INTAB,NUMEIG,IFLAG,ISLFUN DOUBLE PRECISION A,B,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,EIG,TOL, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFUN(9) C ********** C C This subroutine is designed for the calculation of a specified C eigenvalue, EIG, of a Sturm-Liouville problem for the equation C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C with user-supplied coefficient functions p, q, and w. C The problem may be either nonsingular or singular. In the C nonsingular case, boundary conditions of the form C C A1*y(a) + A2*p(a)*y'(a) = 0 C B1*y(b) + B2*p(b)*y'(b) = 0 C C are prescribed by specifying the numbers A1, A2, B1, and B2. C The index of the desired eigenvalue is specified in NUMEIG C and its requested accuracy in TOL. Initial data for the C associated eigenfunction are also computed along with values C at selected points, if desired, in array SLFUN. C C In addition to the coefficient functions p, q, and w, the user C must supply subroutine UV to describe the boundary condition C when the problem is limit circle. UV can be a dummy subroutine C if the problem is not limit circle. C C The SUBROUTINE statement is C C SUBROUTINE sleign2(a,b,intab,p0ata,qfata,p0atb,qfatb,a1,a2, C b1,b2,numeig,eig,tol,iflag,islfun,slfun, C singata,singatb,circla,circlb,oscila,oscilb) C C where C C A and B are input variables defining the interval. If the C interval is finite, A must be less than B. (See INTAB below.) C C INTAB is an integer input variable specifying the nature of the C interval. It can have four values. C C INTAB = 1 - A and B are finite. C INTAB = 2 - A is finite and B is infinite (+). C INTAB = 3 - A is infinite (-) and B is finite. C INTAB = 4 - A is infinite (-) and B is infinite (+). C C If either A or B is infinite, it is classified singular and C its value is ignored. C C P0ATA, QFATA, P0ATB, and QFATB are input variables set to C 1.0 or -1.0 as the following properties of p, q, and w at C the interval endpoints are true or false, respectively. C C P0ATA - p(a) is zero. (If true, A is singular.) C QFATA - q(a) and w(a) are finite. (If false, A is singular.) C P0ATB - p(b) is zero. (If true, B is singular.) C QFATB - q(b) and w(b) are finite. (If false, B is singular.) C C A1 and A2 are input variables set to prescribe the boundary C condition at A. C C B1 and B2 are input variables set to prescribe the boundary C condition at B. C C NUMEIG is an integer variable. On input, it should be set to C the index of the desired eigenvalue (increasing sequence where C index 0 corresponds to the lowest eigenvalue -- if the C eigenvalues are bounded below -- or to the smallest nonegative C eigenvalue otherwise). On output, it is unchanged unless the C problem (apparently) lacks eigenvalue NUMEIG, in which case it C is reset to the index of the largest eigenvalue that seems to C exist. C C EIG is a variable set on input to 0.0 or to an initial guess of C the eigenvalue. If EIG is set to 0.0, SLEIGN2 will generate C the initial guess. On output, EIG holds the calculated C eigenvalue if IFLAG (see below) signals success. C C TOL is a variable set on input to the desired accuracy of the C eigenvalue. On output, TOL is reset to the accuracy estimated C to have been achieved if IFLAG (see below) signals success. C This accuracy estimate is absolute if EIG is less than one C in magnitude, and relative otherwise. In addition, prefixing C TOL with a negative sign, removed after interrogation, serves C as a flag to request trace output from the calculation. C C IFLAG is an integer output variable set as follows: C C IFLAG = 0 - improper input parameters. C IFLAG = 1 - successful problem solution, within tolerance. C IFLAG = 2 - best problem result, not within tolerance. C IFLAG = 3 - NUMEIG exceeds actual highest eigenvalue index. C IFLAG = 4 - RAY and EIG fail to agree after 5 tries. C IFLAG = 6 - in SECANT-METHOD, ABS(DE) .LT. EPSMIN . C IFLAG = 7 - iterations are stuck in a loop. C IFLAG = 8 - number of iterations has reached the set limit. C IFLAG = 9 - residual truncation error dominates. C IFLAG = 10 - integrator tolerance cannot be reduced. C IFLAG = 11 - no more improvement. C IFLAG = 12 - failed to get a bracket. C IFLAG = 13 - AA cannot be moved in any further. C IFLAG = 14 - BB cannot be moved in any further. C IFLAG = 51 - integration failure after 1st call to INTEG. C IFLAG = 52 - integration failure after 2nd call to INTEG. C IFLAG = 53 - integration failure after 3rd call to INTEG. C IFLAG = 54 - integration failure after 4th call to INTEG. C C ISLFUN is an integer input variable set to the number of C selected eigenfunction values desired. If no values are C desired, set ISLFUN to zero. C C SLFUN is an array of length at least 9. On output, the first 9 C locations contain the integration interval and initial data C that completely determine the eigenfunction. C C SLFUN(1) - point where two pieces of eigenfunction Y match. C SLFUN(2) - left endpoint XAA of the (truncated) interval. C SLFUN(3) - value of THETA at XAA. (Y = RHO*sin(THETA)) C SLFUN(4) - value of F at XAA. (RHO = exp(F)) C SLFUN(5) - right endpoint XBB of the (truncated) interval. C SLFUN(6) - value of THETA at XBB. C SLFUN(7) - value of F at XBB. C SLFUN(8) - final value of integration accuracy parameter EPS. C SLFUN(9) - the constant Z in the polar form transformation. C C F(XAA) and F(XBB) are chosen so that the eigenfunction is C continuous in the interval (XAA,XBB) and has weighted (by W) C L2-norm of 1.0 on the interval. If ISLFUN is positive, then C on input the further ISLFUN locations of SLFUN specify the C points, in ascending order, where the eigenfunction values C are desired and on output contain the values themselves. C C SINGATA is an input variable set positive if endpoint A C is singular, and negative or zero if A is nonsingular. C C SINGATB is an input variable set positive if endpoint B C is singular, and negative or zero if B is nonsingular. C C CIRCLA is an input variable set positive if endpoint A has C a limit-circle singularity, and negative or zero if not. C C CIRCLB is an input variable set positive if endpoint B has C a limit-circle singularity, and negative or zero if not. C C OSCILA is an input variable set positive if the limit-circle C singularity at A is oscillatory, and negative or zero if not. C C OSCILB is an input variable set positive if the limit-circle C singularity at B is oscillatory, and negative or zero if not. C C Subprograms called C C user-supplied ..... p,q,w,uv C C sleign2-supplied .. aabb,alfbet,dxdt,eigenf,epslon,estpac,integ, C setmid,tfromi,thum C C This version dated 7/23/95. C Paul B. Bailey, Albuquerque, New Mexico C Burton S. Garbow, Park Forest, Illinois C C ********** C .. Scalars in Common .. INTEGER INTSAV,IND DOUBLE PRECISION ASAV,BSAV,C1,C2,EIGSAV,EPSMIN,Z, 1 PI,TWOPI,HPI,TSAVEL,TSAVER C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION TEE(100),ZEE(100) C .. C .. Local Scalars .. INTEGER I,IA,IB,IMAX,IMIN,IOUT,JFLAG,KFLAG,MF,ML, 1 NEIG,K,JJL,JJR,IE,IMID,NITER,NRAY,LOOP2,LOOP3, 2 MDTHZ LOGICAL AOK,BOK,BRACKT,CONVRG,FYNYT,FYNYT1,LOGIC, 1 NEWTON,ONEDIG,PRIN,THEGT0,THELT0,OLDNEWT,SINGA, 2 SINGB,LCIRCA,LCIRCB,OSCA,OSCB,ENDA,ENDB,LIMUP, 3 ADDD,EXIT,FIRSTT,NEWTONF,LIMA,LIMB,BRS, 4 BRSS,CHNGEPS,TRUNKA,TRUNKB DOUBLE PRECISION AA,AAA,AAF,ALFA,BB,BBB,BBF,BETA, 1 C,CHNG,CL,CR,DE,DEDW,DEN,DERIVL,DERIVR,DIST, 2 DT,DTHDA,DTHDAA,DTHDB, 3 DTHDBB,DTHDE,DTHDEA,DTHDEB,DTHETA,DTHOLD,E,EEE, 4 EIGLO,EIGLT,EIGRT,EIGUP,EL,EMAX,EMIN,EOLD,EPS, 5 ER1,ER2,ESTERR,FLO,FMAX,FUP,GUESS,ONE,PIN, 6 PSIL,PSIPL,PSIPR,PSIR,PX,QX,RAY,WX, 7 SL,SQL,SQR,SR,T,T1,T2,T3,TAU,THRESH,TMID,TMP, 8 U,UL,UR,V,WL,X,X50,XAA,XBB,XMID,XSAV,ZAV, 9 TS,ELIMA,ELIMB,ELIMUP,SUM,SUM0,UT,EU,WU,FOLD,BALLPK, A BESTEIG,BESTEST,OLDEST,EPSM,THA,THB,XT,PUP,PVP,HU,HV, B DTHZ,REMZ,OLDRAY,SAVRAY,RLX,EIGPI,FNEW,AAL,BBL,EPSL, C CHNGLIM,DTHOLDY,AAS,BBS,DTHDAAX,DTHDBBX,DUM, D RATL1,RATL2,RATL3,RATR1,RATR2,RATR3,SL1,SL2,SL3, E TAUM,ADTHETA,FLOUP,PT2,PT3,SAVAA,SAVBB,SAVERR, F BESTAA,BESTBB,BESTMID,BESTEPS,SR1,SR2,SR3 C .. C .. Local Arrays .. DOUBLE PRECISION DS(99),PS(99),QS(99),WS(99),DELT(99),PSS(99), 1 XS(99),YL(3),YR(3),ERL(3),ERR(3),YZL(3),YZR(3) C .. C .. External Functions .. DOUBLE PRECISION EPSLON,P,Q,W,TFROMI EXTERNAL EPSLON,P,Q,W,TFROMI C .. C .. External Subroutines .. EXTERNAL AABB,ALFBET,DXDT,EIGFCN,ESTPAC,INTEG,SETMID,THUM,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,EXP,INT,LOG,MAX,MIN,SIGN,SIN,SQRT,TAN C .. C .. Common blocks .. COMMON /DATADT/ASAV,BSAV,C1,C2,INTSAV COMMON /DATAF/EIGSAV,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /TEEZ/TEE COMMON /ZEEZ/JAY,ZEE COMMON /PIE/PI,TWOPI,HPI COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ COMMON /TSAVE/TSAVEL,TSAVER C .. C Set constants EPSMIN, the computer unit roundoff error, and PI. C (Variable ONE set to 1.0 eases precision conversion.) C ONE = 1.0 EPSMIN = EPSLON(ONE) PI = 4.0*ATAN(ONE) TWOPI = 2.0*PI HPI = 0.5*PI do 3 I=1,99 PSS(I) = 0.0D0 3 continue C C Set output device number. C IOUT = 6 C C Check input parameters for errors. If errors, return IFLAG = 0. C LOGIC = 1.LE.INTAB .AND. INTAB.LE.4 .AND. 1 P0ATA*QFATA*P0ATB*QFATB.NE.0.0 IF (INTAB.EQ.1) LOGIC = LOGIC .AND. A.LT.B IF (.NOT.LOGIC) THEN IFLAG = 0 GO TO 150 END IF C C Set PRIN = .true. to trigger trace printout of successive steps. C PRIN = .FALSE. IF (TOL.LT.0.0) PRIN = .TRUE. C C Set EPS to the (initial) integration accuracy. C EPS = 0.0001 C C Set logical variables. C AOK = INTAB.LT.3 .AND. P0ATA.LT.0.0 .AND. QFATA.GT.0.0 BOK = (INTAB.EQ.1 .OR. INTAB.EQ.3) .AND. 1 P0ATB.LT.0.0 .AND. QFATB.GT.0.0 SINGA = SINGATA.GT.0.0 SINGB = SINGATB.GT.0.0 LCIRCA = CIRCLA.GT.0.0 LCIRCB = CIRCLB.GT.0.0 OSCA = OSCILA.GT.0.0 OSCB = OSCILB.GT.0.0 TRUNKA = (SINGA .AND. .NOT.LCIRCA) .OR. OSCA TRUNKB = (SINGB .AND. .NOT.LCIRCB) .OR. OSCB EIGPI = NUMEIG*PI NEIG = NUMEIG - 1 WRITE(21,*) ' NUMEIG = ',NUMEIG C C Initial C1 and C2, used in the mapping between X and T intervals. C C1 = 1.0 C2 = 0.0 C DO (SAVE-INPUT-DATA) ASAV = A BSAV = B INTSAV = INTAB TAU = ABS(TOL) TAUM = MAX(TAU,EPSMIN) C END (SAVE-INPUT-DATA) C C Initialize the arrays JAY and ZEE if either end is oscillatory. C IF (OSCA .OR. OSCB) THEN DO 5 K=1,100 JAY(K) = 0 ZEE(K) = 1.0 5 CONTINUE END IF C C Evaluate P, Q, W to obtain preliminary information about the C differential equation. C C DO (SAMPLE-COEFFICIENTS) THRESH = 1.0E+17 10 CONTINUE CALL DXDT(EPSMIN,TMP,X50) XS(50) = X50 TS = EPSMIN PX = P(X50) QX = Q(X50) WX = W(X50) PS(50) = PX QS(50) = QX/PX WS(50) = WX/PX C C EMIN = min(Q/W), achieved at X for index value IMIN. C EMAX = max(Q/W), achieved at X for index value IMAX. C MF and ML are the least and greatest index values, respectively. C XSAV = X50 EMIN = 0.0 IF (QX.NE.0.0) EMIN = QX/WX EMAX = EMIN IMIN = 50 IMAX = 50 DO 20 I=49,1,-1 T = TFROMI(I) CALL DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I) = XSAV - X DELT(I) = 0.5*(TS-T) XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near A C or when w is small near A. C FYNYT = (ABS(WX)+ABS(QX)+1.0/ABS(PX)).LE.THRESH 1 .AND. WX.GT.EPSMIN IF (QX.NE.0.0 .AND. QX/WX.LT.EMIN) THEN EMIN = QX/WX IMIN = I END IF IF (QX.NE.0.0 .AND. QX/WX.GT.EMAX) THEN EMAX = QX/WX IMAX = I END IF MF = I IF (.NOT.FYNYT) GO TO 30 20 CONTINUE 30 CONTINUE AAA=T IF (.NOT.SINGA) AAA = -1.0 XSAV = X50 DO 40 I=51,99 T = TFROMI(I) CALL DXDT(T,TMP,X) XS(I) = X PX = P(X) QX = Q(X) WX = W(X) PS(I) = PX QS(I) = QX/PX WS(I) = WX/PX DS(I-1) = X - XSAV DELT(I-1) = 0.5*(T-TS) XSAV = X TS = T C C Try to avoid overflow by stopping when functions are large near B C or when w is small near A. C FYNYT1 = (ABS(QX)+ABS(WX)+1.0/ABS(PX)).LE.THRESH 1 .AND. WX.GT.EPSMIN IF (QX.NE.0.0 .AND. QX/WX.LT.EMIN) THEN EMIN = QX/WX IMIN = I END IF IF (QX.NE.0.0 .AND. QX/WX.GT.EMAX) THEN EMAX = QX/WX IMAX = I END IF ML = I - 1 IF (.NOT.FYNYT1) GO TO 50 40 CONTINUE 50 CONTINUE BBB = T IF (.NOT.SINGB) BBB = 1.0 LOGIC = C1.EQ.1.0 .AND. (.NOT.FYNYT .OR. .NOT.FYNYT1) C C Modify (T,X) transformation corresponding to truncated interval. C IF (LOGIC) THEN C1 = 0.5*(BBB-AAA) C2 = 0.5*(AAA+BBB) GO TO 10 END IF IF (OSCA .OR. OSCB) CALL THUM(MF,ML,XS) C C Here we try to determine 'sigma0'. Initially, we will be C satisfied to determine eliml and elimr, the limiting values C of q/w, if they exist. C LIMA = .FALSE. IF (SINGA .AND. .NOT.LCIRCA) THEN RATL1 = QS(MF)/WS(MF) RATL2 = QS(MF+1)/WS(MF+1) RATL3 = QS(MF+2)/WS(MF+2) SL1 = RATL1/(XS(MF+1)-XS(MF)) SL2 = RATL2/(XS(MF+2)-XS(MF+1)) SL3 = RATL3/(XS(MF+3)-XS(MF+2)) IF (ABS(SL2).GE.ABS(SL1) .AND. ABS(SL2).LE.ABS(SL3)) THEN ELIMA = RATL1 LIMA = PS(MF).EQ.PS(MF+1) WRITE(*,*) ' There is a limit at a, LIMIT = ',ELIMA WRITE(21,*) ' THERE IS A LIMIT AT a, LIMIT = ',ELIMA END IF END IF LIMB = .FALSE. IF (SINGB .AND. .NOT.LCIRCB) THEN RATR1 = QS(ML)/WS(ML) RATR2 = QS(ML-1)/WS(ML-1) RATR3 = QS(ML-2)/WS(ML-2) SR1 = RATR1/(XS(ML)-XS(ML-1)) SR2 = RATR2/(XS(ML-1)-XS(ML-2)) SR3 = RATR3/(XS(ML-2)-XS(ML-3)) IF (ABS(SR2).GE.ABS(SR1) .AND. ABS(SR2).LE.ABS(SR3)) THEN ELIMB = RATR1 LIMB = PS(ML).EQ.PS(ML-1) WRITE(*,*) ' There is a limit at b, LIMIT = ',ELIMB WRITE(21,*) ' THERE IS A LIMIT AT b, LIMIT = ',ELIMB END IF END IF LIMUP = .FALSE. ELIMUP = EMAX IF (LIMA .OR. LIMB) THEN LIMUP = .TRUE. IF (.NOT.LIMB) THEN ELIMUP = ELIMA ELSE IF (.NOT.LIMA) THEN ELIMUP = ELIMB ELSE ELIMUP = MIN(ELIMA,ELIMB) END IF WRITE(21,*) ' THE CONTINUOUS SPECTRUM HAS A LOWER ' WRITE(21,*) ' BOUND, SIGMA0 = ',ELIMUP END IF C END (SAMPLE-COEFFICIENTS) PIN = EIGPI + PI IF (EIG.EQ.0.0) THEN C DO (ESTIMATE-EIG) SUM0 = 0.0 IF (OSCA .OR. OSCB) THEN EEE = 0.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) SUM0 = SUM END IF EEE = MIN(ELIMUP,EMAX) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) 55 CONTINUE IF (.NOT.LIMUP .AND. 1 ABS(SUM).GE.10.0*MAX(1.0,ABS(PIN))) THEN IF (SUM.GE.10.0*PIN) THEN IF (EEE.GE.1.0) THEN EEE = EEE/10.0 ELSE IF (EEE.LT.-1.0) THEN EEE = 10.0*EEE ELSE EEE = EEE - 1.0 END IF ELSE IF (EEE.LE.-1.0) THEN EEE = EEE/10.0 ELSE IF (EEE.GT.1.0) THEN EEE = 10.0*EEE ELSE EEE = EEE + 1.0 END IF END IF C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) GO TO 55 END IF EU = EEE WU = SUM IF (SUM.GE.PIN) THEN EL = EU WL = WU 60 CONTINUE IF (WL.GE.PIN) THEN EU = EL WU = WL EEE = EL - ((WL-PIN+3.0)/U)**2 - 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EL = EEE WL = SUM GO TO 60 END IF ELSE EL = EEE WL = SUM END IF IF (LIMUP .AND. WU.LT.PIN) THEN EEE = ELIMUP ELSE IF (U.EQ.0.0) THEN EEE = EMAX + 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM END IF 70 CONTINUE IF (WU.LE.PIN) THEN EL = EU WL = WU EEE = EU + ((PIN-WU+3.0)/U)**2 + 1.0 C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) EU = EEE WU = SUM GO TO 70 END IF 80 CONTINUE IF (ABS(IMAX-IMIN).GE.2 .AND. EU.LE.EMAX) THEN IE = (IMAX+IMIN)/2 EEE = QS(IE)/WS(IE) C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.GT.PIN) THEN IMAX = IE WU = SUM EU = EEE ELSE IMIN = IE WL = SUM EL = EEE END IF GO TO 80 END IF C C Improve approximation for EIG using bisection or secant method. C Substitute 'ballpark' estimate if approximation grows too large. C DEDW = (EU-EL)/(WU-WL) FOLD = 0.0 IF (INTAB.EQ.1) BALLPK = (PIN/(A-B))**2 IF (INTAB.EQ.1) WRITE(21,*) ' BALLPK = ',BALLPK LOGIC = .TRUE. 90 CONTINUE IF (LOGIC) THEN LOGIC = (WL.LT.PIN-1.0 .OR. WU.GT.PIN+1.0) EEE = EL + DEDW*(PIN-WL) FNEW = MIN(PIN-WL,WU-PIN) IF (FNEW.GT.0.4*FOLD .OR. FNEW.LE.1.0) 1 EEE = 0.5*(EL+EU) IF (INTAB.EQ.1 .AND. ABS(EEE).GT.1.0E3*BALLPK) THEN EEE = BALLPK GO TO 100 ELSE IF (INTAB.NE.1 .AND. ABS(EEE).GT.1.0E6) THEN EEE = 1.0 GO TO 100 ELSE FOLD = FNEW C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS, 1 DELT,PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) IF (SUM.LT.PIN) THEN EL = EEE WL = SUM ELSE EU = EEE WU = SUM END IF DEDW = (EU-EL)/(WU-WL) GO TO 90 END IF END IF END IF C END (ESTIMATE-EIG) END IF 100 CONTINUE GUESS = EIG IF (LIMUP .AND. EEE.GE.ELIMUP) EEE = ELIMUP - 0.01 C DO (SET-INITIAL-INTERVAL-AND-MATCHPOINT) IF (GUESS.NE.0.0) THEN EEE=EIG C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(.FALSE.,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) END IF C C Choose initial interval as large as possible that avoids overflow. C JJL and JJR are boundary indices for nonnegativity of EIG*W-Q. C AA = -1.0 IF (SINGA) AA = TFROMI(JJL) BB = 1.0 IF (SINGB) BB = TFROMI(JJR) AA = MIN(-0.01,AA) BB = MAX(0.01,BB) AA = MIN(AA,-0.95) BB = MAX(BB,0.95) IF (OSCA) AA = -0.9999 IF (OSCB) BB = 0.9999 AAF = AAA BBF = BBB C C Determine boundary values ALFA and BETA for theta at A and B. C Z = 1.0 CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB, 1 BETA,JFLAG,DERIVR) IF (SINGB) BETA = PI - BETA C C Take boundary conditions into account in estimation of EIG. C PIN = EIGPI + BETA - ALFA IF (OSCA) PIN = PIN + ALFA IF (OSCB) PIN = PIN + PI - BETA IF (GUESS.EQ.0.0) THEN EEE = EL + DEDW*(PIN-WL) IF (.NOT.(OSCA .OR. OSCB) .AND. ABS(EEE).GT.1000.0) 1 EEE = SIGN(1000.0,EEE) IF (INTAB.EQ.1 .AND. ABS(EEE).GT.1.0E3*BALLPK) EEE = BALLPK END IF C DO (ESTIMATE-PHASE-ANGLE-CHANGE) CALL ESTPAC(OSCA.OR.OSCB,MF,ML,EEE,SUM0,QS,WS,DS,DELT, 1 PS,PSS,TAU,IA,IB,JJL,JJR,SUM,U,UT,ZAV) C END (ESTIMATE-PHASE-ANGLE-CHANGE) C C Choose the constant Z . C IF (U.GT.0.0) Z = ZAV/UT C C Reset boundary values ALFA and BETA . C CALL ALFBET(A,INTAB,AA,A1,A2,EEE,P0ATA,QFATA,SINGA,LCIRCA, 1 ALFA,KFLAG,DERIVL) CALL ALFBET(B,INTAB,BB,B1,B2,EEE,P0ATB,QFATB,SINGB,LCIRCB, 1 BETA,JFLAG,DERIVR) IF (SINGB) BETA = PI - BETA IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA WRITE(21,'(A,E22.14,A,E22.14)') 1 ' ALFA=',ALFA,' BETA=',BETA C C Choose initial matching point TMID . C IMID = 50 TMID = 0.5*(AA+BB) IF (PRIN) WRITE(IOUT,'(A,E15.7,A,F11.8,A,E15.7)') 1 ' estim=',EEE,' tmid=',TMID,' z=',Z IF (PRIN) WRITE(IOUT,'(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') 1 ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB WRITE(21,'(A,E15.7,A,F11.8,A,E15.7)') 1 ' estim=',EEE,' tmid=',TMID,' z=',Z WRITE(21,'(A,F11.8,A,F11.8,A,F11.8,A,F11.8)') 1 ' aaa=',AAA,' aa=',AA,' bb=',BB,' bbb=',BBB C END (SET-INITIAL-INTERVAL-AND-MATCHPOINT) IF (EIG.EQ.0.0 .AND. LIMUP .AND. EEE.GE.ELIMUP) 1 EEE = ELIMUP - 0.01 C DO (RESET-TMID) CALL SETMID(MF,ML,EEE,QS,WS,IMID,TMID) C END (RESET-TMID) IF (OSCA .OR. OSCB) THEN Z = 1.0 C DO (PREP-ZEEZ) DO 85 I=1,100 TEE(I) = 1.0 IF (JAY(I).NE.0) TEE(I) = TFROMI(JAY(I)) 85 CONTINUE C END (PREP-ZEEZ) END IF IF (ISLFUN.EQ.-1) THEN SLFUN(1) = TMID SLFUN(2) = AA SLFUN(3) = ALFA SLFUN(5) = BB SLFUN(6) = BETA + EIGPI SLFUN(9) = Z ADDD = .FALSE. MDTHZ = 0 IFLAG = 1 RETURN END IF C C End preliminary work, begin main task of computing EIG. C C Logical variables have the following meanings if true. C AOK - endpoint A is not singular. C BOK - endpoint B is not singular. C BRACKT - EIG has been bracketed. C CONVRG - convergence test for EIG has been successfully passed. C NEWTON - Newton iteration may be employed. C THELT0 - lower bound for EIG has been found. C THEGT0 - upper bound for EIG has been found. C LIMIT - upper bound exists with boundary conditions satisfied. C ONEDIG - most significant digit can be expected to be correct. C EIG = EEE NRAY = 1 OLDRAY = 1.0E+9 EXIT = .FALSE. FIRSTT = .TRUE. LOOP2 = 0 LOOP3 = 0 BESTEIG = EIG BESTEST = 1.0E+9 OLDEST = BESTEST ADTHETA = 1.0E+9 NEWTONF = .FALSE. CHNGEPS = .FALSE. EPSM = EPSMIN ENDA = .FALSE. ENDB = .FALSE. TSAVEL = -1.0 TSAVER = 1.0 BRS = .FALSE. BRSS = .FALSE. SAVERR = 1.0E+9 AAL = AA BBL = BB EPSL = EPS 110 CONTINUE C DO (INITIAL-IZE) BRACKT = .FALSE. CONVRG = .FALSE. THELT0 = .FALSE. THEGT0 = .FALSE. EIGLO = EMIN - 1.0 FLO = -5.0 FUP = 5.0 EIGLT = 0.0 EIGRT = 0.0 EIGUP = EMAX + 1.0 IF (LIMUP) EIGUP = MIN(EMAX,ELIMUP) DTHOLD = 1.0 C END (INITIAL-IZE) WRITE(21,*) WRITE(21,*) '---------------------------------------------' WRITE(21,*) ' INITIAL GUESS FOR EIG = ',EIG WRITE(21,*) ' aa,bb = ',AA,BB C DO UNTIL(CONVRG .OR. EXIT) DO 120 NITER = 1,40 WRITE(*,*) WRITE(*,*) ' ******************** ' C DO (SET-TMID-AND-BOUNDARY-CONDITIONS) WRITE(*,*) ' set tmid and boundary conditions ' V = EIG*WS(IMID) - QS(IMID) C IF (V.LE.0.0) DO (RESET-TMID) IF (V.LE.0.0) CALL SETMID(MF,ML,EIG,QS,WS,IMID,TMID) C END (RESET-TMID) C DO (RESET-BOUNDARY-CONDITIONS) DERIVL = 0.0 IF (SINGA) CALL ALFBET(A,INTAB,AA,A1,A2,EIG, 1 P0ATA,QFATA,.TRUE.,LCIRCA,ALFA,KFLAG,DERIVL) DERIVR = 0.0 IF (SINGB) THEN CALL ALFBET(B,INTAB,BB,B1,B2,EIG,P0ATB,QFATB, 1 .TRUE.,LCIRCB,BETA,JFLAG,DERIVR) BETA = PI - BETA END IF IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' alfa=',ALFA,' beta=',BETA WRITE(21,'(A,E22.14,A,E22.14)') 1 ' ALFA=',ALFA,' BETA=',BETA C END (RESET-BOUNDARY-CONDITIONS) C C Check that boundary conditions can be satisfied at singular C endpoints. If not, try for slightly altered EIG consistent C with boundary conditions. C IF (LIMUP .AND. EIG.NE.GUESS .AND. .NOT.BRACKT) THEN KFLAG = 1 IF (SINGA .AND. .NOT.LCIRCA) CALL ALFBET(A,INTAB,AA, 1 A1,A2,EIG,P0ATA,QFATA,.TRUE.,.FALSE.,TMP,KFLAG,TMP) JFLAG = 1 IF (SINGB .AND. .NOT.LCIRCB) CALL ALFBET(B,INTAB,BB, 1 B1,B2,EIG,P0ATB,QFATB,.TRUE.,.FALSE.,TMP,JFLAG,TMP) IF ((KFLAG.NE.1 .OR. JFLAG.NE.1) .AND. 1 (THELT0 .AND. EIGLO.LT.ELIMUP)) THEN EIGUP = MIN(ELIMUP+2.0*EPSMIN,EIGUP) IF (EIG.NE.EIGLO .AND. EIG.NE.EIGUP) THEN EIG = 0.05*EIGLO + 0.95*EIGUP ELSE IFLAG = 11 WRITE(21,*) ' IFLAG = 11 ' EXIT = .TRUE. GO TO 130 END IF END IF END IF C END (SET-TMID-AND-BOUNDARY-CONDITIONS) C DO (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) IF (PRIN) WRITE(IOUT,'(/A,E22.14,A,E10.3,A,E10.3)') 1 ' guess=',EIG,' eps=',EPS,' tmid=',TMID C DO (INTEGRATE-FOR-DTHETA) C DO (SET-INITIAL-CONDITIONS) THA = ALFA DTHDEA = DERIVL DTHDAA = 0.0 IF (SINGA .AND. .NOT.LCIRCA) THEN CALL DXDT(AA,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDAA = -(COS(ALFA)**2/PX + C*SIN(ALFA)**2)*DT C C Two special cases for DTHDAA . C IF (C.GE.0.0 .AND. P0ATA.LT.0.0 .AND. QFATA.LT.0.0) 1 DTHDAA = DTHDAA + ALFA*DT/(X-A) IF (C.GE.0.0 .AND. P0ATA.GT.0.0 .AND. QFATA.GT.0.0) 1 DTHDAA = DTHDAA + (ALFA-0.5*PI)*DT/(X-A) END IF THB = BETA DTHDEB = -DERIVR DTHDBB = 0.0 IF (SINGB .AND. .NOT.LCIRCB) THEN CALL DXDT(BB,DT,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = EIG*WX - QX DTHDBB = -(COS(BETA)**2/PX + C*SIN(BETA)**2)*DT C C Two special cases for DTHDBB . C IF (C.GE.0.0 .AND. P0ATB.LT.0.0 .AND. QFATB.LT.0.0) 1 DTHDBB = DTHDBB + (PI-BETA)*DT/(B-X) IF (C.GE.0.0 .AND. P0ATB.GT.0.0 .AND. QFATB.GT.0.0) 1 DTHDBB = DTHDBB + (0.5*PI-BETA)*DT/(B-X) END IF C END (SET-INITIAL-CONDITIONS) EIGSAV = EIG C C YL = (theta,d(theta)/d(eig),d(theta)/da) C YL(1) = ALFA YL(2) = DTHDEA YL(3) = 0.0 C CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS,YL,ERL, 1 LCIRCA,AOK,SINGA,OSCA,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 51 WRITE(21,*) ' IFLAG = 51 ' EXIT = .TRUE. GO TO 130 END IF DTHDA = DTHDAA*EXP(-2.0*YL(3)) C C YR = (theta,d(theta)/d(eig),d(theta)/db) C YR(1) = BETA + EIGPI - PI YR(2) = DTHDEB YR(3) = 0.0 C CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS,YR,ERR, 1 LCIRCB,BOK,SINGB,OSCB,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 52 WRITE(21,*) ' IFLAG = 52 ' EXIT = .TRUE. GO TO 130 END IF DTHDB = DTHDBB*EXP(-2.0*YR(3)) C ER1 = ERL(1) - ERR(1) ER2 = ERL(2) - ERR(2) C IF (OSCA .OR. OSCB) THEN Z = 1.0 CALL DXDT(TMID,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) EIGSAV = 0.0 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,A1,A2,EPS, 1 YZL,ERL,LCIRCA,AOK,SINGA,OSCA,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 53 WRITE(21,*) ' IFLAG = 53 ' EXIT = .TRUE. GO TO 130 END IF CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,B1,B2,EPS, 1 YZR,ERR,LCIRCB,BOK,SINGB,OSCB,IFLAG) IF (IFLAG.EQ.5) THEN IFLAG = 54 WRITE(21,*) ' IFLAG = 54 ' EXIT = .TRUE. GO TO 130 END IF EIGSAV = EIG DTHZ = YZR(1) - YZL(1) MDTHZ = DTHZ/PI REMZ = DTHZ - MDTHZ*PI IF (DTHZ.LT.0.0 .AND. REMZ.LT.0.0) THEN MDTHZ = MDTHZ - 1 REMZ = REMZ + PI END IF IF (REMZ.GT.3.14) MDTHZ = MDTHZ + 1 END IF C C Record the environment parameters of this most recent C successful integration. C AAS = AA BBS = BB C C DTHETA measures theta difference from left and right integrations. C C DO (FORM-DTHETA) DTHETA = YL(1) - YR(1) - EIGPI IF (OSCA .OR. OSCB) DTHETA = DTHETA + MDTHZ*PI DTHDE = YL(2) - YR(2) C END (FORM-DTHETA) ADTHETA = ABS(DTHETA) ONEDIG = (ABS(ER1).LE.0.5*ABS(DTHETA) .AND. 1 ABS(ER2).LE.0.5*ABS(DTHDE)) .OR. 2 MAX(ADTHETA,ABS(ER1)).LT.1.0E-6 FIRSTT = .FALSE. C END (INTEGRATE-FOR-DTHETA) CHNGEPS = .FALSE. CONVRG = .FALSE. OLDNEWT = NEWTON NEWTON = ABS(DTHETA).LT.0.06 .AND. BRACKT IF (NEWTON) 1 ONEDIG = ONEDIG .OR. ABS(DTHETA+ER1).LT.0.5*DTHOLD IF (PRIN) WRITE(IOUT,'(A,E15.7,A,E15.7)') 1 ' dtheta=',DTHETA,' dthde=',DTHDE IF (PRIN) WRITE(IOUT,'(/A,E15.7,A,E15.7)') 1 ' thetal=',YL(1),' thetar=',YR(1) C END (OBTAIN-DTHETA-WITH-ONE-CORRECT-DIGIT) IF (.NOT.ONEDIG .AND. BRS) THEN EXIT = .TRUE. WRITE(21,*) ' NOT ONEDIG ' GO TO 130 END IF C DO (SET-BRACKET-DATA) WRITE(*,*) ' set-bracket ' IF (DTHETA.GT.0.0) THEN IF (.NOT.THEGT0 .OR. EIG.LE.EIGUP) THEN THEGT0 = .TRUE. EIGUP = EIG FUP = DTHETA EIGRT = EIG - DTHETA/DTHDE END IF ELSE IF (.NOT.THELT0 .OR. EIG.GE.EIGLO) THEN THELT0 = .TRUE. EIGLO = EIG FLO = DTHETA EIGLT = EIG - DTHETA/DTHDE END IF END IF C C EIG is bracketed when both THEGT0=.true. and THELT0=.true. C BRACKT = THELT0 .AND. THEGT0 IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eigrt=',EIGRT,' eigup=',EIGUP IF (PRIN) WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' eiglt=',EIGLT,' eiglo=',EIGLO C END (SET-BRACKET-DATA) IF (BRACKT) LOOP2 = 0 C DO (TEST-FOR-CONVERGENCE) C C Measure convergence after adding separate contributions to error. C FLOUP = MIN(ABS(FLO),ABS(FUP)) T1 = (ABS(DTHETA)+MAX(ABS(ERL(1)),ABS(ERR(1))))/ABS(DTHDE) T2 = (1.0+AA)*ABS(DTHDA)/ABS(DTHDE) T3 = (1.0-BB)*ABS(DTHDB)/ABS(DTHDE) WRITE(21,*) ' FLO,FUP,FLOUP = ',FLO,FUP,FLOUP WRITE(21,*) ' DTHDE,DTHDA,DTHDB = ',DTHDE,DTHDA,DTHDB PT2 = (AAF-AA)*DTHDA/DTHDE PT3 = (BBF-BB)*DTHDB/DTHDE IF (.NOT.TRUNKA) THEN T2 = 0.0 PT2 = 0.0 END IF IF (.NOT.TRUNKB) THEN T3 = 0.0 PT3 = 0.0 END IF ESTERR = T1 + T2 + T3 ESTERR = ESTERR/MAX(ONE,ABS(EIG)) CONVRG = ESTERR.LE.TAUM .AND. NEWTON WRITE(21,*) ' T1,T2,T3 = ',T1,T2,T3 WRITE(21,*) ' PT2,PT3 = ',PT2,PT3 WRITE(21,*) ' TMID,EPS = ',TMID,EPS WRITE(21,*) ' ONEDIG,BRACKT,NEWTON,CONVRG = ', 1 ONEDIG,BRACKT,NEWTON,CONVRG WRITE(21,*) ' EIG,DTHETA,ESTERR = ',EIG,DTHETA,ESTERR IF (BRACKT .AND. (ESTERR.LT.BESTEST .OR. .NOT.BRS) .AND. 1 ADTHETA.LT.0.1) THEN BESTAA = AA BESTBB = BB BESTMID = TMID BESTEPS = EPS BESTEIG = EIG BESTEST = ESTERR BRS = BRACKT IF (BRS) BRSS = BRS WRITE(21,*) ' BESTEIG,BESTEST = ',BESTEIG,BESTEST WRITE(21,*) ' BRS = ',BRS END IF IF (THEGT0) WRITE(21,*) ' EIGUP = ',EIGUP IF (THELT0) WRITE(21,*) ' EIGLO = ',EIGLO WRITE(21,*) '---------------------------------------------' IF (PRIN) WRITE(IOUT,'(A,L2)') ' converge=',CONVRG IF (PRIN .AND. .NOT.CONVRG) WRITE(IOUT,'(A,E15.7)') 1 ' estim. acc.=',ESTERR C END (TEST-FOR-CONVERGENCE) IF (CONVRG) THEN WRITE(*,*) ' number of iterations was ',NITER WRITE(21,*) ' NUMBER OF ITERATIONS WAS ',NITER WRITE(*,*) '-----------------------------------------------' GO TO 130 ELSE IF (NEWTON) THEN IF (OLDNEWT .AND. ADTHETA.GT.0.8*ABS(DTHOLD)) THEN WRITE(21,*) ' ADTHETA,DTHOLD = ',ADTHETA,DTHOLD WRITE(21,*) ' NEWTON DID NOT IMPROVE EIG ' NEWTONF = .TRUE. LOOP3 = LOOP3 + 1 ELSE IF (TRUNKA .OR. TRUNKB) THEN ENDA = ADTHETA.LT.1.0 .AND. ABS(PT2).GT.MAX(TAUM,T1) 1 .AND. TRUNKA ENDB = ADTHETA.LT.1.0 .AND. ABS(PT3).GT.MAX(TAUM,T1) 1 .AND. TRUNKB IF (ENDA .OR. ENDB) THEN NEWTON = .FALSE. ELSE IF ((T2+T3).GT.T1 .AND. ADTHETA.LT.1.0 .AND. 1 (AA.LE.AAF .AND. BB.GE.BBF)) THEN WRITE(*,*) ' RESIDUAL TRUNCATION ERROR DOMINATES ' EXIT = .TRUE. IFLAG = 9 WRITE(21,*) ' IFLAG = 9 ' GO TO 130 END IF END IF IF (NEWTONF .OR. ENDA .OR. ENDB) THEN WRITE(21,*) ' NEWTONF,ENDA,ENDB = ',NEWTONF,ENDA,ENDB EXIT = .TRUE. GO TO 130 END IF C DO (NEWTON'S-METHOD) WRITE(*,*) ' Newton''s method ' RLX = 1.2 IF (BRACKT) RLX = 1.0 EIG = EIG - RLX*DTHETA/DTHDE IF (EIG.LE.EIGLO .OR. EIG.GE.EIGUP) 1 EIG = 0.5*(EIGLO+EIGUP) WRITE(21,*) ' NEWTON: EIG = ',EIG C END (NEWTON'S-METHOD) ELSE IF (BRACKT) THEN WRITE(*,*) ' bracket ' C DO (SECANT-METHOD) WRITE(*,*) ' do secant method ' FMAX = MAX(-FLO,FUP) EOLD = EIG EIG = 0.5*(EIGLO+EIGUP) IF (FMAX.LE.1.5) THEN U = -FLO/(FUP-FLO) DIST = EIGUP - EIGLO EIG = EIGLO + U*DIST V = MIN(EIGLT,EIGRT) IF (EIG.LE.V) EIG = 0.5*(EIG+V) V = MAX(EIGLT,EIGRT) IF (EIG.GE.V) EIG = 0.5*(EIG+V) DE = EIG - EOLD IF (ABS(DE).LT.EPSMIN) THEN TOL = ABS(DE)/MAX(ONE,ABS(EIG)) IFLAG = 6 EXIT = .TRUE. GO TO 130 END IF END IF WRITE(21,*) ' SECANT: EIG = ',EIG C END (SECANT-METHOD) ELSE C DO (TRY-FOR-BRACKET) LOOP2 = LOOP2 + 1 IF (LOOP2.GT.9 .AND. .NOT.LIMUP) THEN IFLAG = 12 WRITE(21,*) ' IFLAG = 12 ' EXIT = .TRUE. GO TO 130 END IF IF (EIG.EQ.EEE) THEN IF (GUESS.NE.0.0) DEDW = 1.0/DTHDE CHNG = -0.6*(DEDW+1.0/DTHDE)*DTHETA IF (EIG.NE.0.0 .AND. ABS(CHNG).GT.0.1*ABS(EIG)) 1 CHNG = -0.1*SIGN(EIG,DTHETA) ELSE CHNG = -1.2*DTHETA/DTHDE IF (CHNG.EQ.0.) CHNG = 0.1*MAX(1.0,ABS(EIG)) WRITE(21,*) ' IN BRACKET, 1,CHNG = ',CHNG C C Limit change in EIG to a factor of 10. C IF (ABS(CHNG).GT.(1.0+10.0*ABS(EIG))) THEN CHNG = SIGN(1.0+10.0*ABS(EIG),CHNG) WRITE(21,*) ' IN BRACKET, 2,CHNG = ',CHNG ELSE IF (ABS(EIG).GE.1.0 .AND. 1 ABS(CHNG).LT.0.1*ABS(EIG)) THEN CHNG = 0.1*SIGN(EIG,CHNG) WRITE(21,*) ' IN BRACKET, 3,CHNG = ',CHNG END IF IF (DTHOLD.LT.0.0 .AND. LIMUP .AND. 1 CHNG.GT.(ELIMUP-EIG)) THEN CHNG = 0.95*(ELIMUP-EIG) WRITE(21,*) ' ELIMUP,EIG,CHNG = ', 1 ELIMUP,EIG,CHNG IF (CHNG.LT.EPSMIN) THEN WRITE(*,*) ' ELIMUP,EIG = ',ELIMUP,EIG WRITE(21,*) ' IN BRACKET, CHNG.LT.EPSMIN ' ENDA = TRUNKA .AND. AA.GT.AAF .AND. 1 (0.5*DTHETA+(AAF-AA)*DTHDA).GT.0.0 ENDB = TRUNKB .AND. BB.LT.BBF .AND. 1 (0.5*DTHETA-(BBF-BB)*DTHDB).GT.0.0 IF (.NOT.(ENDA .OR. ENDB)) THEN NUMEIG = NEIG - INT(-DTHETA/PI) WRITE(*,*) ' new numeig = ',NUMEIG WRITE(21,*) ' NEW NUMEIG = ',NUMEIG END IF IFLAG = 3 GO TO 150 END IF END IF END IF EOLD = EIG CHNGLIM = 2.0*ESTERR*MAX(ONE,ABS(EIG)) WRITE(21,*) ' CHNGLIM = ',CHNGLIM IF (ADTHETA.LT.0.06 .AND. ABS(CHNG).GT.CHNGLIM .AND. 1 CHNGLIM.NE.0.0) CHNG = SIGN(CHNGLIM,CHNG) IF ((THELT0 .AND. CHNG.LT.0.0) .OR. 1 (THEGT0 .AND. CHNG.GT.0.0)) CHNG = -CHNG EIG = EIG + CHNG WRITE(21,*) ' BRACKET: EIG = ',EIG C END (TRY-FOR-BRACKET) END IF END IF IF (IFLAG.EQ.3) GO TO 130 IF (NITER.GE.3 .AND. DTHOLDY.EQ.DTHETA) THEN IFLAG = 7 WRITE(21,*) ' IFLAG = 7 ' EXIT = .TRUE. GO TO 130 END IF DTHOLDY = DTHOLD DTHOLD = DTHETA WRITE(*,*) ' number of iterations was ',NITER WRITE(*,*) '-----------------------------------------------' 120 CONTINUE IFLAG = 8 WRITE(21,*) ' IFLAG = 8 ' EXIT = .TRUE. 130 CONTINUE IF (AA.EQ.AAL .AND. BB.EQ.BBL .AND. EPS.LT.EPSL .AND. 1 ESTERR.GE.0.5*SAVERR) GO TO 140 EPSL = EPS AAL = AA BBL = BB TOL = BESTEST EIG = BESTEIG IF (EXIT) THEN WRITE(21,*) ' EXIT ' IF (FIRSTT) THEN IF (IFLAG.EQ.51 .OR. IFLAG.EQ.53) THEN IF (AA.LT.-0.1) THEN WRITE(*,*) ' FIRST COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' FIRST COMPLETE INTEGRATION FAILED. ' IF (AA.EQ.-1.0) GO TO 150 AAF = AA CALL AABB(AA,-ONE) WRITE(21,*) ' aa MOVED FROM ',AAf,' IN TO ',AA EXIT = .FALSE. GO TO 110 ELSE WRITE(21,*) ' aa.GE.-0.1 ' IFLAG = 13 GO TO 150 END IF ELSE IF (IFLAG.EQ.52 .OR. IFLAG.EQ.54) THEN IF (BB.GT.0.1) THEN WRITE(*,*) ' FIRST COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' FIRST COMPLETE INTEGRATION FAILED. ' IF (BB.EQ.1.0) GO TO 150 BBF = BB CALL AABB(BB,-ONE) WRITE(21,*) ' bb MOVED FROM ',BBf,' IN TO ',BB EXIT = .FALSE. GO TO 110 ELSE WRITE(21,*) ' bb.LE.0.1 ' IFLAG = 14 GO TO 150 END IF END IF ELSE IF (IFLAG.EQ.51 .OR. IFLAG.EQ.53) THEN WRITE(*,*) ' A COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' A COMPLETE INTEGRATION FAILED. ' IF (CHNGEPS) THEN EPS = 5.0*EPS EPSM = EPS WRITE(21,*) ' EPS INCREASED TO ',EPS ELSE AAF = AA CALL AABB(AA,-ONE) WRITE(21,*) ' aa MOVED FROM ',AAf,' IN TO ',AA END IF EXIT = .FALSE. GO TO 110 ELSE IF (IFLAG.EQ.52 .OR. IFLAG.EQ.54) THEN WRITE(*,*) ' A COMPLETE INTEGRATION FAILED. ' WRITE(21,*) ' A COMPLETE INTEGRATION FAILED. ' IF (CHNGEPS) THEN EPS = 5.0*EPS EPSM = EPS WRITE(21,*) ' EPS INCREASED TO ',EPS ELSE BBF = BB CALL AABB(BB,-ONE) WRITE(21,*) ' bb MOVED FROM ',BBf,' IN TO ',BB END IF EXIT = .FALSE. GO TO 110 ELSE IF (IFLAG.EQ.6) THEN WRITE(*,*) ' IN SECANT, CHNG.LT.EPSMIN ' WRITE(21,*) ' IN SECANT, CHNG.LT.EPSMIN ' GO TO 140 ELSE IF (IFLAG.EQ.7) THEN WRITE(*,*) ' DTHETA IS REPEATING ' WRITE(21,*) ' DTHETA IS REPEATING ' GO TO 140 ELSE IF (IFLAG.EQ.8) THEN WRITE(*,*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' WRITE(21,*) ' NUMBER OF ITERATIONS REACHED SET LIMIT ' GO TO 140 ELSE IF (IFLAG.EQ.9) THEN WRITE(21,*) ' RESIDUAL TRUNCATION ERROR DOMINATES ' GO TO 140 ELSE IF (IFLAG.EQ.11) THEN WRITE(*,*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' WRITE(21,*) ' IN TRY FOR BRACKET, CHNG.LT.EPSMIN ' GO TO 140 ELSE IF (IFLAG.EQ.12) THEN WRITE(*,*) ' FAILED TO GET A BRACKET. ' WRITE(21,*) ' FAILED TO GET A BRACKET. ' GO TO 140 ELSE IF (NEWTONF .OR. .NOT.ONEDIG) THEN IF (LOOP3.GE.3) THEN WRITE(21,*) ' NEWTON IS NOT GETTING ANYWHERE ' NEWTONF = .FALSE. GO TO 140 END IF WRITE(21,*) ' BESTEST,OLDEST = ',BESTEST,OLDEST IF (EPS.GT.EPSM .AND. BESTEST.LT.OLDEST) THEN CHNGEPS = .TRUE. SAVERR = ESTERR EPS = 0.2*EPS WRITE(*,*) ' EPS REDUCED TO ',EPS WRITE(21,*) ' EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST GO TO 110 ELSE IF (EPS.LE.EPSM) THEN WRITE(*,*) ' EPS CANNOT BE REDUCED FURTHER. ' WRITE(21,*) ' EPS CANNOT BE REDUCED FURTHER. ' IFLAG = 2 GO TO 140 ELSE WRITE(*,*) ' no more improvement ' WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF END IF ELSE IF (ENDA) THEN CALL AABB(AA,ONE) AA = MAX(AA,AAA) IF (AA.LE.AAF) THEN WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF WRITE(*,*) ' aa MOVED OUT TO ',AA WRITE(21,*) ' aa MOVED OUT TO ',AA EXIT = .FALSE. GO TO 110 ELSE IF (ENDB) THEN CALL AABB(BB,ONE) BB = MIN(BB,BBB) IF (BB.GE.BBF) THEN WRITE(21,*) ' NO MORE IMPROVEMENT ' GO TO 140 END IF WRITE(*,*) ' bb MOVED OUT TO ',BB WRITE(21,*) ' bb MOVED OUT TO ',BB EXIT = .FALSE. GO TO 110 END IF END IF 140 CONTINUE C C If CONVRG is false, check that any truncation error might possibly C be reduced or that the integrations might be done more accurately. C IF (.NOT.CONVRG .AND. IFLAG.LT.50 .AND. IFLAG.NE.11) THEN SAVAA = AA SAVBB = BB IF (EPS.GT.EPSM .AND. ESTERR.LT.0.5*SAVERR) THEN WRITE(21,*) ' SAVERR,ESTERR = ',SAVERR,ESTERR SAVERR = ESTERR EPS = 0.2*EPS WRITE(*,*) ' EPS REDUCED TO ',EPS WRITE(21,*) ' 2,EPS REDUCED TO ',EPS EXIT = .FALSE. NEWTON = .FALSE. OLDEST = BESTEST GO TO 110 ELSE IF (ABS(PT2).GT.TAUM .OR. ABS(PT3).GT.TAUM) THEN IF ((AAS-AAF).GT.2.0*EPSMIN .AND. ABS(PT2).GT.TAUM) THEN CALL AABB(AA,ONE) AA = MAX(AA,AAA) IF (AA.GT.AAF .AND. AA.LT.SAVAA) THEN WRITE(*,*) ' aa MOVED OUT TO ',AA WRITE(21,*) ' 3,aa MOVED OUT TO ',AA EXIT = .FALSE. END IF END IF IF ((BBF-BBS).GT.2.0*EPSMIN .AND. ABS(PT3).GT.TAUM) THEN CALL AABB(BB,ONE) BB = MIN(BB,BBB) IF (BB.GT.SAVBB .AND. BB.LT.BBF) THEN WRITE(*,*) ' bb MOVED OUT TO ',BB WRITE(21,*) ' 3,bb MOVED OUT TO ',BB EXIT = .FALSE. END IF END IF IF (.NOT.EXIT .AND. (AA.NE.SAVAA .OR. BB.NE.SAVBB)) 1 GO TO 110 END IF END IF IF (PRIN) WRITE(IOUT,'(A,I7,A,E22.14,A,E10.3)') 1 ' numeig=',NUMEIG,' eig=',EIG,' tol=',TOL WRITE(21,*) 'NUMEIG = ',NUMEIG,' EIG = ',EIG,' TOL = ',TOL IF (BRSS .AND. BESTEST.LT.0.05) THEN C DO (COMPUTE-EIGENFUNCTION-DATA) C C Convert from T to X values, fill 7 of first 9 locations of SLFUN. C CALL DXDT(TMID,TMP,XMID) CALL DXDT(AA,TMP,XAA) CALL DXDT(BB,TMP,XBB) SLFUN(1) = XMID SLFUN(2) = XAA SLFUN(3) = ALFA SLFUN(5) = XBB SLFUN(6) = BETA + EIGPI SLFUN(8) = EPS SLFUN(9) = Z C C Compute SLFUN(4), SLFUN(7) towards normalizing the eigenfunction. C EIGSAV = EIG THA = ALFA DTHDAAX = 0.0 YL(1) = 0.0 YL(2) = 0.0 YL(3) = 0.0 CALL INTEG(AA,THA,DTHDAAX,DTHDEA,TMID,A1,A2,EPS,YL,ERL, 1 LCIRCA,AOK,SINGA,OSCA,JFLAG) THB = BETA DTHDBBX = 0.0 CALL INTEG(BB,THB,DTHDBBX,DTHDEB,TMID,B1,B2,EPS,YR,ERR, 1 LCIRCB,BOK,SINGB,OSCB,JFLAG) YR(1) = YR(1) + EIGPI SL = SIN(YL(1)) SR = SIN(YR(1)) CL = COS(YL(1)) CR = COS(YR(1)) UL = (YL(2)-DTHDEA*EXP(-2.0*YL(3)))*Z UR = (YR(2)-DTHDEB*EXP(-2.0*YR(3)))*Z DUM = 0.5*LOG(UL-UR) SLFUN(4) = -YL(3) - DUM SLFUN(7) = -YR(3) - DUM C END (COMPUTE-EIGENFUNCTION-DATA) C DO (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C Perform final check on EIG. Return IFLAG = 2 C if not accurate enough. C DEN = UL*SR*SR - UR*SL*SL E = ABS(SR)/SQRT(DEN) PSIL = E*SL PSIPL = E*CL*Z SQL = E*E*UL E = ABS(SL)/SQRT(DEN) PSIR = E*SR PSIPR = E*CR*Z SQR = E*E*UR ADDD = PSIL*PSIR.LT.0.0 .AND. PSIPL*PSIPR.LT.0.0 RAY = EIG + (PSIL*PSIPL-PSIR*PSIPR)/(SQL-SQR) IF (PRIN) THEN WRITE(IOUT,'(A,E22.14)') ' ray=',RAY WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psil=',PSIL,' psir=',PSIR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' psipl=',PSIPL,' psipr=',PSIPR WRITE(IOUT,'(A,E22.14,A,E22.14)') 1 ' sql=',SQL,' sqr=',SQR END IF C END (CHECK-MATCHING-VALUES-OF-EIGENFUNCTION) C C If next condition is .true., then something is apparently wrong C with the accuracy of EIG. Bisect and go through the loop again. C WRITE(21,*) ' EIG,RAY = ',EIG,RAY IF (ABS(RAY-EIG).GT.2.0*TAUM*MAX(ONE,ABS(EIG))) THEN NRAY = NRAY + 1 WRITE(*,*) ' nray = ',nray WRITE(21,*) ' NRAY,RAY,OLDRAY = ',NRAY,RAY,OLDRAY IF (ESTERR.GE.0.5*SAVERR) THEN IFLAG = 2 GO TO 150 END IF EIG = 0.5*(EIG+RAY) SAVRAY = OLDRAY OLDRAY = RAY IF (OLDRAY.NE.SAVRAY .AND. NRAY.LT.3) GO TO 110 END IF C DO (GENERATE-EIGENFUNCTION-VALUES) CALL EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN) C END (GENERATE-EIGENFUNCTION-VALUES) IFLAG = 1 END IF C C IF THE ESTIMATED ACCURACY IMPLIES THAT THE COMPUTED VALUE C OF THE EIGENVALUE IS UNCERTAIN, SIGNAL BY IFLAG = 2. C IF ((ABS(EIG).LE.ONE .AND. TOL.GE.ABS(EIG)) .OR. 1 (ABS(EIG).GT.ONE .AND. TOL.GE.ONE)) IFLAG = 2 C 150 CONTINUE WRITE(21,*) ' BEST aa,bb,TMID,EPS = ', 1 BESTAA,BESTBB,BESTMID,BESTEPS WRITE(21,*) ' BRS,BESTEIG,BESTEST = ',BRS,BESTEIG,BESTEST WRITE(21,*) ' IFLAG = ',IFLAG WRITE(21,*) '********************************************' WRITE(21,*) RETURN END SUBROUTINE AABB(TEND,OUT) DOUBLE PRECISION TEND,OUT C ********** C C This subroutine moves aa or bb further out or closer in. C TEND is either aa or bb. If OUT is positive, TEND is moved C further out, and if OUT is negative, TEND is moved closer in. C C ********** C .. Local Scalars .. INTEGER J DOUBLE PRECISION DIF,REM,TTEND C .. C .. Intrinsic Functions .. INTRINSIC ABS,LOG10,SIGN C .. REM = 1.0 - ABS(TEND) J = LOG10(5.0/REM) IF (OUT.GT.0.0) J = J + 1 DIF = 10.0**(-J) TTEND = SIGN(1.0-DIF,TEND) IF (TTEND.EQ.TEND) THEN IF (OUT.LT.0.0) TTEND = SIGN(1.0-10.0*DIF,TEND) IF (OUT.GT.0.0) TTEND = SIGN(1.0-0.1*DIF,TEND) END IF TEND = TTEND RETURN END SUBROUTINE ALFBET(XEND,INTAB,TT,COEF1,COEF2,EIG,P0,QF,SING, 1 LCIRC,VALUE,IFLAG,DERIV) INTEGER INTAB,IFLAG LOGICAL SING,LCIRC DOUBLE PRECISION XEND,TT,COEF1,COEF2,EIG,P0,QF,VALUE,DERIV C ********** C C This subroutine computes a boundary value for a specified endpoint C of the interval for a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. It is called C from SLEIGN2. Both regular and singular endpoints are treated. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt,extrap C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. LOGICAL LOGIC DOUBLE PRECISION C,CD,D,HH,ONE,PI,PUP,PVP,PX,QX,WX,T,TEMP,TTS, 1 U,V,X,XDENOM,XNUM C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT,EXTRAP,UV C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEE/Z C .. C Set machine dependent constant. C C PI (variable ONE set to 1.0 eases precision conversion). ONE = 1.0 PI = 4.0*ATAN(ONE) C IFLAG = 1 DERIV = 0.0 IF (.NOT.SING) THEN VALUE = 0.5*PI IF (COEF1.NE.0.0) VALUE = ATAN(-Z*COEF2/COEF1) LOGIC = (TT.LT.0.0 .AND. VALUE.LT.0.0) .OR. 1 (TT.GT.0.0 .AND. VALUE.LE.0.0) IF (LOGIC) VALUE = VALUE + PI ELSE IF (LCIRC) THEN CALL DXDT(TT,TEMP,X) CALL UV(X,U,PUP,V,PVP,TEMP,TEMP) XNUM = COEF1*U+COEF2*V XDENOM = (COEF1*PUP+COEF2*PVP)/Z VALUE = ATAN2(XNUM,XDENOM) IF (XNUM.LT.0.0) VALUE = VALUE + 2.0*PI ELSE LOGIC = (INTAB.EQ.2 .AND. TT.GT.0.0) .OR. 1 (INTAB.EQ.3 .AND. TT.LT.0.0) .OR. 2 INTAB.EQ.4 .OR. (P0.GT.0.0 .AND. QF.LT.0.0) IF (LOGIC) THEN T = SIGN(ONE,TT) TTS = TT CALL EXTRAP(T,TTS,EIG,VALUE,DERIV,IFLAG) ELSE CALL DXDT(TT,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z C = 2.0*(EIG*WX-QX) IF (C.LT.0.0) THEN VALUE = 0.0 IF (P0.GT.0.0) VALUE = 0.5*PI ELSE HH = ABS(XEND-X) D = 2.0*HH/PX CD = C*D*HH IF (P0.GT.0.0) THEN VALUE = C*HH IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) VALUE = VALUE + 0.5*PI ELSE VALUE = D IF (CD.LT.1.0) VALUE = VALUE/(1.0+SQRT(1.0-CD)) END IF END IF END IF END IF RETURN END SUBROUTINE DXDT(T,DT,X) DOUBLE PRECISION T,DT,X C ********** C C This subroutine transforms coordinates from T on (-1,1) to C X on (A,B) in the solution of a Sturm-Liouville problem. C It is called from subroutines SLEIGN2, ALFBET, F, and EXTRAP. C C ********** C .. Scalars in Common .. INTEGER INTAB DOUBLE PRECISION A,B,C1,C2 C .. C .. Local Scalars .. DOUBLE PRECISION U C .. C .. Intrinsic Functions .. INTRINSIC ABS C .. C .. Common blocks .. COMMON /DATADT/A,B,C1,C2,INTAB C .. U = C1*T + C2 GO TO (10,20,30,40), INTAB 10 CONTINUE DT = C1*0.5*(B-A) X = 0.5*((B+A)+(B-A)*U) RETURN 20 CONTINUE DT = C1*2.0/(1.0-U)**2 X = A + (1.0+U)/(1.0-U) RETURN 30 CONTINUE DT = C1*2.0/(1.0+U)**2 X = B - (1.0-U)/(1.0+U) RETURN 40 CONTINUE DT = C1/(1.0-ABS(U))**2 X = U/(1.0-ABS(U)) RETURN END SUBROUTINE EIGFCN(EIGPI,A1,A2,B1,B2,AOK,SINGA,LCIRCA,OSCA, 1 BOK,SINGB,LCIRCB,OSCB,SLFUN,ISLFUN) INTEGER ISLFUN LOGICAL AOK,SINGA,LCIRCA,OSCA,BOK,SINGB,LCIRCB,OSCB DOUBLE PRECISION EIGPI,A1,A2,B1,B2 DOUBLE PRECISION SLFUN(ISLFUN+9) C ********** C ********** C .. Scalars in Common .. INTEGER MDTHZ LOGICAL ADDD DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,TMID C .. C .. Local Scalars .. INTEGER I,IFLAG,J,NMID LOGICAL LCIRC,OK,SING DOUBLE PRECISION DTHDAT,DTHDBT,DTHDET,EFF,T,THT,TM C .. C .. Local Arrays .. DOUBLE PRECISION ERL(3),ERR(3),YL(3),YR(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC EXP,SIN C .. C .. Common blocks .. COMMON /TDATA/AA,TMID,BB,DTHDAA,DTHDBB,ADDD,MDTHZ C .. C C WARNING: In this program it is assumed that the points T C in SLFUN all lie within the interval (AA,BB). C C Calculate selected eigenfunction values by integration (over T). C NMID = 0 DO 10 I=1,ISLFUN IF (SLFUN(9+I).LE.TMID) NMID = I 10 CONTINUE IF (NMID.GT.0) THEN T = AA YL(1) = SLFUN(3) YL(2) = 0.0 YL(3) = 0.0 LCIRC = LCIRCA OK = AOK SING = SINGA EFF = 0.0 DO 20 J=1,NMID TM = SLFUN(J+9) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YL(1) DTHDAT = DTHDAA*EXP(-2.0*EFF) DTHDET = YL(2) IF (TM.GT.AA) THEN CALL INTEG(T,THT,DTHDAT,DTHDET,TM,A1,A2,SLFUN(8), 1 YL,ERL,LCIRC,OK,SING,OSCA,IFLAG) IF (OSCA) THEN EFF = YL(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YL(3) END IF END IF SLFUN(J+9) = SIN(YL(1))*EXP(EFF+SLFUN(4)) T = TM IF (T.GT.-1.0) OK = .TRUE. IF (T.LT.-0.9 .AND .OSCA) THEN OK = .FALSE. T = AA YL(1) = SLFUN(3) YL(2) = 0.0 YL(3) = 0.0 END IF 20 CONTINUE END IF IF (NMID.LT.ISLFUN) THEN T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0 YR(3) = 0.0 LCIRC = LCIRCB OK = BOK SING = SINGB EFF = 0.0 DO 30 J=ISLFUN,NMID+1,-1 TM = SLFUN(J+9) IF (TM.LT.AA .OR. TM.GT.BB) THEN WRITE(*,*) ' t.lt.aa .or. t.gt.bb ' STOP END IF THT = YR(1) DTHDBT = DTHDBB*EXP(-2.0*EFF) DTHDET = YR(2) IF (TM.LT.BB) THEN CALL INTEG(T,THT,DTHDBT,DTHDET,TM,B1,B2,SLFUN(8), 1 YR,ERR,LCIRC,OK,SING,OSCB,IFLAG) IF (OSCB) THEN EFF = YR(3) ELSE LCIRC = .FALSE. SING = .FALSE. EFF = EFF + YR(3) END IF END IF SLFUN(J+9) = SIN(YR(1)+EIGPI)*EXP(EFF+SLFUN(7)) IF (ADDD) SLFUN(J+9) = -SLFUN(J+9) T = TM IF (T.LT.1.0) OK = .TRUE. IF (T.GT.0.9 .AND. OSCB) THEN OK = .FALSE. T = BB YR(1) = SLFUN(6) - EIGPI YR(2) = 0.0 YR(3) = 0.0 END IF 30 CONTINUE END IF RETURN END SUBROUTINE ESTPAC(IOSC,MF,ML,EEE,SUM0,QS,WS,DS,DELT,PS,PSS,TAU, 1 IA,IB,JJL,JJR,SUM,U,UT,ZAV) INTEGER MF,ML,IA,IB,JJL,JJR LOGICAL IOSC DOUBLE PRECISION EEE,SUM0,TAU,SUM,U,UT,ZAV DOUBLE PRECISION QS(ML),WS(ML),DS(ML),DELT(ML),PS(ML),PSS(ML) C ********** C C This subroutine estimates the change in 'phase angle' in the C eigenvalue determination of a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C The subroutine approximates the (trapezoidal rule) integral of C C sqrt((eig*w-q)/p) C C where the integral is taken over those X in (A,B) for which C C (eig*w-q)/p .gt. 0 C C ********** C .. Local Scalars .. INTEGER J,JJ,JSAV,MF1 DOUBLE PRECISION PSUM,RT,RTSAV,V,WW,WSAV,DPSUM,DPSUMT,ZAVJ,ZAVSAV C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION ZEE(100) C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX,MIN,SIGN,SQRT C .. C .. Common blocks .. COMMON /ZEEZ/JAY,ZEE C .. IA = MF IB = 80 C C SUM accumulates the integral approximation. U measures the total C length of subintervals where (EIG*W-Q)/P .gt. 0.0. ZAV is the C average value of sqrt((EIG*W-Q)*P) over those subintervals. C IF (.NOT.IOSC) THEN JJL = 99 JJR = 1 SUM = 0.0 U = 0.0 UT = 0.0 ZAV = 0.0 WSAV = EEE*WS(MF) - QS(MF) IF (WSAV.GT.0.0) THEN RTSAV = SIGN(SQRT(WSAV),PS(MF)) ELSE RTSAV = 0.0 END IF DO 10 J=MF+1,ML WW = EEE*WS(J) - QS(J) IF (WW.GT.0.0) THEN IF (J.GT.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) ELSE RT = 0.0 IF (U.EQ.0.0 .AND. RTSAV.EQ.0.0 .AND. IA.LE.19) 1 IA = IA + 1 END IF IF (WW.EQ.0.0 .OR.WSAV.EQ.0.0 .OR. WW.EQ.SIGN(WW,WSAV)) THEN V = RT + RTSAV ELSE V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) END IF WSAV = WW RTSAV = RT PSUM = DS(J-1)*V IF (EEE.EQ.0.0) THEN PSS(J) = PSUM ELSE DPSUM = PSUM - PSS(J) DPSUMT = DPSUM*DELT(J-1)/DS(J-1) IF (DPSUMT.GT.0.001*TAU) THEN JJL = MIN(JJL,J) JJR = MAX(JJR,J) END IF END IF SUM = SUM + PSUM IF (U.GT.0.0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) 10 CONTINUE SUM = 0.5*SUM - SUM0 ZAV = 0.25*ZAV ELSE JJ = 1 JAY(1) = MF 20 CONTINUE SUM = 0.0 U = 0.0 UT = 0.0 ZAV = 0.0 ZAVJ = 0.0 MF1 = JAY(JJ) WSAV = EEE*WS(MF1) - QS(MF1) IF (WSAV.GT.0.0) THEN RTSAV = SIGN(SQRT(WSAV),PS(MF1)) ELSE RTSAV = 0.0 END IF DO 30 J=MF1+1,ML WW = EEE*WS(J) - QS(J) IF (WW.GT.0.0) THEN IF (J.GT.80) IB = J U = U + DS(J-1) UT = UT + DELT(J-1) RT = SIGN(SQRT(WW),PS(J)) ELSE RT = 0.0 IF (U.EQ.0.0 .AND. RTSAV.EQ.0.0 .AND. IA.LE.19) 1 IA = IA + 1 END IF IF (WW.EQ.0.0 .OR. WSAV.EQ.0.0 .OR. 1 WW.EQ.SIGN(WW,WSAV)) THEN V = RT + RTSAV ELSE V = (WW*RT+WSAV*RTSAV)/ABS(WW-WSAV) END IF WSAV = WW RTSAV = RT PSUM = DS(J-1)*V SUM = SUM + PSUM IF (U.GT.0.0) ZAV = ZAV + DELT(J-1)*V*ABS(PS(J)+PS(J-1)) IF (U.NE.0.0) THEN IF (ZAVJ.EQ.0.0) JSAV = J ZAVJ = 0.25*ZAV/UT IF (J.EQ.JSAV) ZAVSAV = ZAVJ IF (2.0*ZAVJ.LT.ZAVSAV .OR. ZAVJ.GT.2.0*ZAVSAV) THEN JJ = JJ + 1 JAY(JJ) = J ZEE(JJ) = 0.5*(ZAVJ+ZAVSAV) GO TO 40 END IF END IF 30 CONTINUE 40 CONTINUE IF (J.GT.ML) THEN JJ = JJ + 1 JAY(JJ) = ML ZEE(JJ) = 0.5*(ZAVJ+ZAVSAV) END IF IF (J.LT.ML) GO TO 20 SUM = 0.5*SUM ZAV = 0.25*ZAV END IF IB = IB + 1 RETURN END SUBROUTINE EXTRAP(T,TT,EIG,VALUE,DERIV,IFLAG) INTEGER IFLAG DOUBLE PRECISION T,TT,EIG,VALUE,DERIV C ********** C C This subroutine is called from ALFBET in determining boundary C values at a singular endpoint of the interval for a C Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C EXTRAP, which in turn calls INTPOL, extrapolates the function C C arctan(1.0/sqrt(-p*(eig*w-q))) C C from its values for T within (-1,1) to an endpoint. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt,intpol C C ********** C .. Scalars in Common .. DOUBLE PRECISION Z C .. C .. Local Scalars .. INTEGER KGOOD DOUBLE PRECISION ANS,CTN,ERROR,PROD,PX,QX,WX,T1,TEMP,X C .. C .. Local Arrays .. DOUBLE PRECISION FN1(5),XN(5) C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT,INTPOL C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,SQRT,TAN C .. C .. Common blocks .. COMMON /ZEE/Z C .. IFLAG = 1 KGOOD = 0 T1 = TT 10 CONTINUE CALL DXDT(T1,TEMP,X) PX = P(X)/Z QX = Q(X)/Z WX = W(X)/Z PROD = -PX*(EIG*WX-QX) IF (PROD.LE.0.0) THEN T1 = 0.5*(T1+T) IF ((1.0+(T1-T)**2).GT.1.0) GO TO 10 IF (PROD.GT.-1.0E-6) VALUE = 2.0*ATAN(1.0) IFLAG = 5 WRITE(21,*) ' In EXTRAP, iflag = 5' RETURN ELSE KGOOD = KGOOD + 1 XN(KGOOD) = T1 FN1(KGOOD) = ATAN(1.0/SQRT(PROD)) T1 = 0.5*(T+T1) IF (KGOOD.LT.5) GO TO 10 END IF T1 = 0.01 CALL INTPOL(5,XN,FN1,T,T1,3,ANS,ERROR) VALUE = ABS(ANS) CTN = 1.0/TAN(VALUE) DERIV = 0.5*PX*WX/CTN/(1.0+CTN**2) TT = XN(1) RETURN END SUBROUTINE F(U,Y,YP) DOUBLE PRECISION U DOUBLE PRECISION Y(2),YP(3) C ********** C C This subroutine evaluates the derivative functions for use with C integrator GERK in solving a Sturm-Liouville problem in the form C C -(p(x)*y'(x))' + q(x)*y(x) = eig*w(x)*y(x) on (a,b) C C for user-supplied coefficient functions P, Q, and W. C C Subprograms called C C user-supplied ..... p,q,w C C sleign2-supplied .. dxdt C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,Z C .. C .. Local Scalars .. DOUBLE PRECISION C,C2,DT,QX,WX,S,S2,T,TH,V,WW,X,XP C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. External Subroutines .. EXTERNAL DXDT C .. C .. Intrinsic Functions .. INTRINSIC COS,MOD,SIN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND COMMON /ZEE/Z C .. IF (MOD(IND,2).EQ.1) THEN T = U TH = Y(1) ELSE T = Y(1) TH = U END IF CALL DXDT(T,DT,X) XP = Z/P(X) QX = Q(X)/Z WX = W(X)/Z V = EIG*WX - QX S = SIN(TH) C = COS(TH) S2 = S*S C2 = C*C YP(1) = DT*(XP*C2+V*S2) IF (IND.EQ.1) THEN WW = (XP-V)*S*C YP(2) = DT*(-2.0*WW*Y(2)+WX*S2) YP(3) = DT*WW ELSE IF (IND.EQ.2) THEN YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0/YP(1) ELSE IF (IND.EQ.3) THEN ELSE YP(1) = 1.0/YP(1) END IF RETURN END DOUBLE PRECISION FUNCTION FF(ALFLAM) DOUBLE PRECISION ALFLAM C ********** C ********** C .. Scalars in Common .. INTEGER IND,INDD DOUBLE PRECISION CC,EIGSAV,HPI,PI,THETU,THETV,TWOPI, 1 UL,UR,VL,VR,UB,VB,Z C .. C .. Local Scalars .. INTEGER LFLAG LOGICAL AOK,BOK,LCIRCA,LCIRCB,OSCA,OSCB,SINGA,SINGB DOUBLE PRECISION AA,BB,DTHDAA,DTHDBB,DTHDEA,DTHDEB,DUM,EPS,LAMBDA, 1 PVPB,PVPL,PVPR,RHOB,RHOL,RHOR,THA,THB,THL,THR,TMID, 1 EPSMIN C .. C .. Local Arrays .. DOUBLE PRECISION ERR(3),Y(3) C .. C .. External Subroutines .. EXTERNAL INTEG C .. C .. Intrinsic Functions .. INTRINSIC COS,EXP,SIN C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /DATAF/EIGSAV,INDD COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /THET/THETU,THETV COMMON /RNDOFF/EPSMIN C .. C C (THIS ROUTINE IS BEING MODIFIED FOR PERIODIC PROBLEMS WHICH C ARE NOT NECESSARILY REGULAR, BUT IS NOT YET COMPLETE.) C AOK = .TRUE. LCIRCA = .FALSE. SINGA = .FALSE. OSCA = .FALSE. BOK = .TRUE. LCIRCB = .FALSE. SINGB = .FALSE. OSCB = .FALSE. C AA = -1.0 BB = 1.0 C C SET TMID SO THAT IT IS NOT IN THE EXACT MIDDLE. C TMID = 0.1*PI C INDD = 1 LAMBDA = ALFLAM EIGSAV = LAMBDA EPS = EPSMIN C IF (IND.GE.2) GO TO 10 C 50 CONTINUE C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOL = EXP(Y(3)) THL = Y(1) UL = RHOL*SIN(THL) C THB = HPI Y(1) = THB Y(2) = 1.0 Y(3) = 0.0 DTHDBB = 0.0 DTHDEB = 1.0 LFLAG = 1 CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCB,BOK,SINGB,OSCB,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOR = EXP(Y(3)) THR = Y(1) UR = RHOR*SIN(THR) C C FOR V: C THA = 0.0 Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOL = EXP(Y(3)) THL = Y(1) VL = RHOL*SIN(THL) PVPL = Z*RHOL*COS(THL) C THB = 0.0 Y(1) = THB Y(2) = 1.0 Y(3) = 0.0 DTHDBB = 0.0 DTHDEB = 1.0 LFLAG = 1 CALL INTEG(BB,THB,DTHDBB,DTHDEB,TMID,DUM,DUM,EPS,Y,ERR, 1 LCIRCB,BOK,SINGB,OSCB,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 50 END IF RHOR = EXP(Y(3)) THR = Y(1) VR = RHOR*SIN(THR) PVPR = Z*RHOR*COS(THR) FF = (VR*(UL*PVPL-1.0)-CC*VL*(UR*PVPR-1.0))*(VL-VR/CC) - 1 VL*VR*(UL-CC*UR)*(PVPL-PVPR/CC) RETURN C 10 CONTINUE C C FOR U: C THA = HPI Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 10 END IF RHOB = EXP(Y(3)) THB = Y(1) THETU = THB UB = RHOB*SIN(THB) C C FOR V: C THA = 0.0 Y(1) = THA Y(2) = 1.0 Y(3) = 0.0 DTHDAA = 0.0 DTHDEA = 1.0 LFLAG = 1 CALL INTEG(AA,THA,DTHDAA,DTHDEA,BB,DUM,DUM,EPS,Y,ERR, 1 LCIRCA,AOK,SINGA,OSCA,LFLAG) IF (LFLAG.EQ.5) THEN EPS = 10.0*EPS GO TO 10 END IF RHOB = EXP(Y(3)) THB = Y(1) THETV = THB VB = RHOB*SIN(THB) PVPB = Z*RHOB*COS(THB) FF = CC*PVPB + UB/CC - 2.0 RETURN END SUBROUTINE FIT(TH1,TH,TH2) DOUBLE PRECISION TH1,TH,TH2 C ********** C C This program converts TH into an 'equivalent' angle between C TH1 and TH2. We assume TH1.LT.TH2 and PI.LE.(TH2-TH1). C C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Intrinsic Functions .. INTRINSIC AINT C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. IF (TH.LT.TH1) TH = TH + AINT((TH1-TH+PI)/PI)*PI IF (TH.GT.TH2) TH = TH - AINT((TH-TH2+PI)/PI)*PI RETURN END SUBROUTINE FZ(UU,Y,YP) DOUBLE PRECISION UU DOUBLE PRECISION Y(2),YP(3) C ********** C C This subroutine evaluates the derivative of the function PHI C in the regularization at a singular endpoint. C C Here, HU means -(PUP)' + QU. C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG C .. C .. Local Scalars .. DOUBLE PRECISION AU,AV,A1122,A12,A21,B1122,B12,B21,C,C2,D,DT, 1 HU,HV,PHI,PUP,PVP,S,SC,S2,T,U,V,WW,WX,X C .. C .. External Functions .. DOUBLE PRECISION W EXTERNAL W C .. C .. External Subroutines .. EXTERNAL DXDT,UV C .. C .. Intrinsic Functions .. INTRINSIC COS,MOD,SIN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND C .. IF (MOD(IND,2).EQ.1) THEN T = UU PHI = Y(1) ELSE T = Y(1) PHI = UU END IF CALL DXDT(T,DT,X) CALL UV(X,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP WX = W(X) S = SIN(PHI) C = COS(PHI) S2 = S*S C2 = C*C SC = S*C B1122 = WX*U*V B12 = WX*V*V B21 = -WX*U*U AU = EIG*WX*U - HU AV = EIG*WX*V - HV A1122 = U*AV + V*AU A12 = V*AV A21 = -U*AU YP(1) = -DT*(A1122*SC+A12*S2-A21*C2)/D IF (IND.EQ.1) THEN WW = 2.0*(A12+A21)*SC + A1122*(C2-S2) YP(2) = -DT*(WW*Y(2)+2.0*B1122*SC+B12*S2-B21*C2)/D YP(3) = 0.5*DT*WW/D ELSE IF (IND.EQ.2) THEN YP(2) = YP(2)/YP(1) YP(3) = YP(3)/YP(1) YP(1) = 1.0/YP(1) ELSE IF (IND.EQ.3) THEN ELSE YP(1) = 1.0/YP(1) END IF RETURN END SUBROUTINE GERKZ(F,NEQ,Y,TIN,TOUT,REPS,AEPS,LFLAG,ER,WORK,IWORK) INTEGER NEQ,LFLAG INTEGER IWORK(5) DOUBLE PRECISION TIN,TOUT,REPS,AEPS DOUBLE PRECISION Y(3),ER(3),WORK(27) EXTERNAL F C ********** C ********** C .. Scalars in Common .. DOUBLE PRECISION EPSMIN,Z C .. C .. Local Scalars .. INTEGER I,J,K,L,LLFLAG DOUBLE PRECISION T,TOUTS C .. C .. Arrays in Common .. INTEGER JAY(100) DOUBLE PRECISION TEE(100),ZEE(100) C .. C .. Local Arrays .. DOUBLE PRECISION U(3) C .. C .. External Subroutines .. EXTERNAL GERK,THTOTHZ,THZTOTH C .. C .. Intrinsic Functions INTRINSIC MAX,MIN C .. C .. Common blocks .. COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z COMMON /TEEZ/TEE COMMON /ZEEZ/JAY,ZEE C .. T = TIN IF (TIN.LT.TOUT) THEN DO 10 I=1,19 IF (TEE(I)-EPSMIN.LE.TIN .AND. TIN.LT.TEE(I+1)+EPSMIN) J = I IF (TEE(I)-EPSMIN.LT.TOUT.AND.TOUT.LE.TEE(I+1)+EPSMIN) L = I 10 CONTINUE DO 30 K=J,L TOUTS = MIN(TOUT,TEE(K+1)) Z = ZEE(K+1) IF (Z.EQ.0.0) Z = 1.0 CALL THTOTHZ(Y,Z,U) LLFLAG = 1 20 CONTINUE CALL GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) IF (LLFLAG.GT.3) THEN WRITE(21,*) ' llflag = ',LLFLAG LFLAG = 5 RETURN END IF IF (LLFLAG.EQ.3 .OR. LLFLAG.EQ.-2) GO TO 20 CALL THZTOTH(U,Z,Y) 30 CONTINUE ELSE DO 40 I=20,2,-1 IF (TEE(I-1)-EPSMIN.LT.TIN .AND. TIN.LE.TEE(I)+EPSMIN) J = I IF (TEE(I-1)-EPSMIN.LE.TOUT.AND.TOUT.LT.TEE(I)+EPSMIN) L = I 40 CONTINUE DO 60 K=J,L,-1 TOUTS = MAX(TOUT,TEE(K-1)) Z = ZEE(K) IF (Z.EQ.0.0) Z = 1.0 CALL THTOTHZ(Y,Z,U) LLFLAG = 1 50 CONTINUE CALL GERK(F,NEQ,U,T,TOUTS,REPS,AEPS,LLFLAG,ER,WORK,IWORK) IF (LLFLAG.GT.3) THEN WRITE(21,*) ' llflag = ',LLFLAG LFLAG = 5 RETURN END IF IF (LLFLAG.EQ.3 .OR. LLFLAG.EQ.-2) GO TO 50 CALL THZTOTH(U,Z,Y) 60 CONTINUE END IF TIN = T LFLAG = LLFLAG RETURN END SUBROUTINE INTEG(TEND,THEND,DTHDAA,DTHDE,TMID,COEF1,COEF2, 1 EPS,Y,ER,LCIRC,OK,SING,OSC,IFLAG) INTEGER IFLAG LOGICAL LCIRC,OK,SING,OSC DOUBLE PRECISION TEND,THEND,DTHDAA,DTHDE,TMID,COEF1,COEF2,EPS DOUBLE PRECISION Y(3),ER(3) CHARACTER*16 PREC C ********** C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,HPI,PI,TSAVEL,TSAVER,TWOPI,Z C .. C .. Arrays in Common .. INTEGER NT(2) DOUBLE PRECISION TT(7,2),YY(7,3,2) C .. C .. Local Scalars .. INTEGER I,J,KFLAG,K2PI,LFLAG,M LOGICAL LOGIC DOUBLE PRECISION D,DDD,EFF,HU,HV,PHI,PHI0,PUP,PVP,T,TMP,U,V,XT0, 1 ZSAV,C,DTHIN,DUM,DPHIDE,DPHIDAA,FAC2,P1,PYPZ,PYPZ0, 2 Q1,RHOSQ,S,TSTAR,TINTHZ,TH0,TH,THBAR,THETA, 3 THIN,THU,THV,THU0,THV0,TIN,TOUT,W1,XSTAR,XT,YSTAR,YZ,YZ0 C .. C .. Local Arrays .. INTEGER IWORK(5) DOUBLE PRECISION ERZ(3),WORK(27),YP(3),YU(3) C .. C .. External Subroutines .. EXTERNAL DXDT,F,FZ,INTEGT,GERK,GERKZ,SETTHU,UV,UVPHI,WR C .. C .. External Functions .. DOUBLE PRECISION P,Q,W EXTERNAL P,Q,W C .. C .. Intrinsic Functions .. INTRINSIC ATAN2,EXP,LOG,MIN,SIGN C .. C .. Common blocks .. COMMON /DATAF/EIG,IND COMMON /ZEE/Z COMMON /PIE/PI,TWOPI,HPI COMMON /TEMP/TT,YY,NT COMMON /TSAVE/TSAVEL,TSAVER C .. C C Note: The input values of THEND and DTHDAA are overwritten C when integrating from a limit circle endpoint. C PREC = 'DOUBLE PRECISION' IFLAG = 1 IND = 1 IF (OSC) THEN IF (.NOT.OK) THEN LOGIC = .FALSE. ELSE IF (TEND.LE.TMID) THEN LOGIC = TEND.GE.TSAVEL ELSE LOGIC = TEND.LE.TSAVER END IF C IF (LOGIC) THEN TINTHZ = TEND TH = THEND DTHIN = DTHDE Y(1) = TH Y(2) = DTHIN EFF = Y(3) ELSE C DO (INTEGRATE-FOR-PHI-OSC) ZSAV = Z Z = 1.0 T = TEND PHI0 = ATAN2(COEF2,COEF1) IF (TMID.GT.TEND) THEN J = 1 ELSE J = 2 END IF C C We want -PI/2 .lt. PHI0 .le. PI/2. C IF (COEF1.LT.0.0) PHI0 = PHI0 - SIGN(PI,COEF2) Y(1) = PHI0 Y(2) = 0.0 Y(3) = 0.0 CALL DXDT(T,TMP,XT0) CALL FZ(T,Y,YP) DPHIDAA = -YP(1) CALL UV(XT0,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU0 and THV0. C THU0 = ATAN2(U,PUP) IF (U.LT.0.0) THU0 = THU0 + TWOPI CALL SETTHU(XT0,THU0) THV0 = ATAN2(V,PVP) IF (V.LT.0.0) THV0 = THV0 + TWOPI 10 CONTINUE IF (THV0.LT.THU0) THEN THV0 = THV0 + TWOPI GO TO 10 END IF C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C CALL UVPHI(U,PUP,V,PVP,THU0,THV0,PHI0,TH0) THEND = TH0 C = COS(PHI0) S = SIN(PHI0) YZ0 = U*C + V*S PYPZ0 = PUP*C + PVP*S DUM = ABS(COS(TH0)) IF (DUM.GE.0.5) THEN FAC2 = -D*(DUM/PYPZ0)**2 ELSE FAC2 = -D*(SIN(TH0)/YZ0)**2 END IF DTHDAA = DPHIDAA*FAC2 TOUT = TMID I = 2 TT(I,J) = T YY(I,1,J) = Y(1) YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) KFLAG = -1 C C TSAVEL, TSAVER presumed set by an earlier call with EIG .ne. 0. C IF (EIG.EQ.0.0) THEN IF (T.LE.TSAVEL) TOUT = TSAVEL IF (T.GT.TSAVER) TOUT = TSAVER KFLAG = 1 END IF 20 CONTINUE CALL GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG1 = 5 ' IFLAG = 5 RETURN END IF IF (KFLAG.EQ.3) GO TO 20 IF (Y(3).LT.-15.0) Y(3) = -15.0 PHI = Y(1) C C Store up to seven values of (T,PHI) for later reference. C I = I + 1 IF (I.LE.7) THEN TT(I,J) = T YY(I,1,J) = PHI YY(I,2,J) = Y(2) YY(I,3,J) = Y(3) END IF IF (10.0*ABS(PHI-PHI0).GE.PI) GO TO 30 IF (KFLAG.EQ.-2) GO TO 20 30 CONTINUE IF (T.LE.TOUT) THEN TSAVEL = T ELSE TSAVER = T END IF NT(J) = I DPHIDE = Y(2) TINTHZ = T CALL DXDT(T,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP C C Set THU and THV. C THU = ATAN2(U,PUP) IF (U.LT.0.0) THU = THU + TWOPI CALL SETTHU(XT,THU) THV = ATAN2(V,PVP) IF (V.LT.0.0) THV = THV + TWOPI 40 CONTINUE IF (THV.LT.THU) THEN THV = THV + TWOPI GO TO 40 END IF C C Now define TH in terms of PHI, THU, and THV. C CALL UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) YZ = U*COS(PHI) + V*SIN(PHI) PYPZ = PUP*COS(PHI) + PVP*SIN(PHI) Y(1) = TH S = SIN(TH) C = COS(TH) DUM = ABS(C) IF (DUM.GE.0.5) THEN FAC2 = -D*(DUM/PYPZ)**2 ELSE FAC2 = -D*(S/YZ)**2 END IF DTHIN = FAC2*DPHIDE Y(2) = DTHIN Z = ZSAV RHOSQ = EXP(2.0*Y(3))*(YZ**2+PYPZ**2) EFF = 0.5*LOG(RHOSQ*(S**2+(C/Z)**2)) Y(3) = EFF C END (INTEGRATE-FOR-PHI-OSC) END IF IF (TINTHZ.NE.TMID) THEN TIN = TINTHZ TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETAZ) C C The following block of code replaces what was used for C non-limit-circle problems, with a few changes. C T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0 50 CONTINUE CALL GERKZ(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ERZ,WORK,IWORK) IF (LFLAG.GT.3) THEN WRITE(21,*) ' LFLAGZ = ',LFLAG IFLAG = 5 RETURN END IF IF (LFLAG.EQ.3 .OR. LFLAG.EQ.-2) GO TO 50 C END (INTEGRATE-FOR-THETAZ) Y(3) = Y(3) + EFF Z = 1.0 END IF ELSE IF (LCIRC) THEN C DO (INTEGRATE-FOR-PHI-NONOSC) T = TEND IF (COEF1.LT.0.0) THEN COEF1 = -COEF1 COEF2 = -COEF2 END IF PHI0 = ATAN2(COEF2,COEF1) C C We want -PI/2 .lt. PHI0 .le. PI/2. C Y(1) = PHI0 Y(2) = 0.0 Y(3) = 0.0 CALL DXDT(T,TMP,XT) CALL FZ(T,Y,YP) DPHIDAA = -YP(1) CALL UV(XT,U,PUP,V,PVP,HU,HV) D = U*PVP - V*PUP YZ0 = U*COEF1 + V*COEF2 PYPZ0 = (PUP*COEF1+PVP*COEF2)/Z C C Set TH0 and copy into THEND, overwriting its input value. C Also, redefine DTHDAA, overwriting its input value. C TH0 = ATAN2(YZ0,PYPZ0) IF (YZ0.LT.0.0) TH0 = TH0 + TWOPI THEND = TH0 DUM = ABS(COS(TH0)) IF (DUM.GE.0.5) THEN FAC2 = (-D/Z)*(DUM/PYPZ0)**2 ELSE FAC2 = (-D/Z)*(SIN(TH0)/YZ0)**2 END IF DTHDAA = FAC2*DPHIDAA C C In the next piece, we assume TH0 .ge. 0. C M = 0 IF (TH0.EQ.0.0) M = -1 IF (TH0.GT.PI .OR. (TH0.EQ.PI. AND. T.LT.TMID)) M = 1 PHI = PHI0 K2PI = 0 YZ0 = U*COS(PHI0) + V*SIN(PHI0) IF (TMID.GT.TEND) THEN J = 1 TSTAR = -0.99999 IF (PREC(1:1).NE.'R') TSTAR = -0.9999999999D0 ELSE J = 2 TSTAR = 0.99999 IF (PREC(1:1).NE.'R') TSTAR = 0.9999999999D0 END IF DPHIDE = 0.0 CALL WR(FZ,EPS,TSTAR,PHI0,PHI0,DPHIDE,TOUT,Y, 1 TT(1,J),YY(1,1,J),ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01,ABS(TMID-TOUT)) TOUT = TOUT + DDD*(TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 CALL GERK(FZ,3,Y,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = Y(1) YY(7,2,J) = Y(2) YY(7,3,J) = Y(3) 60 CONTINUE T = TOUT CALL DXDT(T,TMP,XT) CALL UV(XT,U,PUP,V,PVP,HU,HV) PHI = Y(1) S = SIN(PHI) C = COS(PHI) YZ = U*C + V*S IF (YZ*YZ0 .LT. 0.0) K2PI = K2PI + 1 YZ0 = YZ IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG2 = ',KFLAG IFLAG = 5 RETURN END IF IF (KFLAG.EQ.3 .OR. KFLAG.EQ.-2) GO TO 60 C C Convert from PHI to THETA. C DPHIDE = Y(2) D = U*PVP-V*PUP PYPZ = (PUP*C+PVP*S)/Z THBAR = ATAN2(YZ,PYPZ) IF (TMID.GT.TEND .AND. THBAR.LT.TH0 .AND. PHI.LT.PHI0) 1 THBAR = THBAR + TWOPI IF (TMID.LT.TEND .AND. THBAR.GT.TH0 .AND. PHI.GT.PHI0) 1 THBAR = THBAR - TWOPI TH = THBAR - M*PI IF (TH.LT.-PI) TH = TH + TWOPI IF (TH.GT.TWOPI) TH = TH - TWOPI IF (TMID.LT.TEND .AND. K2PI.GT.1) TH = TH - (K2PI-1)*TWOPI IF (TMID.GT.TEND .AND. K2PI.GT.1) TH = TH + (K2PI-1)*TWOPI IF (TMID.GT.TEND .AND. TH*TH0.LT.0.0) TH = TH + TWOPI C C We now have YZ, PYPZ, PHI and TH. C DUM = ABS(COS(TH)) IF (DUM.GE.0.5) THEN FAC2 = -(D/Z)*(DUM/PYPZ)**2 ELSE FAC2 = -(D/Z)*(SIN(TH)/YZ)**2 END IF DTHIN = FAC2*DPHIDE THETA = ATAN2(YZ,Z*PYPZ) S = SIN(THETA) C = COS(THETA) RHOSQ = EXP(2.0*Y(3))*(YZ**2+(Z*PYPZ)**2) EFF = 0.5*LOG(RHOSQ*(S**2+(C/Z)**2)) C END (INTEGRATE-FOR-PHI-NONOSC) TIN = TOUT TOUT = TMID THIN = TH C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) Y(3) = Y(3) + EFF ELSE IF (.NOT.OK .AND. .NOT.SING) THEN C C This is the 'weakly regular' case. C IF (TMID.GT.TEND) THEN J = 1 TSTAR = -0.99999 IF (PREC(1:1).NE.'R') TSTAR = -0.9999999999D0 ELSE J = 2 TSTAR = 0.99999 IF (PREC(1:1).NE.'R') TSTAR = 0.9999999999D0 END IF CALL DXDT(TSTAR,TMP,XSTAR) P1 = 1.0/P(XSTAR) Q1 = Q(XSTAR) W1 = W(XSTAR) YSTAR = THEND + 0.5*(TSTAR-TEND)* 1 (P1*COS(THEND)**2+(EIG*W1-Q1)*SIN(THEND)**2) CALL WR(F,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,YU, 1 TT(1,J),YY(1,1,J),ERZ,WORK,IWORK) T = TOUT DDD = MIN(0.01,ABS(TMID-TOUT)) TOUT = TOUT + DDD*(TMID-TOUT)/ABS(TMID-TOUT) KFLAG = 1 CALL GERK(F,3,YU,T,TOUT,EPS,EPS,KFLAG,ER,WORK,IWORK) TT(7,J) = T YY(7,1,J) = YU(1) YY(7,2,J) = YU(2) YY(7,3,J) = YU(3) TIN = TOUT TOUT = TMID THIN = YU(1) DTHIN = YU(2) C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) ELSE C C This is the regular (not weakly regular) or limit point case. C TIN = TEND TOUT = TMID THIN = THEND DTHIN = DTHDE C DO (INTEGRATE-FOR-THETA) CALL INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) C END (INTEGRATE-FOR-THETA) END IF RETURN END SUBROUTINE INTEGT(TIN,TOUT,THIN,DTHIN,EPS,Y,IFLAG,ER,WORK,IWORK) INTEGER IFLAG,IWORK(5) DOUBLE PRECISION TIN,TOUT,THIN,DTHIN,EPS DOUBLE PRECISION Y(3),ER(3),WORK(27) C ********** C C Integrate for theta. C C ********** C .. Local Scalars .. INTEGER LFLAG DOUBLE PRECISION T C .. C .. External Subroutines .. EXTERNAL F C .. C DO (INTEGRATE-FOR-TH) T = TIN Y(1) = THIN Y(2) = DTHIN Y(3) = 0.0 LFLAG = 1 10 CONTINUE CALL GERK(F,3,Y,T,TOUT,EPS,EPS,LFLAG,ER,WORK,IWORK) IF (LFLAG.EQ.3) GO TO 10 IF (LFLAG.GT.3) THEN WRITE(21,*) ' LFLAG = ',LFLAG IFLAG = 5 RETURN END IF THIN = Y(1) DTHIN = Y(2) C END (INTEGRATE-FOR-TH) RETURN END SUBROUTINE INTPOL(N,XN,FN,X,ABSERR,MAXDEG,ANS,ERROR) INTEGER N,MAXDEG DOUBLE PRECISION X,ABSERR,ANS,ERROR DOUBLE PRECISION XN(N),FN(N) C ********** C C This subroutine forms an interpolating polynomial for data pairs. C It is called from EXTRAP in solving a Sturm-Liouville problem. C C ********** C .. Local Scalars .. INTEGER I,I1,II,IJ,IK,IKM1,J,K,L,LIMIT DOUBLE PRECISION PROD C .. C .. Local Arrays .. INTEGER INDEX(10) DOUBLE PRECISION V(10,10) C .. C .. Intrinsic Functions .. INTRINSIC ABS,MIN C .. L = MIN(MAXDEG,N-2) + 2 LIMIT = MIN(L,N-1) DO 10 I = 1,N V(I,1) = ABS(XN(I)-X) INDEX(I) = I 10 CONTINUE DO 30 I=1,LIMIT DO 20 J=I+1,N II = INDEX(I) IJ = INDEX(J) IF (V(II,1).GT.V(IJ,1)) THEN INDEX(I) = IJ INDEX(J) = II END IF 20 CONTINUE 30 CONTINUE PROD = 1.0 I1 = INDEX(1) ANS = FN(I1) V(1,1) = FN(I1) DO 50 K=2,L IK = INDEX(K) V(K,1) = FN(IK) DO 40 I=1,K-1 II = INDEX(I) V(K,I+1) = (V(I,I)-V(K,I))/(XN(II)-XN(IK)) 40 CONTINUE IKM1 = INDEX(K-1) PROD = (X-XN(IKM1))*PROD ERROR = PROD*V(K,K) IF(ABS(ERROR).LE.ABSERR) RETURN ANS = ANS + ERROR 50 CONTINUE ANS = ANS - ERROR RETURN END SUBROUTINE LPOL(KEIGS,XN,FN,X,F) INTEGER KEIGS DOUBLE PRECISION X,F DOUBLE PRECISION XN(KEIGS),FN(KEIGS) C ********** C ********** C .. C .. Local variables .. DOUBLE PRECISION X12,X13,X14,X15,X21,X23,X24,X25,X31,X32,X34,X35, 1 X41,X42,X43,X45,X51,X52,X53,X54,XX1,XX2,XX3,XX4,XX5 C .. X12 = XN(1) - XN(2) X13 = XN(1) - XN(3) X23 = XN(2) - XN(3) X21 = -X12 X31 = -X13 X32 = -X23 XX1 = X - XN(1) XX2 = X - XN(2) XX3 = X - XN(3) IF (KEIGS.GE.4) THEN X14 = XN(1) - XN(4) X24 = XN(2) - XN(4) X34 = XN(3) - XN(4) X41 = -X14 X42 = -X24 X43 = -X34 XX4 = X - XN(4) END IF IF (KEIGS.EQ.5) THEN X15 = XN(1) - XN(5) X25 = XN(2) - XN(5) X35 = XN(3) - XN(5) X45 = XN(4) - XN(5) X51 = -X15 X52 = -X25 X53 = -X35 X54 = -X45 XX5 = X - XN(5) END IF IF (KEIGS.EQ.3) THEN F = XX2*XX3*FN(1)/(X12*X13) + 1 XX1*XX3*FN(2)/(X21*X23) + 2 XX1*XX2*FN(3)/(X31*X32) ELSE IF (KEIGS.EQ.4) THEN F = XX2*XX3*XX4*FN(1)/(X12*X13*X14) + 1 XX1*XX3*XX4*FN(2)/(X21*X23*X24) + 2 XX1*XX2*XX4*FN(3)/(X31*X32*X34) + 3 XX1*XX2*XX3*FN(4)/(X41*X42*X43) ELSE F = XX2*XX3*XX4*XX5*FN(1)/(X12*X13*X14*X15) + 1 XX1*XX3*XX4*XX5*FN(2)/(X21*X23*X24*X25) + 2 XX1*XX2*XX4*XX5*FN(3)/(X31*X32*X34*X35) + 3 XX1*XX2*XX3*XX5*FN(4)/(X41*X42*X43*X45) + 4 XX1*XX2*XX3*XX4*FN(5)/(X51*X52*X53*X54) END IF RETURN END C SUBROUTINE PERIO(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB, 1 A1,A2,B1,B2,NUMEIG,EIG,TOL,IFLAG,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) INTEGER INTAB,NUMEIG,IFLAG DOUBLE PRECISION A,B,P0ATA,QFATA,P0ATB,QFATB,A1,A2,B1,B2,EIG,TOL, 1 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB DOUBLE PRECISION SLFN(9) C ********** C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EPSMIN,CC,UB,UL,UR,VB,VL,VR,Z C .. C .. Local Scalars .. INTEGER JFLAG DOUBLE PRECISION A1D,A1N,A2D,A2N,B1N,B1D,B2N,B2D DOUBLE PRECISION AE,EIGLO,EIGUP,LAMBDA,LAMUP,RE,TOLL,TOLS C .. C .. External Subroutines .. EXTERNAL FZERO,SLEIGN2 C .. C .. External Functions .. EXTERNAL FF C .. C .. Intrinsic Functions .. C .. C .. Common blocks .. COMMON /EPP2/CC,UL,UR,VL,VR,UB,VB,IND COMMON /RNDOFF/EPSMIN COMMON /ZEE/Z C .. C C Get upper and lower bounds as accurately as possible. C TOLL = 0.0 TOLS = TOL C A1N = 0.0 A2N = 1.0 B1N = 0.0 B2N = 1.0 TOL = TOLL EIG = 0.0 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1N,A2N, 1 B1N,B2N,NUMEIG,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) WRITE(*,*) ' eiglo,iflag = ',EIG,IFLAG EIGLO = EIG - 0.1 C A1D = 1.0 A2D = 0.0 B1D = 1.0 B2D = 0.0 TOL = TOLL EIG = 0.0 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1D,A2D, 1 B1D,B2D,NUMEIG,EIG,TOL,IFLAG,0,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) WRITE(*,*) ' eigup,iflag = ',EIG,IFLAG EIGUP = EIG + 0.1 LAMBDA = 0.5*(EIGLO+EIGUP) C C The following call to SLEIGN2 sets the stage for INTEG. C TOL = .001 CALL SLEIGN2(A,B,INTAB,P0ATA,QFATA,P0ATB,QFATB,A1,A2, 1 B1,B2,NUMEIG,LAMBDA,TOL,IFLAG,-1,SLFN, 2 SINGATA,SINGATB,CIRCLA,CIRCLB,OSCILA,OSCILB) Z = 1.0 C EIG = EIGLO LAMUP = EIGUP RE = TOLS AE = RE C C IND = 2 selects the classical function d(LAMBDA) in function FF. C IND = 2 CALL FZERO(FF,EIG,LAMUP,LAMBDA,RE,AE,JFLAG) IF (JFLAG.NE.1) WRITE(*,*) ' jflag = ',JFLAG IFLAG = JFLAG TOL = ABS(EIG-LAMUP)/MAX(1.0,ABS(EIG)) WRITE(*,*) ' EIGLO,EIGUP = ',EIGLO,EIGUP C RETURN END SUBROUTINE SETMID(MF,ML,EIG,QS,WS,IMID,TMID) INTEGER MF,ML,IMID DOUBLE PRECISION EIG,QS(*),WS(*),TMID C ********** C C This procedures tests the interval sample points in the order C 50,51,49,52,48,...,etc. for the first one where the expression C (lambda*w-q) is positive. This point is designated TMID. C C ********** C .. Local Scalars .. INTEGER I,J DOUBLE PRECISION S C .. C .. External Functions .. DOUBLE PRECISION TFROMI EXTERNAL TFROMI C .. S = -1.0 DO 10 J=1,100 I = 50 + S*(J/2) S = -S IF (I.LT.MF .OR. I.GT.ML) GO TO 20 IF (EIG*WS(I)-QS(I).GT.0.0) THEN IMID = I TMID = TFROMI(IMID) GO TO 20 END IF 10 CONTINUE 20 CONTINUE WRITE(*,*) ' new tmid = ',TMID RETURN END SUBROUTINE SETTHU(X,THU) DOUBLE PRECISION X,THU C ********** c c This subroutine establishes a definite value for THU, c the phase angle for the function U, including an c appropriate integer multiple of pi c It needs the numbers MMW(*) found in THUM c C ********** C .. Scalars in Common .. INTEGER MMWD DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Arrays in Common .. INTEGER MMW(98) DOUBLE PRECISION YS(197) C .. C .. Local Scalars .. INTEGER I C .. C .. Common blocks .. COMMON /PASS/YS,MMW,MMWD COMMON /PIE/PI,TWOPI,HPI C .. DO 10 I=1,MMWD IF (X.GE.YS(MMW(I)) .AND. X.LE.YS(MMW(I)+1)) THEN IF (THU.GT.PI) THEN THU = THU + (I-1)*TWOPI RETURN ELSE THU = THU + I*TWOPI RETURN END IF END IF 10 CONTINUE DO 20 I=1,MMWD IF (X.GE.YS(MMW(I))) THU = THU + TWOPI 20 CONTINUE RETURN END DOUBLE PRECISION FUNCTION TFROMI(I) INTEGER I C ********** C C This function associates the value of an interval sample point C with its index. C C ********** IF (I.LT.8) THEN TFROMI = -1.0 + 0.1/4.0**(8-I) ELSE IF (I.GT.92) THEN TFROMI = 1.0 - 0.1/4.0**(I-92) ELSE TFROMI = 0.0227*(I-50) END IF RETURN END SUBROUTINE THTOTHZ(Y,Z,U) DOUBLE PRECISION Z DOUBLE PRECISION Y(3),U(3) C ********** C THIS PROGRAM CONVERTS FROM TH TO THZ WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER K DOUBLE PRECISION DTH,DTHZ,DUM,FAC,PIK,REMTH,TH,THZ C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TH = Y(1) DTH = Y(2) K = TH/PI IF (TH.LT.0.0) K = K - 1 PIK = K*PI REMTH = TH - PIK IF (4.0*REMTH.LE.PI) THEN THZ = ATAN(Z*TAN(REMTH)) + PIK ELSE IF (4.0*REMTH.GE.3.0*PI) THEN THZ = ATAN(Z*TAN(REMTH)) + PIK + PI ELSE THZ = ATAN(TAN(REMTH-HPI)/Z) + PIK + HPI END IF DUM = ABS(COS(THZ)) IF (DUM.GE.0.5) THEN FAC = Z*(DUM/COS(TH))**2 ELSE FAC = (SIN(THZ)/SIN(TH))**2/Z END IF DTHZ = FAC*DTH U(1) = THZ U(2) = DTHZ U(3) = Y(3) - 0.5*LOG(Z*FAC) RETURN END SUBROUTINE THUM(MF,ML,XS) INTEGER MF,ML DOUBLE PRECISION XS(*) C ********** C C YS IS LIKE XS, BUT HAS TWICE AS MANY POINTS. C MMW(N) IS THE VALUE OF THE INDEX I OF U(I), MF .LE. I .LE. 2*ML-2, C WHERE U FOR THE Nth TIME CHANGES SIGN FROM - TO + C AND WHERE P*U' IS POSITIVE. C MMWD IS THE NUMBER OF SUCH POINTS OF U. C C ********** C .. Scalars in Common .. INTEGER MMWD C .. C .. Arrays in Common .. INTEGER MMW(98) DOUBLE PRECISION YS(197) C .. C .. Local Scalars .. INTEGER I,N DOUBLE PRECISION PUP,PUP1,U,U1,tmp C .. C .. Common blocks .. COMMON /PASS/YS,MMW,MMWD C .. DO 10 I=1,98 YS(2*I-1) = XS(I) YS(2*I) = 0.5*(XS(I)+XS(I+1)) 10 CONTINUE YS(197) = XS(99) N = 0 U1 = 0.0 PUP1 = 0.0 DO 20 I=2*MF-1,2*ML-1 CALL UV(YS(I),U,PUP,tmp,tmp,tmp,tmp) IF (U1.LT.0.0 .AND. U.GT.0.0 .AND. PUP1.GT.0.0) THEN N = N + 1 MMW(N) = I - 1 END IF U1 = U PUP1 = PUP 20 CONTINUE MMWD = N RETURN END SUBROUTINE THZTOTH(U,Z,Y) DOUBLE PRECISION Z DOUBLE PRECISION U(3),Y(3) C ********** C THIS PROGRAM CONVERTS FROM THZ TO TH WHERE C TAN(TH)=PSI/(P*PSI') C AND C TAN(THZ)=Z*PSI/(P*PSI'), C OR C TAN(THZ)=Z*TAN(TH) . C SO WE HAVE C DTHZ=Z*(COS(THZ)/COS(TH))**2 * DTH , C OR C DTH=(1/Z)*(COS(TH)/COS(THZ))**2 * DTHZ . C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. INTEGER K DOUBLE PRECISION DTH,DTHZ,DUM,FAC,PIK,REMTHZ,TH,THZ C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN,COS,LOG,SIN,TAN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. THZ = U(1) DTHZ = U(2) K = THZ/PI IF (THZ.LT.0.0) K = K - 1 PIK = K*PI REMTHZ = THZ - PIK IF (4.0*REMTHZ.LE.PI) THEN TH = ATAN(TAN(REMTHZ)/Z) + PIK ELSE IF (4.0*REMTHZ.GE.3.0*PI) THEN TH = ATAN(TAN(REMTHZ)/Z) + PIK + PI ELSE TH = ATAN(Z*TAN(REMTHZ-HPI)) + PIK + HPI END IF DUM = ABS(COS(TH)) IF (DUM.GE.0.5) THEN FAC = (DUM/COS(THZ))**2/Z ELSE FAC = Z*(SIN(TH)/SIN(THZ))**2 END IF DTH = FAC*DTHZ Y(1) = TH Y(2) = DTH Y(3) = U(3) + 0.5*LOG(Z/FAC) RETURN END SUBROUTINE UVPHI(U,PUP,V,PVP,THU,THV,PHI,TH) DOUBLE PRECISION U,PUP,V,PVP,THU,THV,PHI,TH C ********** C C This program finds TH appropriate to THU, THV, and PHI, where C THU is the phase angle for U, and THV is the phase angle for V. C C ********** C .. Scalars in Common .. DOUBLE PRECISION PI,TWOPI,HPI C .. C .. Local Scalars .. DOUBLE PRECISION C,D,PYP,S,Y C .. C .. External Subroutines .. EXTERNAL FIT C .. C .. Intrinsic Functions .. INTRINSIC ATAN2,COS,SIN C .. C .. Common blocks .. COMMON /PIE/PI,TWOPI,HPI C .. TH = THU IF (PHI.EQ.0.0) RETURN IF (THV-THU.LT.PI) THEN TH = THV IF (PHI.EQ.-HPI) RETURN TH = THV - PI IF (PHI.EQ.HPI) RETURN ELSE TH = THV - PI IF (PHI.EQ.-HPI) RETURN TH = THV - TWOPI IF (PHI.EQ.HPI) RETURN END IF C = COS(PHI) S = SIN(PHI) Y = U*C + V*S PYP = PUP*C + PVP*S TH = ATAN2(Y,PYP) IF (Y.LT.0.0) TH = TH + TWOPI D = U*PVP - V*PUP IF (D*PHI.GT.0.0) THEN CALL FIT(THU-PI,TH,THU) ELSE CALL FIT(THU,TH,THU+PI) END IF RETURN END SUBROUTINE WR(FG,EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT,Y, 1 TT,YY,ERR,WORK,IWORK) INTEGER IWORK(5) DOUBLE PRECISION EPS,TSTAR,YSTAR,THEND,DTHDE,TOUT DOUBLE PRECISION Y(3),TT(7),YY(7,3),ERR(3),WORK(27) EXTERNAL FG C ********** C C This subroutine integrates Y' = F(T,Y) from t = +/-1.0 to THEND C even when F cannot be evaluated at t. (T*,Y*) is chosen as a C nearby point, and the equation is integrated from there and C checked for consistency with having integrated from t. If not, C a different (T*,Y*) is chosen until consistency is achieved. C C ********** C .. Scalars in Common .. INTEGER IND DOUBLE PRECISION EIG,EPSMIN C .. C .. Local Scalars .. INTEGER I,K,KFLAG DOUBLE PRECISION CHNG,D2F,D2G,D3F,D3G,D4F,D4G,HT,HU,OLDSS2,OLDYY2, 1 ONE,SLO,SOUT,SUMM,SUP,T,TEN5,TIN,U,UOUT,USTAR,YLO,YOUT,YUP C .. C .. Local Arrays .. DOUBLE PRECISION DF(4),DG(4),FF(6),GG(5),S(3),SS(6,3),UU(6) C .. C .. External Subroutines .. EXTERNAL GERK,LPOL C .. C .. Intrinsic Functions .. INTRINSIC ABS,SIGN C .. C .. Common blocks COMMON /DATAF/EIG,IND COMMON /RNDOFF/EPSMIN C .. ONE = 1.0 TEN5 = 100000.0 C C Integrate Y' = F(T,Y,YP). C TIN = SIGN(ONE,TSTAR) HT = TSTAR - TIN TT(1) = TIN YY(1,1) = THEND YY(1,2) = DTHDE YY(1,3) = 0.0 TT(2) = TSTAR YY(2,1) = YSTAR YY(2,2) = DTHDE YY(2,3) = 0.0 YLO = -TEN5 YUP = TEN5 C C Normally IND = 1 or 3; IND is set to 2 or 4 when Y is to be used C as the independent variable in FG(T,Y,YP), instead of the usual T. C Before leaving this subroutine, IND is reset to 1. C 10 CONTINUE T = TSTAR Y(1) = YY(2,1) Y(2) = YY(2,2) Y(3) = YY(2,3) KFLAG = 1 IND = 1 DO 30 K = 3,6 TOUT = T + HT 20 CONTINUE CALL GERK(FG,3,Y,T,TOUT,EPS,EPS,KFLAG,ERR,WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG3 = 5 ' END IF IF (KFLAG.EQ.3) GO TO 20 YOUT = Y(1) TT(K) = T YY(K,1) = YOUT YY(K,2) = Y(2) YY(K,3) = Y(3) 30 CONTINUE IND = 3 DO 40 I = 2,6 CALL FG(TT(I),YY(I,1),FF(I)) 40 CONTINUE CALL LPOL(5,TT(2),FF(2),TT(1),FF(1)) IF (ABS(FF(1)).LE.500.0) THEN C C Now we want to apply some criterion to see if these results are C consistent with having integrated from (TT(1),YY(1,1). C DO 50 I = 1,4 DF(I) = FF(I+1) - FF(I) 50 CONTINUE D2F = DF(4) - DF(3) D3F = DF(4) - 2.0*DF(3) + DF(2) D4F = DF(4) - 3.0*DF(3) + 3.0*DF(2) - DF(1) SUMM = HT*(FF(5)-3.5*DF(4)+53.0*D2F/12.0 1 -55.0*D3F/24.0+251.0*D4F/720.0) C C Presumably, YY(2,1) should be YY(1,1) + SUMM. C OLDYY2 = YY(2,1) YY(2,1) = YY(1,1) + SUMM C C Also improve the value of Y(2) at TSTAR. C YY(2,2) = 0.5*(YY(1,2)+YY(3,2)) YY(2,3) = 0.5*(YY(1,3)+YY(3,3)) CHNG = YY(2,1) - OLDYY2 IF (CHNG.GE.0.0 .AND. OLDYY2.GT.YLO) YLO = OLDYY2 IF (CHNG.LE.0.0 .AND. OLDYY2.LT.YUP) YUP = OLDYY2 IF ((YY(2,1).GE.YUP .AND. YLO.GT.-TEN5) .OR. 1 (YY(2,1).LE.YLO .AND. YUP.LT.TEN5)) 2 YY(2,1) = 0.5*(YLO+YUP) IF (ABS(YY(2,1)-OLDYY2).GT.EPSMIN) GO TO 10 ELSE C C Here, Y' is assumed infinite at T = TIN. In this case, C it cannot be expected to approximate Y with a polynomial, C so the independent and dependent variables are interchanged. C The points are assumed equally spaced. C HU = (YY(6,1)-YY(1,1))/5.0 UU(1) = YY(1,1) SS(1,1) = TT(1) SS(1,2) = DTHDE SS(1,3) = 0.0 UU(2) = UU(1) + HU SS(2,1) = TSTAR SS(2,2) = DTHDE SS(2,3) = 0.0 USTAR = UU(2) SLO = -TEN5 SUP = TEN5 60 CONTINUE U = USTAR S(1) = SS(2,1) S(2) = SS(2,2) S(3) = SS(2,3) KFLAG = 1 IND = 2 DO 80 K = 3,6 UOUT = U + HU 70 CONTINUE CALL GERK(FG,3,S,U,UOUT,EPS,EPS,KFLAG,ERR, 1 WORK,IWORK) IF (KFLAG.GT.3) THEN WRITE(*,*) ' KFLAG4 = 5 ' END IF IF (KFLAG.EQ.3) GO TO 70 SOUT = S(1) UU(K) = U SS(K,1) = SOUT SS(K,2) = S(2) SS(K,3) = S(3) 80 CONTINUE IND = 4 DO 90 I = 2,5 CALL FG(UU(I),SS(I,1),GG(I)) 90 CONTINUE GG(1) = 0.0 DO 100 I = 1,4 DG(I) = GG(I+1) - GG(I) 100 CONTINUE D2G = DG(4) - DG(3) D3G = DG(4) - 2.0*DG(3) + DG(2) D4G = DG(4) - 3.0*DG(3) + 3.0*DG(2) - DG(1) SUMM = HU*(GG(5)-3.5*DG(4)+53.0*D2G/12.0 1 -55.0*D3G/24.0+251.0*D4G/720.0) C C Presumably, SS(2,1) should be SS(1,1) + SUMM. C OLDSS2 = SS(2,1) SS(2,1) = SS(1,1) + SUMM IF (SS(2,1).LE.-1.0) SS(2,1) = -1.0 + EPSMIN IF (SS(2,1).GE.1.0) SS(2,1) = 1.0 - EPSMIN C C Also improve the value of Y(2) at TSTAR. C SS(2,2) = 0.5*(SS(1,2)+SS(3,2)) SS(2,3) = 0.5*(SS(1,3)+SS(3,3)) CHNG = SS(2,1) - OLDSS2 IF (CHNG.GE.0.0 .AND. OLDSS2.GT.SLO) SLO = OLDSS2 IF (CHNG.LE.0.0 .AND. OLDSS2.LT.SUP) SUP = OLDSS2 IF ((SS(2,1).GE.SUP .AND. SLO.GT.-TEN5) .OR. 1 (SS(2,1).LE.SLO .AND. SUP.LT.TEN5)) 2 SS(2,1) = 0.5*(SLO+SUP) IF (ABS(SS(2,1)-OLDSS2).GT.EPSMIN) GO TO 60 END IF IF (IND.EQ.4) THEN DO 110 I = 1,6 TT(I) = SS(I,1) YY(I,1) = UU(I) YY(I,2) = SS(I,2) YY(I,3) = SS(I,3) 110 CONTINUE END IF TOUT = TT(6) IND = 1 RETURN END SUBROUTINE GERK(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK, IWORK) C C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C C WRITTEN BY H.A.WATTS AND L.F.SHAMPINE C SANDIA LABORATORIES C C GERK IS DESIGNED TO SOLVE SYSTEMS OF DIFFERENTIAL EQUATIONS C WHEN IT IS IMPORTANT TO HAVE A READILY AVAILABLE GLOBAL ERROR C ESTIMATE. PARALLEL INTEGRATION IS PERFORMED TO YIELD TWO C SOLUTIONS ON DIFFERENT MESH SPACINGS AND GLOBAL EXTRAPOLATION C IS APPLIED TO PROVIDE AN ESTIMATE OF THE GLOBAL ERROR IN THE C MORE ACCURATE SOLUTION. C C FOR IBM SYSTEM 360 AND 370 AND OTHER MACHINES OF SIMILAR C ARITHMETIC CHARACTERISTICS, THIS CODE SHOULD BE CONVERTED TO C DOUBLE PRECISION. C C******************************************************************* C ABSTRACT C******************************************************************* C C SUBROUTINE GERK INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT = F(T,Y(1),Y(2),...,Y(NEQN)) C WHERE THE Y(I) ARE GIVEN AT T . C TYPICALLY THE SUBROUTINE IS USED TO INTEGRATE FROM T TO TOUT C BUT IT CAN BE USED AS A ONE-STEP INTEGRATOR TO ADVANCE THE C SOLUTION A SINGLE STEP IN THE DIRECTION OF TOUT. ON RETURN, AN C ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T IS PROVIDED C AND THE PARAMETERS IN THE CALL LIST ARE SET FOR CONTINUING THE C INTEGRATION. THE USER HAS ONLY TO CALL GERK AGAIN (AND PERHAPS C DEFINE A NEW VALUE FOR TOUT). ACTUALLY, GERK IS MERELY AN C INTERFACING ROUTINE WHICH ALLOCATES VIRTUAL STORAGE IN THE C ARRAYS WORK, IWORK AND CALLS SUBROUTINE GERKS FOR THE SOLUTION. C GERKS IN TURN CALLS SUBROUTINE FEHL WHICH COMPUTES AN APPROX- C IMATE SOLUTION OVER ONE STEP. C C GERK USES THE RUNGE-KUTTA-FEHLBERG (4,5) METHOD DESCRIBED C IN THE REFERENCE C E.FEHLBERG , LOW-ORDER CLASSICAL RUNGE-KUTTA FORMULAS WITH C STEPSIZE CONTROL , NASA TR R-315 C C C THE PARAMETERS REPRESENT- C F -- SUBROUTINE F(T,Y,YP) TO EVALUATE DERIVATIVES C YP(I)=DY(I)/DT C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED C Y(*) -- SOLUTION VECTOR AT T C T -- INDEPENDENT VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED C RELERR,ABSERR -- RELATIVE AND ABSOLUTE ERROR TOLERANCES FOR C LOCAL ERROR TEST. AT EACH STEP THE CODE REQUIRES THAT C ABS(LOCAL ERROR) .LE. RELERR*ABS(Y) + ABSERR C FOR EACH COMPONENT OF THE LOCAL ERROR AND SOLUTION C VECTORS. C IFLAG -- INDICATOR FOR STATUS OF INTEGRATION C GERROR(*) -- VECTOR WHICH ESTIMATES THE GLOBAL ERROR AT T. C THAT IS, GERROR(I) APPROXIMATES Y(I)-TRUE C SOLUTION(I). C WORK(*) -- ARRAY TO HOLD INFORMATION INTERNAL TO GERK WHICH C IS NECESSARY FOR SUBSEQUENT CALLS. MUST BE DIMENSIONED C AT LEAST 3+8*NEQN C IWORK(*) -- INTEGER ARRAY USED TO HOLD INFORMATION INTERNAL C TO GERK WHICH IS NECESSARY FOR SUBSEQUENT CALLS. MUST C BE DIMENSIONED AT LEAST 5 C C C******************************************************************* C FIRST CALL TO GERK C******************************************************************* C C THE USER MUST PROVIDE STORAGE IN HIS CALLING PROGRAM FOR THE C ARRAYS IN THE CALL LIST - Y(NEQN), WORK(3+8*NEQN), IWORK(5), C DECLARE F IN AN EXTERNAL STATEMENT, SUPPLY SUBROUTINE F(T,Y,YP) C AND INITIALIZE THE FOLLOWING PARAMETERS- C C NEQN -- NUMBER OF EQUATIONS TO BE INTEGRATED. (NEQN .GE. 1) C Y(*) -- VECTOR OF INITIAL CONDITIONS C T -- STARTING POINT OF INTEGRATION , MUST BE A VARIABLE C TOUT -- OUTPUT POINT AT WHICH SOLUTION IS DESIRED. C T=TOUT IS ALLOWED ON THE FIRST CALL ONLY,IN WHICH CASE C GERK RETURNS WITH IFLAG=2 IF CONTINUATION IS POSSIBLE. C RELERR,ABSERR -- RELATIVE AND ABSOLUTE LOCAL ERROR TOLERANCES C WHICH MUST BE NON-NEGATIVE BUT MAY BE CONSTANTS. WE CAN C USUALLY EXPECT THE GLOBAL ERRORS TO BE SOMEWHAT SMALLER C THAN THE REQUESTED LOCAL ERROR TOLERANCES. TO AVOID C LIMITING PRECISION DIFFICULTIES THE CODE ALWAYS USES C THE LARGER OF RELERR AND AN INTERNAL RELATIVE ERROR C PARAMETER WHICH IS MACHINE DEPENDENT. C IFLAG -- +1,-1 INDICATOR TO INITIALIZE THE CODE FOR EACH NEW C PROBLEM. NORMAL INPUT IS +1. THE USER SHOULD SET IFLAG= C -1 ONLY WHEN ONE-STEP INTEGRATOR CONTROL IS ESSENTIAL. C IN THIS CASE, GERK ATTEMPTS TO ADVANCE THE SOLUTION A C SINGLE STEP IN THE DIRECTION OF TOUT EACH TIME IT IS C CALLED. SINCE THIS MODE OF OPERATION RESULTS IN EXTRA C COMPUTING OVERHEAD, IT SHOULD BE AVOIDED UNLESS NEEDED. C C C******************************************************************* C OUTPUT FROM GERK C******************************************************************* C C Y(*) -- SOLUTION AT T C T -- LAST POINT REACHED IN INTEGRATION. C IFLAG = 2 -- INTEGRATION REACHED TOUT. INDICATES SUCCESSFUL C RETURN AND IS THE NORMAL MODE FOR CONTINUING C INTEGRATION. C =-2 -- A SINGLE SUCCESSFUL STEP IN THE DIRECTION OF C TOUT HAS BEEN TAKEN. NORMAL MODE FOR CONTINUING C INTEGRATION ONE STEP AT A TIME. C = 3 -- INTEGRATION WAS NOT COMPLETED BECAUSE MORE THAN C 9000 DERIVATIVE EVALUATIONS WERE NEEDED. THIS C IS APPROXIMATELY 500 STEPS. C = 4 -- INTEGRATION WAS NOT COMPLETED BECAUSE SOLUTION C VANISHED MAKING A PURE RELATIVE ERROR TEST C IMPOSSIBLE. MUST USE NON-ZERO ABSERR TO CONTINUE. C USING THE ONE-STEP INTEGRATION MODE FOR ONE STEP C IS A GOOD WAY TO PROCEED. C = 5 -- INTEGRATION WAS NOT COMPLETED BECAUSE REQUESTED C ACCURACY COULD NOT BE ACHIEVED USING SMALLEST C ALLOWABLE STEPSIZE. USER MUST INCREASE THE ERROR C TOLERANCE BEFORE CONTINUED INTEGRATION CAN BE C ATTEMPTED. C = 6 -- GERK IS BEING USED INEFFICIENTLY IN SOLVING C THIS PROBLEM. TOO MUCH OUTPUT IS RESTRICTING THE C NATURAL STEPSIZE CHOICE. USE THE ONE-STEP C INTEGRATOR MODE. C = 7 -- INVALID INPUT PARAMETERS C THIS INDICATOR OCCURS IF ANY OF THE FOLLOWING IS C SATISFIED - NEQN .LE. 0 C T=TOUT AND IFLAG .NE. +1 OR -1 C RELERR OR ABSERR .LT. 0. C IFLAG .EQ. 0 OR .LT. -2 OR .GT. 7 C GERROR(*) -- ESTIMATE OF THE GLOBAL ERROR IN THE SOLUTION AT T C WORK(*),IWORK(*) -- INFORMATION WHICH IS USUALLY OF NO C INTEREST TO THE USER BUT NECESSARY FOR SUBSEQUENT C CALLS. WORK(1),...,WORK(NEQN) CONTAIN THE FIRST C DERIVATIVES OF THE SOLUTION VECTOR Y AT T. C WORK(NEQN+1) CONTAINS THE STEPSIZE H TO BE C ATTEMPTED ON THE NEXT STEP. IWORK(1) CONTAINS C THE DERIVATIVE EVALUATION COUNTER. C C C******************************************************************* C SUBSEQUENT CALLS TO GERK C******************************************************************* C C SUBROUTINE GERK RETURNS WITH ALL INFORMATION NEEDED TO CONTINUE C THE INTEGRATION. IF THE INTEGRATION REACHED TOUT, THE USER NEED C ONLY DEFINE A NEW TOUT AND CALL GERK AGAIN. IN THE ONE-STEP C INTEGRATOR MODE (IFLAG=-2) THE USER MUST KEEP IN MIND THAT EACH C STEP TAKEN IS IN THE DIRECTION OF THE CURRENT TOUT. UPON C REACHING TOUT (INDICATED BY CHANGING IFLAG TO 2), THE USER MUST C THEN DEFINE A NEW TOUT AND RESET IFLAG TO -2 TO CONTINUE IN THE C ONE-STEP INTEGRATOR MODE. C C IF THE INTEGRATION WAS NOT COMPLETED BUT THE USER STILL WANTS C TO CONTINUE (IFLAG=3 CASE), HE JUST CALLS GERK AGAIN. THE C FUNCTION COUNTER IS THEN RESET TO 0 AND ANOTHER 9000 FUNCTION C EVALUATIONS ARE ALLOWED. C C HOWEVER, IN THE CASE IFLAG=4, THE USER MUST FIRST ALTER THE C ERROR CRITERION TO USE A POSITIVE VALUE OF ABSERR BEFORE C INTEGRATION CAN PROCEED. IF HE DOES NOT,EXECUTION IS TERMINATED. C C ALSO, IN THE CASE IFLAG=5, IT IS NECESSARY FOR THE USER TO C RESET IFLAG TO 2 (OR -2 WHEN THE ONE-STEP INTEGRATION MODE IS C BEING USED) AS WELL AS INCREASING EITHER ABSERR,RELERR OR BOTH C BEFORE THE INTEGRATION CAN BE CONTINUED. IF THIS IS NOT DONE, C EXECUTION WILL BE TERMINATED. THE OCCURRENCE OF IFLAG=5 C INDICATES A TROUBLE SPOT (SOLUTION IS CHANGING RAPIDLY, C SINGULARITY MAY BE PRESENT) AND IT OFTEN IS INADVISABLE TO C CONTINUE. C C IF IFLAG=6 IS ENCOUNTERED, THE USER SHOULD USE THE ONE-STEP C INTEGRATION MODE WITH THE STEPSIZE DETERMINED BY THE CODE. IF C THE USER INSISTS UPON CONTINUING THE INTEGRATION WITH GERK IN C THE INTERVAL MODE, HE MUST RESET IFLAG TO 2 BEFORE CALLING GERK C AGAIN. OTHERWISE,EXECUTION WILL BE TERMINATED. C C IF IFLAG=7 IS OBTAINED, INTEGRATION CAN NOT BE CONTINUED UNLESS C THE INVALID INPUT PARAMETERS ARE CORRECTED. C C IT SHOULD BE NOTED THAT THE ARRAYS WORK,IWORK CONTAIN C INFORMATION REQUIRED FOR SUBSEQUENT INTEGRATION. ACCORDINGLY, C WORK AND IWORK SHOULD NOT BE ALTERED. C C******************************************************************* C C .. SCALAR ARGUMENTS .. INTEGER IFLAG,NEQN DOUBLE PRECISION ABSERR,RELERR,T,TOUT C .. C .. ARRAY ARGUMENTS .. INTEGER IWORK(5) DOUBLE PRECISION GERROR(NEQN),WORK(3+8*NEQN),Y(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K1,K1M,K2,K3,K4,K5,K6,K7,K8 C .. C .. EXTERNAL SUBROUTINES .. EXTERNAL GERKS C .. C COMPUTE INDICES FOR THE SPLITTING OF THE WORK ARRAY K1M = NEQN + 1 K1 = K1M + 1 K2 = K1 + NEQN K3 = K2 + NEQN K4 = K3 + NEQN K5 = K4 + NEQN K6 = K5 + NEQN K7 = K6 + NEQN K8 = K7 + NEQN C ******************************************************************* C THIS INTERFACING ROUTINE MERELY RELIEVES THE USER OF A LONG C CALLING LIST VIA THE SPLITTING APART OF TWO WORKING STORAGE C ARRAYS. IF THIS IS NOT COMPATIBLE WITH THE USERS COMPILER, C HE MUST USE GERKS DIRECTLY. C ******************************************************************* CALL GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, WORK(1), WORK(K1M), WORK(K1), WORK(K2), WORK(K3), * WORK(K4), WORK(K5), WORK(K6), WORK(K7), WORK(K8), * WORK(K8+1), IWORK(1), IWORK(2), IWORK(3), IWORK(4), IWORK(5)) RETURN END SUBROUTINE GERKS(F, NEQN, Y, T, TOUT, RELERR, ABSERR, IFLAG, * GERROR, YP, H, F1, F2, F3, F4, F5, YG, YGP, SAVRE, SAVAE, * NFE, KOP, INIT, JFLAG, KFLAG) C FEHLBERG FOURTH(FIFTH) ORDER RUNGE-KUTTA METHOD WITH C GLOBAL ERROR ASSESSMENT C ******************************************************************* C GERKS INTEGRATES A SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL C EQUATIONS AS DESCRIBED IN THE COMMENTS FOR GERK. THE ARRAYS C YP,F1,F2,F3,F4,F5,YG AND YGP (OF DIMENSION AT LEAST NEQN) AND C THE VARIABLES H,SAVRE,SAVAE,NFE,KOP,INIT,JFLAG,AND KFLAG ARE C USED INTERNALLY BY THE CODE AND APPEAR IN THE CALL LIST TO C ELIMINATE LOCAL RETENTION OF VARIABLES BETWEEN CALLS. C ACCORDINGLY, THEY SHOULD NOT BE ALTERED. ITEMS OF POSSIBLE C INTEREST ARE C YP - DERIVATIVE OF SOLUTION VECTOR AT T C H - AN APPROPRIATE STEPSIZE TO BE USED FOR THE NEXT STEP C NFE- COUNTER ON THE NUMBER OF DERIVATIVE FUNCTION C EVALUATIONS. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER IFLAG,INIT,JFLAG,KFLAG,KOP,NEQN,NFE DOUBLE PRECISION ABSERR,H,RELERR,SAVAE,SAVRE,T,TOUT C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 GERROR(NEQN),Y(NEQN),YG(NEQN),YGP(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K,MAXNFE,MFLAG LOGICAL HFAILD,OUTPUT DOUBLE PRECISION A,AE,DT,EE,EEOET,ESTTOL,ET,HH,HMIN,ONE,REMIN,RER, 1 S,SCALE,TOL,TOLN,TS,U,U26,YPK C .. C .. EXTERNAL FUNCTIONS .. DOUBLE PRECISION EPSLON EXTERNAL EPSLON C .. C .. EXTERNAL SUBROUTINES .. EXTERNAL FEHL C .. C .. INTRINSIC FUNCTIONS .. INTRINSIC ABS,MAX,MIN,SIGN C .. C ******************************************************************* C REMIN IS A TOLERANCE THRESHOLD WHICH IS ALSO DETERMINED BY THE C INTEGRATION METHOD. IN PARTICULAR, A FIFTH ORDER METHOD WILL C GENERALLY NOT BE CAPABLE OF DELIVERING ACCURACIES NEAR LIMITING C PRECISION ON COMPUTERS WITH LONG WORDLENGTHS. DATA REMIN /3.E-11/ C ******************************************************************* C THE EXPENSE IS CONTROLLED BY RESTRICTING THE NUMBER C OF FUNCTION EVALUATIONS TO BE APPROXIMATELY MAXNFE. C AS SET,THIS CORRESPONDS TO ABOUT 500 STEPS. DATA MAXNFE /9000/ C ******************************************************************* C U - THE COMPUTER UNIT ROUNDOFF ERROR U IS THE SMALLEST POSITIVE C VALUE REPRESENTABLE IN THE MACHINE SUCH THAT 1.+ U .GT. 1. C (VARIABLE ONE SET TO 1.0 EASES PRECISION CONVERSION.) C ONE = 1.0 U = EPSLON(ONE) C ******************************************************************* C CHECK INPUT PARAMETERS IF (NEQN.LT.1) GO TO 10 IF ((RELERR.LT.0.) .OR. (ABSERR.LT.0.)) GO TO 10 MFLAG = ABS(IFLAG) IF ((MFLAG.GE.1) .AND. (MFLAG.LE.7)) GO TO 20 C INVALID INPUT 10 IFLAG = 7 RETURN C IS THIS THE FIRST CALL 20 IF (MFLAG.EQ.1) GO TO 70 C CHECK CONTINUATION POSSIBILITIES IF (T.EQ.TOUT) GO TO 10 IF (MFLAG.NE.2) GO TO 30 C IFLAG = +2 OR -2 IF (INIT.EQ.0) GO TO 60 IF (KFLAG.EQ.3) GO TO 50 IF ((KFLAG.EQ.4) .AND. (ABSERR.EQ.0.)) GO TO 40 IF ((KFLAG.EQ.5) .AND. (RELERR.LE.SAVRE) .AND. * (ABSERR.LE.SAVAE)) GO TO 40 GO TO 70 C IFLAG = 3,4,5,6, OR 7 30 IF (IFLAG.EQ.3) GO TO 50 IF ((IFLAG.EQ.4) .AND. (ABSERR.GT.0.)) GO TO 60 C INTEGRATION CANNOT BE CONTINUED SINCE USER DID NOT RESPOND TO C THE INSTRUCTIONS PERTAINING TO IFLAG=4,5,6 OR 7 40 STOP C ******************************************************************* C RESET FUNCTION EVALUATION COUNTER 50 NFE = 0 IF (MFLAG.EQ.2) GO TO 70 C RESET FLAG VALUE FROM PREVIOUS CALL 60 IFLAG = JFLAG C SAVE INPUT IFLAG AND SET CONTINUATION FLAG VALUE FOR SUBSEQUENT C INPUT CHECKING 70 JFLAG = IFLAG KFLAG = 0 C SAVE RELERR AND ABSERR FOR CHECKING INPUT ON SUBSEQUENT CALLS SAVRE = RELERR SAVAE = ABSERR C RESTRICT RELATIVE ERROR TOLERANCE TO BE AT LEAST AS LARGE AS C 32U+REMIN TO AVOID LIMITING PRECISION DIFFICULTIES ARISING C FROM IMPOSSIBLE ACCURACY REQUESTS RER = MAX(RELERR,32.*U+REMIN) U26 = 26.*U DT = TOUT - T IF (MFLAG.EQ.1) GO TO 80 IF (INIT.EQ.0) GO TO 90 GO TO 110 C ******************************************************************* C INITIALIZATION -- C SET INITIALIZATION COMPLETION INDICATOR,INIT C SET INDICATOR FOR TOO MANY OUTPUT POINTS,KOP C EVALUATE INITIAL DERIVATIVES C COPY INITIAL VALUES AND DERIVATIVES FOR THE C PARALLEL SOLUTION C SET COUNTER FOR FUNCTION EVALUATIONS,NFE C ESTIMATE STARTING STEPSIZE 80 INIT = 0 KOP = 0 A = T CALL F(A, Y, YP) NFE = 1 IF (T.NE.TOUT) GO TO 90 IFLAG = 2 RETURN 90 INIT = 1 H = ABS(DT) TOLN = 0. DO 100 K=1,NEQN YG(K) = Y(K) YGP(K) = YP(K) TOL = RER*ABS(Y(K)) + ABSERR IF (TOL.LE.0.) GO TO 100 TOLN = TOL YPK = ABS(YP(K)) IF (YPK*H**5.GT.TOL) H = (TOL/YPK)**0.2 100 CONTINUE IF (TOLN.LE.0.) H = 0. H = MAX(H,U26*MAX(ABS(T),ABS(DT))) C ******************************************************************* C SET STEPSIZE FOR INTEGRATION IN THE DIRECTION FROM T TO TOUT 110 H = SIGN(H,DT) C TEST TO SEE IF GERK IS BEING SEVERELY IMPACTED BY TOO MANY C OUTPUT POINTS IF (ABS(H).GT.2.*ABS(DT)) KOP = KOP + 1 IF (KOP.NE.100) GO TO 120 KOP = 0 IFLAG = 6 RETURN 120 IF (ABS(DT).GT.U26*ABS(T)) GO TO 140 C IF TOO CLOSE TO OUTPUT POINT,EXTRAPOLATE AND RETURN DO 130 K=1,NEQN YG(K) = YG(K) + DT*YGP(K) Y(K) = Y(K) + DT*YP(K) 130 CONTINUE A = TOUT CALL F(A, YG, YGP) CALL F(A, Y, YP) NFE = NFE + 2 GO TO 230 C INITIALIZE OUTPUT POINT INDICATOR 140 OUTPUT = .FALSE. C TO AVOID PREMATURE UNDERFLOW IN THE ERROR TOLERANCE FUNCTION, C SCALE THE ERROR TOLERANCES SCALE = 2./RER AE = SCALE*ABSERR C ******************************************************************* C ******************************************************************* C STEP BY STEP INTEGRATION 150 HFAILD = .FALSE. C SET SMALLEST ALLOWABLE STEPSIZE HMIN = U26*ABS(T) C ADJUST STEPSIZE IF NECESSARY TO HIT THE OUTPUT POINT. C LOOK AHEAD TWO STEPS TO AVOID DRASTIC CHANGES IN THE STEPSIZE C AND THUS LESSEN THE IMPACT OF OUTPUT POINTS ON THE CODE. DT = TOUT - T IF (ABS(DT).GE.2.*ABS(H)) GO TO 170 IF (ABS(DT).GT.ABS(H)) GO TO 160 C THE NEXT SUCCESSFUL STEP WILL COMPLETE THE INTEGRATION TO THE C OUTPUT POINT OUTPUT = .TRUE. H = DT GO TO 170 160 H = 0.5*DT C ******************************************************************* C CORE INTEGRATOR FOR TAKING A SINGLE STEP C ******************************************************************* C THE TOLERANCES HAVE BEEN SCALED TO AVOID PREMATURE UNDERFLOW C IN COMPUTING THE ERROR TOLERANCE FUNCTION ET. C TO AVOID PROBLEMS WITH ZERO CROSSINGS, RELATIVE ERROR IS C MEASURED USING THE AVERAGE OF THE MAGNITUDES OF THE SOLUTION C AT THE BEGINNING AND END OF A STEP. C THE ERROR ESTIMATE FORMULA HAS BEEN GROUPED TO CONTROL LOSS OF C SIGNIFICANCE. C TO DISTINGUISH THE VARIOUS ARGUMENTS, H IS NOT PERMITTED C TO BECOME SMALLER THAN 26 UNITS OF ROUNDOFF IN T. C PRACTICAL LIMITS ON THE CHANGE IN THE STEPSIZE ARE ENFORCED TO C SMOOTH THE STEPSIZE SELECTION PROCESS AND TO AVOID EXCESSIVE C CHATTERING ON PROBLEMS HAVING DISCONTINUITIES. C TO PREVENT UNNECESSARY FAILURES, THE CODE USES 9/10 THE C STEPSIZE IT ESTIMATES WILL SUCCEED. C AFTER A STEP FAILURE, THE STEPSIZE IS NOT ALLOWED TO INCREASE C FOR THE NEXT ATTEMPTED STEP. THIS MAKES THE CODE MORE C EFFICIENT ON PROBLEMS HAVING DISCONTINUITIES AND MORE C EFFECTIVE IN GENERAL SINCE LOCAL EXTRAPOLATION IS BEING USED C AND THE ERROR ESTIMATE MAY BE UNRELIABLE OR UNACCEPTABLE WHEN C A STEP FAILS. C ******************************************************************* C TEST NUMBER OF DERIVATIVE FUNCTION EVALUATIONS. C IF OKAY,TRY TO ADVANCE THE INTEGRATION FROM T TO T+H 170 IF (NFE.LE.MAXNFE) GO TO 180 C TOO MUCH WORK IFLAG = 3 KFLAG = 3 RETURN C ADVANCE AN APPROXIMATE SOLUTION OVER ONE STEP OF LENGTH H 180 CALL FEHL(F, NEQN, YG, T, H, YGP, F1, F2, F3, F4, F5, F1) NFE = NFE + 5 C COMPUTE AND TEST ALLOWABLE TOLERANCES VERSUS LOCAL ERROR C ESTIMATES AND REMOVE SCALING OF TOLERANCES. NOTE THAT RELATIVE C ERROR IS MEASURED WITH RESPECT TO THE AVERAGE MAGNITUDES OF THE C OF THE SOLUTION AT THE BEGINNING AND END OF THE STEP. EEOET = 0. DO 200 K=1,NEQN ET = ABS(YG(K)) + ABS(F1(K)) + AE IF (ET.GT.0.) GO TO 190 C INAPPROPRIATE ERROR TOLERANCE IFLAG = 4 KFLAG = 4 RETURN 190 EE = ABS((-2090.*YGP(K)+(21970.*F3(K)-15048.*F4(K))) * +(22528.*F2(K)-27360.*F5(K))) EEOET = MAX(EEOET,EE/ET) 200 CONTINUE ESTTOL = ABS(H)*EEOET*SCALE/752400. IF (ESTTOL.LE.1.) GO TO 210 C UNSUCCESSFUL STEP C REDUCE THE STEPSIZE , TRY AGAIN C THE DECREASE IS LIMITED TO A FACTOR OF 1/10 HFAILD = .TRUE. OUTPUT = .FALSE. S = 0.1 IF (ESTTOL.LT.59049.) S = 0.9/ESTTOL**0.2 H = S*H IF (ABS(H).GT.HMIN) GO TO 170 C REQUESTED ERROR UNATTAINABLE AT SMALLEST ALLOWABLE STEPSIZE IFLAG = 5 KFLAG = 5 RETURN C SUCCESSFUL STEP C STORE ONE-STEP SOLUTION YG AT T+H C AND EVALUATE DERIVATIVES THERE 210 TS = T T = T + H DO 220 K=1,NEQN YG(K) = F1(K) 220 CONTINUE A = T CALL F(A, YG, YGP) NFE = NFE + 1 C NOW ADVANCE THE Y SOLUTION OVER TWO STEPS OF C LENGTH H/2 AND EVALUATE DERIVATIVES THERE HH = 0.5*H CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) TS = TS + HH A = TS CALL F(A, Y, YP) CALL FEHL(F, NEQN, Y, TS, HH, YP, F1, F2, F3, F4, F5, Y) A = T CALL F(A, Y, YP) NFE = NFE + 12 C CHOOSE NEXT STEPSIZE C THE INCREASE IS LIMITED TO A FACTOR OF 5 C IF STEP FAILURE HAS JUST OCCURRED, NEXT C STEPSIZE IS NOT ALLOWED TO INCREASE S = 5. IF (ESTTOL.GT.1.889568E-4) S = 0.9/ESTTOL**0.2 IF (HFAILD) S = MIN(S,ONE) H = SIGN(MAX(S*ABS(H),HMIN),H) C ******************************************************************* C END OF CORE INTEGRATOR C ******************************************************************* C SHOULD WE TAKE ANOTHER STEP IF (OUTPUT) GO TO 230 IF (IFLAG.GT.0) GO TO 150 C ******************************************************************* C ******************************************************************* C INTEGRATION SUCCESSFULLY COMPLETED C ONE-STEP MODE IFLAG = -2 GO TO 240 C INTERVAL MODE 230 T = TOUT IFLAG = 2 240 DO 250 K=1,NEQN GERROR(K) = (YG(K)-Y(K))/31. 250 CONTINUE RETURN END SUBROUTINE FEHL(F, NEQN, Y, T, H, YP, F1, F2, F3, F4, F5, S) C FEHLBERG FOURTH-FIFTH ORDER RUNGE-KUTTA METHOD C ******************************************************************* C FEHL INTEGRATES A SYSTEM OF NEQN FIRST ORDER C ORDINARY DIFFERENTIAL EQUATIONS OF THE FORM C DY(I)/DT=F(T,Y(1),---,Y(NEQN)) C WHERE THE INITIAL VALUES Y(I) AND THE INITIAL DERIVATIVES C YP(I) ARE SPECIFIED AT THE STARTING POINT T. FEHL ADVANCES C THE SOLUTION OVER THE FIXED STEP H AND RETURNS C THE FIFTH ORDER (SIXTH ORDER ACCURATE LOCALLY) SOLUTION C APPROXIMATION AT T+H IN ARRAY S(I). C F1,---,F5 ARE ARRAYS OF DIMENSION NEQN WHICH ARE NEEDED C FOR INTERNAL STORAGE. C THE FORMULAS HAVE BEEN GROUPED TO CONTROL LOSS OF SIGNIFICANCE. C FEHL SHOULD BE CALLED WITH AN H NOT SMALLER THAN 13 UNITS OF C ROUNDOFF IN T SO THAT THE VARIOUS INDEPENDENT ARGUMENTS CAN BE C DISTINGUISHED. C ******************************************************************* C .. SCALAR ARGUMENTS .. INTEGER NEQN DOUBLE PRECISION H,T C .. C .. ARRAY ARGUMENTS .. DOUBLE PRECISION F1(NEQN),F2(NEQN),F3(NEQN),F4(NEQN),F5(NEQN), 1 S(NEQN),Y(NEQN),YP(NEQN) C .. C .. SUBROUTINE ARGUMENTS .. EXTERNAL F C .. C .. LOCAL SCALARS .. INTEGER K DOUBLE PRECISION CH C .. CH = 0.25*H DO 10 K=1,NEQN F5(K) = Y(K) + CH*YP(K) 10 CONTINUE CALL F(T+0.25*H, F5, F1) CH = 0.09375*H DO 20 K=1,NEQN F5(K) = Y(K) + CH*(YP(K)+3.*F1(K)) 20 CONTINUE CALL F(T+0.375*H, F5, F2) CH = H/2197. DO 30 K=1,NEQN F5(K) = Y(K) + CH*(1932.*YP(K)+(7296.*F2(K)-7200.*F1(K))) 30 CONTINUE CALL F(T+12./13.*H, F5, F3) CH = H/4104. DO 40 K=1,NEQN F5(K) = Y(K) + CH*((8341.*YP(K)-845.*F3(K))+(29440.*F2(K) * -32832.*F1(K))) 40 CONTINUE CALL F(T+H, F5, F4) CH = H/20520. DO 50 K=1,NEQN F1(K) = Y(K) + CH*((-6080.*YP(K)+(9295.*F3(K)-5643.*F4(K))) * +(41040.*F1(K)-28352.*F2(K))) 50 CONTINUE CALL F(T+0.5*H, F1, F5) C COMPUTE APPROXIMATE SOLUTION AT T+H CH = H/7618050. DO 60 K=1,NEQN S(K) = Y(K) + CH*((902880.*YP(K)+(3855735.*F3(K)-1371249.* * F4(K)))+(3953664.*F2(K)+277020.*F5(K))) 60 CONTINUE RETURN END DOUBLE PRECISION FUNCTION EPSLON (X) DOUBLE PRECISION X C C ESTIMATE UNIT ROUNDOFF IN QUANTITIES OF SIZE X. C DOUBLE PRECISION A,B,C,EPS,FOUR,THREE C C THIS PROGRAM SHOULD FUNCTION PROPERLY ON ALL SYSTEMS C SATISFYING THE FOLLOWING TWO ASSUMPTIONS, C 1. THE BASE USED IN REPRESENTING FLOATING POINT C NUMBERS IS NOT A POWER OF THREE. C 2. THE QUANTITY A IN STATEMENT 10 IS REPRESENTED TO C THE ACCURACY USED IN FLOATING POINT VARIABLES C THAT ARE STORED IN MEMORY. C THE STATEMENT NUMBER 10 AND THE GO TO 10 ARE INTENDED TO C FORCE OPTIMIZING COMPILERS TO GENERATE CODE SATISFYING C ASSUMPTION 2. C UNDER THESE ASSUMPTIONS, IT SHOULD BE TRUE THAT, C A IS NOT EXACTLY EQUAL TO FOUR-THIRDS, C B HAS A ZERO FOR ITS LAST BIT OR DIGIT, C C IS NOT EXACTLY EQUAL TO ONE, C EPS MEASURES THE SEPARATION OF 1.0 FROM C THE NEXT LARGER FLOATING POINT NUMBER. C FOUR = 4.0 THREE = 3.0 A = FOUR/THREE 10 B = A - 1.0 C = B + B + B EPS = ABS(C-1.0) IF (EPS .EQ. 0.0) GO TO 10 EPSLON = EPS*ABS(X) RETURN END SHAR_EOF fi # end of overwriting check if test -f 'sleign2x.tex' then echo shar: will not over-write existing file "'sleign2x.tex'" else cat << SHAR_EOF > 'sleign2x.tex' \documentstyle[12pt]{article} \topmargin 0in \textheight 8in \oddsidemargin 0in \evensidemargin 0in \textwidth 6.5in \pagestyle{empty} \newfont{\msbm}{msbm10 scaled\magstephalf} \newcommand{\Z}{\mbox{\msbm Z}} \newcommand{\dfrac}{\displaystyle\frac} \newcommand{\ul}{\underline} \newenvironment{romlist}{\begin{list}{(\roman{romnum})} {\usecounter{romnum}\setlength{\topsep}{1pt} \setlength{\itemsep}{1pt}} \rm}{\end{list}} \newcommand{\zettleq}{\raise.08in\hbox{.} \!\!\! =\!\!\!\raise-.03in\hbox{.} } \begin{document} \baselineskip=24pt \begin{center} SLEIGN2 \end{center} \vspace*{.2in} \noindent {\bf Commentary on the individual examples in xamples.f} These examples have been chosen to illustrate the capabilities and limitations of the program SLEIGN2. Many of the examples have been chosen from special cases of the well known and well studied ``special functions" of mathematical analysis. All possible cases of end-point classifications are represented; general separated regular and singular boundary conditions may be applied to these examples as appropriate. Also coupled periodic-type boundary conditions can be used in the regular case. For some of these examples it is possible to give explicit information on the spectrum of associated boundary value problems; this can take the form of providing explicit formulas for eigenvalues against which the program calculated results can be compared. In all cases of limit-circle end-points boundary condition functions $u$ and $v$ have been entered as part of the example data. In the case of limit-circle non-oscillatory end-points we use the convention that the boundary condition function $u$ determines the principal or Friedrichs boundary condition. On selecting a numbered example the the differential equation is displayed in FORTRAN, and details of the end-point classification given. If information on the form of the boundary condition functions $u$ and $v$ is required then the user should scroll through the xamples.f file to the appropriate numbered part of the $u, \ v$ section. Some regular and weakly regular problems can be more successfully run using the limit-circle non-oscillatory (LCNO) algorithm; details are given below for some of the examples. It should be noted that for the limit-circle oscillatory problems it is sometimes difficult to compute numerically more than a few of the eigenvalues. One example is included for which the program fails; see Laguerre \#22. This problem has a discrete spectrum and for one particular boundary condition the eigenvalues are known explicitly. In this case numerical values to confirm the details of the spectrum can be obtained by use of the Liouville transformation; this leads to the Laguerre/Liouville example \#23 for which the program is successful. The Liouville transformation has also been applied to the Jacobi equation, \#16 to yield the Jacobi/Liouville example \#24. The Liouville transformation is sometimes useful to get a Sturm-Liouville differential equation into a form more suitable for numerical computation. {\bf Parameters.} Many of the examples involve the choice of one or more parameters; the range of these parameters is given when the numbered differential equation is displayed. If a choice of parameter is made outside of the stated range the program may abort. {\bf Remarks on the individual examples.} \begin{enumerate} \item%1 {\bf Classical Legendre equation} \begin{itemize} \item[(i)] The Legendre polynomials are obtained by taking the principal (Friedrichs) boundary condition at both end-points $\pm 1:$ enter $A1=1, \; A2=0, \; B1 = 1 , B2 = 0 $ i.e. take the boundary condition function $u$ at $ \pm 1$; eigenvalues: $\lambda_n = (n+1/2 ) (n+ 1/2) \ ; n = 0,1,2, \cdots $; eigenfunctions: Legendre polynomials $P_n(x)$. \item[(ii)] Enter $A1=0, \; A2 = 1, \; B1 = 0, \; B2=1, $ i.e. use the b.c. function $v$ at $\pm 1$; eigenvalues: $\mu_n ; n=0,1,2,\cdots $ no explicit formula is available; eigenfunctions: are logarithmically unbounded at $\pm 1$. Observe that $\mu_n < \lambda_n < \mu_{n+1} \ ; n=0,1,2 \cdots $. \cite{T}: Chapter IV. \end{itemize} \item %2 {\bf Bessel equation}\\ This is the Liouville form of the classical Bessel equation. \begin{itemize} \item[(1)] Problems on $(0,1] $ with $y(1) = 0$ \begin{itemize} \item[(i)] $0 \leq \nu < 1 , \; \nu \neq \dfrac{1}{2} $; the Friedrichs case: $A1=1$, $A2 =0$ yields the classical Fourier-Bessel series; $ \lambda_n = j_{\nu,n}^2 $ where $\{ j_{\nu,n}, n : n=0,1,2,...\}$ are the zeros (positive) of the Bessel function $J_{\nu}(x)$. \item[(ii)] $\nu \geq 1$; limit-point at $0$ so unique boundary value problem with $ \lambda_n = j_{\nu,n}^2 $ as before \item[(iii)] these are similar to (i) and (ii) when $\nu < 0$ \end{itemize} \item[(2)] Problems on $[1, \infty );$ continuous spectrum on $[0, \infty )$ \begin{itemize} \item[(i)] for Dirichlet and Neumann b.c. at $1$ there are no eigenvalues. \item[(ii)] for $A1 = A2 = 1$ at $1$ there is one isolated eigenvalue. \end{itemize} \item[(3)] Problems on $(0, \infty);$ continuous spectrum on $[0, \infty)$ \begin{itemize} \item[(i)] no eigenvalues if $\nu \geq 1$ \item[(ii)] for $0 \leq \nu < 1 $ the Friedrichs case is given by $A1=1$, $A2=0$; there are no eigenvalues \item[(iii)] if $A1 = 5, \; A2=1$ there is one isolated eigenvalue near -46.64.\\ \hfill \cite{T}: Chapter IV and \cite{W}: Chapter XVIII. \end{itemize} \end{itemize} \item %3 {\bf The Halvorsen equation} This equation is $R$ at $0$ and LCNO at $+ \infty$ so that the spectrum is discrete and bounded below for all b.c.. However, this example illustrates that even a regular end-point can cause difficulties for computation. The program fails on $R$ at $0$; is successful for $WR$ at $0$; is successful for LCNO at $0$ (use $u(x) = x, \ v(x) = 1$ at $0$; the given $u$ and $v$ at $\infty $ and employ the double limit-circle entry at $0$ and $\infty $ with $c=1$ - see "Help" h4 for more details). At $0$, with $u(x) = x$ and $v(x) =1$, the principal entry is $A1 = 1, \ A2 = 0$; at $\infty $ with $u(x) = 1, \ v(x) = x$ the principal entry is also $A1=1, \; A2=0$ but note the interchange of $u$ and $v$. \item %4 {\bf The Boyd equation} This equation arises in a model studying eddies in the atmosphere; see \cite{B}. There is no explicit formula for the eigenvalues of any particular boundary condition; eigenfunctions can be given in terms of Whittaker functions; see \cite{BEZ}; example 3. \item%5 {\bf The regularized Boyd equation} This is a WR form of equation 4; the singularity at zero has been regularized using quasi-derivatives. There is a close relationship between the examples 4 and 5; in particular they have the same eigenvalues - see \cite{AEZ}. For a general discussion of regularization using non-principal solutions see \cite{NZ}. For numerical results see \cite{BEZ}; example 3. \item %6 {\bf The Sears-Titchmarsh equation} This differential equations has one LP and one LCO end-point. For details of boundary value problems on $[1, \infty )$ see \cite{BEZ}: example 4. The equation was studied originally in \cite{T}; Chapter IV; but see \cite{ST}. For problems on $[1, \infty)$, with separated boundary conditions, the spectrum is simple and discrete but unbounded above and below. Numerical results are given in \cite{BEZ}: example 4. \item %7 {\bf The BEZ equation} This equation is similar to equation 6. On the interval $(0, 1]$ there is a singularity at $0$ in LCO; the equation is R at 1. For numerical results see \cite{BEZ}: example 5. \item %8 {\bf The LaPlace tidal wave equation} This equation is a particular case of the move general equation with this name; for details and references see \cite{H} There are no representations for solutions in terms of the well-known special functions. Thus to determine boundary conditions at the LCNO end-point $0$ use has to be made of maximal domain functions; see the $u, \ v$ section for this equation. Numerical results are given in \cite{BEZ}: example 8. \item %9 {\bf The Latzko equation} This differential equation has a long and celebrated history; see \cite{F}: pages 43 to 45. There is a LCNO singularity at 1 which requires the use of maximal domain functions; see the $u, \ v$ section. The end-point $0$ is WR due to the fact that $w(0) = 0$. This example is similar in some respects to the Legendre equation of example 1. For numerical results see \cite{BEZ}: example 7. \item%10 {\bf A weakly regular equation} This is a devised example to illustrate the computational difficulties of weakly regular problems. The differential equation gives $p(0) = 0$ and $w(0) = \infty $ but nevertheless $0$ is a regular end-point in the Lebesgue integral sense, but has to be classified as weakly regular in the computational sense. The Liouville normal form of this equation is the Fourier equation; see example 21. There are explicit solutions of this equation when $\lambda = 0$ given by $$ cos (2x^{1/2} \surd \lambda ) \ \ ; sin (2x^{1/2} \surd \lambda ) / \surd \lambda . $$ If $0$ is treated as a LCNO end-point then $u, \ v$ boundary condition functions are $$ u(x) = 2x^{1/2} \ \ ; v(x) = 1 . $$ {\bf WR at 0} The regular condition $D \; y(0) = 0 $ is equivalent to the singular condition $[y,u](0) = 0$ {\bf LCNO} \\ Similarly the regular condition $N \; (py')(0) = 0$ is equivalent to the singular condition $ [y, \ v] (0) = 0$. The following indicated boundary value problems have the given explicit formulae for the eigenvalues: $$ y(0) = 0 {\mbox{ or }} [y, \ u] (0) = 0 {\mbox{ and }} y(1) = 0 \; \; \lambda_n = ((n+1) \pi)^2 /4 \ (n=0, 1,... ) $$ $$ (py)'(0) = 0 {\mbox{ or }} [y,v](0) = 0 {\mbox{ and }} (py')(1) = 0 \; \; \lambda_n = ((n+ \dfrac{1}{2} ) \pi ) ^2 /4 \ (n=0,1, ...). $$ \item %11 {\bf The Plum equation} Plum \cite{P} computed the first seven periodic eigenvalues using a numerical homotopy method together with interval arithmetic and obtained rigorous bounds for these seven computed eigenvalues. \item %12 {\bf The Mathieu equation} The classical Mathieu equation has a celebrated history and voluminous literature. There are no eigenvalues for this problem on $(- \infty , + \infty )$. There may be one negative eigenvalue of the problem on $[0, \infty)$ depending on the boundary condition at the end-point $0$. The continuous (essential) spectrum is the same for the whole line or half-line problems and consists of an infinite number of disjoint closed intervals. The endpoints of these - and thus the spectrum of the problem - can be characterized in terms of periodic and semi-periodic eigenvalues of S-L problems on the compact interval $[0, 2 \pi]$. These can be computed with SLEIGN2. These remarks also apply to the general S-L equation with periodic coefficients of the same period; the so-called Hill's equation. Of special interest is the starting point of the continuous spectrum - this is also the oscillation number of the equation. It can be computed with SLEIGN2. For the Mathieu equation ($p=1, \ q=sin(x), w=1$) on both the whole line and the half line it is appr. -0.378. \item %13 {\bf The hydrogen atom equation} This is the classical one-dimensional equation for quantum modelling of the hydrogen atom; see \cite{T}: Chapter IV. For the parameter $L=0$ the equation is LCNO at end-point $0$; the boundary condition $A1=1, \; A2=0$ gives the Friedrichs extension which leads to the classical eigenvalues and eigenfunctions. For $L>0$ the end-point zero is LP. For all these boundary value problems the continuous spectrum is $[0, \infty )$, and there are a countably infinite number of negative eigenvalues with a single cluster point at 0. The eigenvalues for the classical i.e. Friedrichs case are given by $$ \lambda_n = - \dfrac{1}{4(L+n-1)^2} \, , \ n=0,1,2, \ldots $$ \item %14 {\bf The Marletta equation} This equation is R at 0 and LP at $\infty $; there is a continuous spectrum on $[0, \infty )$; there is an isolated negative eigenvalue for some boundary condition at 0. Both codes SLEIGN2 and SLEDGE report a second eigenvalue near 0, this may be due to the fact that there is a solution which is NOT in $L^2 (0, \infty)$ but is "nearly" in this space, thus deceiving these codes; details are in the Marletta certification report on SLEIGN (not SLEIGN2) \cite{M}. \item %15 { \bf The harmonic oscillator equation} This is another classic equation. It is also the Liouville normal form of the differential equation for the Hermite orthogonal polynomials. On the whole real line the boundary value problem requires no boundary conditions at the end-points of $\pm \infty $. Thus there is a unique self-adjoint extension with discrete spectrum given by : $$ \{ \lambda_n = 2n+1 ; \; n=0, 1,2,...\}. $$ For a classical treatment see \cite{T}; Chapter IV, section 2. \item %16 {\bf The Jacobi equation} To obtain the classical orthogonal polynomials use the Friedrichs extension. This is determined by the boundary conditions as follows: \\ Endpoint +1 : $$ -1 < \alpha < 0, \ -1 < \beta, \ WR, \ (py')(1) =0 $$ $$ 0 \le \alpha < 1 : LCNO, \quad \ [y,u](1) = 0 = [y,v](1) =0. $$ $$ 1 \le \alpha : \ LP $$ Endpoint -1 : $$ -1 < \beta < 0, \ -1 < \alpha \ WR, \ (py')(-1) =0 $$ $$ 0 \le \beta < 1 : LCNO, \quad \ [y,u](-1) = 0 = [y,v](-1) =0. $$ $$ 1 \le \beta : \ LP $$ For the classical orthogonal polynomials the eigenvalues are given by : $$ \lambda_n = n(n + \alpha + \beta + 1), \ n = 0,1,2, \ldots $$ \item % 17 {\bf The rotation Morse oscillator equation} This classical problem has continuous spectrum $[0, \inf ]$ and 26 negative eigenvalues. \item %18 {\bf The Dunsch equation} Discussed in chapter VIII, pp. 1510-1520 of \cite{DS}. For $ 0 < \alpha < 1/2 $ , and $0 < \beta < 1/2$ we choose : \\ $$ at -1 : \ u_-(x) = (1 + x)^{\alpha}, \quad v_-(x) = (1+x)^{-\alpha} $$ $$ at +1 : \ u_+(x) = (1 + x)^{\beta }, \quad v_+(x) = (1+x)^{-\beta} $$ Note that these $u$ and $v$ are not solutions but maximal domain functions. D and S state on p.1519 that the boundary value problem determined by $$ [y,u_-](-1) = 0 = [y,u_+](1) $$ has eigenvalues given by : $$ \lambda_n = (n + \alpha + \beta + 1)(n + \alpha + \beta), n = 0, 1, 2, \ldots $$ \item %19 {\bf The Donsch equation} This is a modification of problem 18 which illustrates an LCNO/LCO mix. Replace $\alpha$ in 18 by $ i \gamma$. This changes the singularity at -1 from LCNO to LCO. Take $\gamma > 0$ and $ 0 \le \beta < 1/2 $. $$ At +1 : u(x) = (1-x)^{\beta}, \quad v(x) = (1-x)^{-\beta} $$ $$ At -1 : u(x) = cos(log(1+x)), \quad v(x) = sin(log(1+x)) $$ Again these $u$ and $v$ are not solutions but maximal domain functions. \item %20. { \bf The Krall equation} This example should be seen as a special case of the Bessel equation 2 above. Solutions can be obtained in terms of the modified Bessel functions. To help with the computations for this example the spectrum is translated by a term $+1$; this simple devise is used for convenience. For problems with separated conditions at end-points $0$ and $\infty $ there is a continuous spectrum on $[1, \infty )$ with a discrete (and simple) spectrum on $(- \infty , 1)$. This discrete spectrum has cluster points at $- \infty $ and $1$. With the $u, \; v$ boundary condition function as given, in particular $u(x) = x^{1/2} \; cos (k \ log(x))$, the problem with boundary condition $[y, u](0) = 0$ has eigenvalues given explicitly by: \begin{itemize} \item[(i)] suppose $\Gamma (1+i) = \alpha + i \beta $ and $ \mu > 0$ satisfies $ tan(log (\dfrac{1}{2} \mu )) = - \alpha / \beta $ \item[(ii)] $\theta = im (log ( \Gamma (1+i))) $ \item[(iii)] $log (\dfrac{1}{2} \mu ) = \dfrac{\pi}{2} + \theta + s \pi \; \; s = 0, \pm 1, \pm 2, ... $ \item[(iv)] $- \mu_s^2 = - (2exp (\theta + \dfrac{1}{2} \pi ))^2 \; exp (2s \pi ) \; s=0, \pm 1 , \pm 2 ... $ \end{itemize} then the eigenvalues are $ \lambda_n = - \mu_{-(n+1)}^2 + 1 \ (n\in \Z )$. SLEIGN2 can compute only six of these eigenvalues on our Sun workstation, $\lambda_{-3}$ to $\lambda_2 $; other eigenvalues are, numerically, too close to 1 or too close to $-\infty $. We have $$ \lambda_2 \; \zettleq \; 0.999997 \quad \lambda_{-3} \; \zettleq \; -14,519,130. $$ See \cite{K}. \item % 21 {\bf The Fourier equation} This is a simple constant coefficient equation whose eigenvalues, for any self-adjoint boundary condition, can be characterized in terms of a transcendental equation involving only trigonometric functions. \item % 22 {\bf The Laguerre equation} This is the classical form of the differential equation which for parameter $ \alpha > 1 $ produces the Laguerre polynomials as eigenfunctions; for the appropriate boundary condition at 0, when required, the eigenvalues are then (remarkably!) independent of $ \alpha $ and given by $ \lambda_n = n \; (n=0, 1,2,...)$; see \cite{AS}; Chapter 22, section 22.6. SLEIGN2 fails to compute eigenvalues with this differential equation on $(0, \infty )$ on our Sun workstation; this appears to be due to numerical problems resulting from the exponentially small coefficients; however, see example 23 below. \item %23 {\bf The Laguerre/Liouville equation} This is the Liouville normal form of the Laguerre equation. It seems to be in a form more suitable for eigenvalue computations in contrast to the previous example. The Laguerre polynomials are produced when $ \alpha > -1$. For $\alpha \geq 1$ the LP condition holds at 0. For $0 \leq \alpha < 1$ the appropriate boundary condition is $[y,u] (0) = 0; $ for $ -1 < \alpha < 0 $ use $[y, \ v] (0) = 0$. In all these cases $ \lambda_n = n \; (n=0, 1, 2, ...)$. \item %24 {\bf The Jacobi/Liouville equation} This is the Liouville normal form of the Jacobi equation of example 16. \item%25 {\bf The Meissner equation} This equation arose in a model of a one dimensional crystal. For this constant coefficient equation with a weight function which has a jump discontinuity the eigenvalues can be characterized as roots of a transcendental equation involving only trig. and inverse trig. functions. There are infinitely many simple eigenvalues and infinitely many double ones for the periodic case; they are given by: {\bf Periodic boundary conditions on $(-0.5, 0.5)$.} We have $\lambda_0 = 0$ and $$ \lambda_{4n+1} = ( 2m \pi + \alpha)^2 ; \ \ \lambda_{4n+2} = ( 2(n+1) \pi - \alpha))^2 ; $$ $$ \ \lambda_{4n+3} \ = \ \ \lambda_{4n+4} = ( 2(n+1) \pi ))^2 ; \ n=0,1,2, \ldots $$ where $ \alpha \, = \, cos^{-1}(-7/8) $ {\bf Semi-Periodic eigenvalues} With $ \beta = cos^{-1}( (1 + \sqrt(33))/16)$ and $ \gamma = cos^{-1}( (1 - \sqrt(33))/16)$ these are all simple and given by : $$ \lambda_{4n} \, = \, ( 2n \pi \, + \, \beta)^2 ; \ \lambda_{4n+1} \, = \, ( 2n \pi \, + \, \gamma )^2 ; \ \lambda_{4n+2} \, = \, ( 2(n+1) \pi \, - \, \gamma )^2 ; \ $$ $$ \lambda_{4n+3} \, = \, ( 2(n+1) \pi \, - \, \beta)^2 ; \ n =0, 1, 2, \ldots $$ See \cite{E} and \cite{Hoc}. \end{enumerate} \begin{thebibliography}{999} \bibitem{AS} M.Abramovitz and I.Stegun, {\em Handbook of Mathematical Functions with formulas and graphs and mathematical tables}, Dover Publications Inc., New York, 1965. \bibitem{AEZ} F.V.Atkinson, W.N.Everitt and A.Zettl, {\em Regularization of Sturm-Liouville problem with an interior singularity using quasi-derivatives} Diff. and Int. Equations 1 (1988), 213-222. \bibitem{BEZ} P.B.Bailey, W.N.Everitt and A.Zettl, {\em Computing eigenvalues of singular Sturm-Liouville problems}, Results in Mathematics, v.20(1991), 391-423. \bibitem{B} J.P.Boyd, {\em Sturm-Liouville eigenvalue problems with an interior pole}, J.Math. Physics, 22(1981), 1575-1590. \bibitem{DS} N.Dunford and J.T.Schwartz, {\em Linear Operators, part II}, Interscience Publishers, New York, 1963. \bibitem{E} M.S.P. Eastham, {\em The spectral theory of periodic differential equations}, Scottish Academic Press, Edinburgh and London, 1973. \bibitem{EGZ} W.N.Everitt, J.Gunson and A.Zettl, {\em Some comments on Sturm-Liouville eigenvalue problems with interior singularities}, J. Appl. Math. Phys. (ZAMP) 38 (1987), 813-838. \bibitem{F} G.Fichera, {\em Numerical and quantitative analysis}, Pitman Press, London, 1978. \bibitem{H} M.S.Homer, {\em Boundary value problems for the La Place tidal wave equation}, Proc. Roy. Soc. of London (A) 428 (1990), 157-180. \bibitem{Hoc} H.Hochstadt, {\em A special Hill's equation with discontinuous coefficients}, Amer. Math. Monthly, 70(1963), 18-26. \bibitem{K} A.M.Krall, {\em Boundary value problems for an eigenvalue problem with a singular potential}, J. Diff. Equations, 45 (1982), 128-138. \bibitem{M} M.Marletta, {\em Numerical tests of the SLEIGN software for Sturm-Liouville problems}, ACM TOMS, v17(1991), 501-503. \bibitem{NZ} H.-D.Niessen and A.Zettl, {\em Singular Sturm-Liouville problems; the Friedrichs extension and comparison of eigenvalues}, Proc. London Math. Soc. 64 (1992), 545-578. \bibitem{P} M.Plum, {\em Eigenvalue inclusions for second-order ordinary differential operators by a numerical homotopy method}, ZAMP, v41(1990), 205-226. \bibitem{ST} D.B.Sears and E.C.Titchmarsh, {\em Some eigenfunction formulae}, Quart. J. Math. Oxford (2) 1 (1950), 165-175. \bibitem{T} E.C. Tichmarsh, {\em Eigenfunction expansions associated with second order differential equations}, v. I, Clarendon Press, Oxford; 1962. \bibitem{W} G.N.Watson, {\em A treatise on the theory of Bessel functions}, Cambridge University Press, Cambridge, England, 1958. \end{thebibliography} \end{document} SHAR_EOF fi # end of overwriting check if test -f 'xamplesd.f' then echo shar: will not over-write existing file "'xamplesd.f'" else cat << SHAR_EOF > 'xamplesd.f' C OCTOBER 15, 1995; P.B. BAILEY, W.N. EVERITT, B. GARBOW AND A. ZETTL C SUBROUTINE EXAMP() CHARACTER ANS INTEGER MUMBER,NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA C C THIS SUBROUTINE CONTAINS A SELECTION OF COEFFICIENT FUNCTIONS C p,q,w (AND POSSIBLY SUITABLE FUNCTIONS u,v TO DETERMINE SINGULAR C B.C.) WHICH DEFINE SOME INTERESTING STURM-LIOUVILLE BOUNDARY C VALUE PROBLEMS. IT CAN BE CALLED BY THE MAIN PROGRAM, DRIVE. C WRITE(*,*) ' Here is a collection of 29 differential equations ' WRITE(*,*) ' which can be used with SLEIGN2. By typing an ' WRITE(*,*) ' integer from 1 to 29, one of these differential ' WRITE(*,*) ' equations is selected, whereupon its coefficient ' WRITE(*,*) ' functions p,q,w will be displayed along with a ' WRITE(*,*) ' brief description of its singular points. The' WRITE(*,*) ' endpoints a, b of the interval over which the ' WRITE(*,*) ' differential equation is integrated are specified ' WRITE(*,*) ' later; any interval which does not contain ' WRITE(*,*) ' singular points in its interior is acceptable. ' WRITE(*,*) WRITE(*,*) ' DO YOU WISH TO CONTINUE ? (Y/N) ' READ(*,9010) ANS IF (.NOT.(ANS.EQ.'y' .OR. ANS.EQ.'Y')) STOP 30 CONTINUE WRITE(*,*) WRITE(*,*) ' 1 IS THE LEGENDRE EQUATION ' WRITE(*,*) ' 2 IS THE BESSEL EQUATION ' WRITE(*,*) ' 3 IS THE HALVORSEN EQUATION ' WRITE(*,*) ' 4 IS THE BOYD EQUATION ' WRITE(*,*) ' 5 IS THE REGULARIZED BOYD EQUATION ' WRITE(*,*) ' 6 IS THE SEARS-TITCHMARSH EQUATION ' WRITE(*,*) ' 7 IS THE BEZ EQUATION ' WRITE(*,*) ' 8 IS THE LAPLACE TIDAL WAVE EQUATION ' WRITE(*,*) ' 9 IS THE LATZKO EQUATION ' WRITE(*,*) ' 10 IS A WEAKLY REGULAR EQUATION ' WRITE(*,*) ' 11 IS THE PLUM EQUATION ' WRITE(*,*) ' 12 IS THE MATHIEU PERIODIC EQUATION ' WRITE(*,*) ' 13 IS THE HYDROGEN ATOM EQUATION ' WRITE(*,*) ' 14 IS THE MARLETTA EQUATION ' WRITE(*,*) ' 15 IS THE HARMONIC OSCILLATOR EQUATION ' WRITE(*,*) WRITE(*,*) ' Press any key to continue. ' READ(*,9010) ANS 9010 FORMAT(A1) WRITE(*,*) ' 16 IS THE JACOBI EQUATION ' WRITE(*,*) ' 17 IS THE ROTATION MORSE OSCILLATOR EQUATION ' WRITE(*,*) ' 18 IS THE DUNSCH EQUATION ' WRITE(*,*) ' 19 IS THE DONSCH EQUATION ' WRITE(*,*) ' 20 IS THE KRALL EQUATION ' WRITE(*,*) ' 21 IS THE FOURIER EQUATION ' WRITE(*,*) ' 22 IS THE LAGUERRE EQUATION ' WRITE(*,*) ' 23 IS THE LAGUERRE/LIOUVILLE FORM EQUATION ' WRITE(*,*) ' 24 IS THE JACOBI/LIOUVILLE FORM EQUATION ' WRITE(*,*) ' 25 IS THE MEISSNER EQUATION ' WRITE(*,*) ' 26 IS THE LOHNER EQUATION ' WRITE(*,*) ' 27 IS THE JOERGENS EQUATION ' WRITE(*,*) ' 28 IS THE BEHNKE-GOERISCH EQUATION ' WRITE(*,*) ' 29 IS THE WHITTAKER EQUATION ' WRITE(*,*) WRITE(*,*) ' ENTER THE NUMBER OF YOUR CHOICE: ' READ(*,*) NUMBER IF (NUMBER.LT.1 .OR. NUMBER.GT.29) GO TO 30 MUMBER = NUMBER GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = 1/4, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT -1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +1. ' GO TO 40 C 2 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = (nu*nu-0.25)/x*x, w = 1 ' WRITE(*,*) ' (nu a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL nu AT + INFINITY' WRITE(*,*) ' AT 0: LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.nu.LT.1 BUT nu*nu.NE.0.25. ' WRITE(*,*) ' REGULAR FOR nu*nu = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR nu*nu.GE.1.0. ' MUMBER = 101 GO TO 40 C 3 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0, w = exp(-2/x)/x**4 ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +INFINITY. ' GO TO 40 C 4 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = -1/x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 5 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = r*r, q = -r*r*(ln|x|)**2, w = r*r ' WRITE(*,*) ' where r = exp(-(x*ln(|x|)-x)) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' WEAKLY REGULAR AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 6 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x, q = -x, w = 1/x ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT +INFINITY. ' GO TO 40 C 7 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity,0) ' WRITE(*,*) ' AND on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x, q = -1/x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT 0+ AND 0-. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 8 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1/x, q = (k/x**2) + (k**2/x), w = 1 ' WRITE(*,*) ' (k a non-zero parameter) ' WRITE(*,*) WRITE(*,*) 'AT 0: LIMIT CIRCLE, NON-OSCILLATORY FOR ALL k. ' WRITE(*,*) 'AT +INFINITY: LIMIT POINT AT FOR ALL k. ' MUMBER = 102 GO TO 40 C 9 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x**7, q = 0, w = x**7 ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY AT +1. ' GO TO 40 C 10 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = sqrt(x), q = 0, w = 1/sqrt(x) ' WRITE(*,*) WRITE(*,*) ' WEAKLY REGULAR AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 11 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 100*cos(x)**2, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 12 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 2*k*cos(2x), w = 1 ' WRITE(*,*) ' (k a non-zero parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 103 GO TO 40 C 13 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = k/x + h/x**2, w = 1 ' WRITE(*,*) ' q = k/x + h/x**2 + 1 if h.lt.-0.25 ' WRITE(*,*) ' (h,k parameters) ' WRITE(*,*) WRITE(*,*) 'LIMIT POINT FOR ALL h,k AT +INFINITY ' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' REGULAR for h = k = 0. ' WRITE(*,*) ' LIMIT-CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR h = 0 AND ALL k.NE.0. ' WRITE(*,*) ' LIMIT-CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -0.25.LE.h.LT.0.75 BUT h.NE.0, AND ALL k. ' WRITE(*,*) ' LIMIT-CIRCLE, OSCILLATORY ' WRITE(*,*) ' FOR h.LT.-0.25 AND ALL k. ' WRITE(*,*) ' (Here, 1 has been added to q so that ' WRITE(*,*) ' at least some eigenvalues are positive.) ' WRITE(*,*) ' LIMIT POINT FOR h.GE.0.75 AND ALL k. ' MUMBER = 104 GO TO 40 C 14 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 3.0*(X-31.0)/(4.0*(X+1.0)*(4.0+X)**2), ' WRITE(*,*) ' w = 1 ' WRITE(*,*) WRITE(*,*) ' REGULAR AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 15 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = x*x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 16 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = (1-x)**(alpha+1)*(1+x)**(beta+1), ' WRITE(*,*) ' q = 0, w = (1-x)**alpha*(1+x)**beta ' WRITE(*,*) ' (alpha, beta parameters) ' WRITE(*,*) WRITE(*,*) ' AT -1.0: ' WRITE(*,*) ' LIMIT POINT FOR beta.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.beta.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.1. ' WRITE(*,*) ' AT +1.0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.alpha.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 105 GO TO 40 C 17 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 2/x**2 - 2000(2e-e*e), w = 1 ' WRITE(*,*) ' where e = exp(-1.7(x-1.3)) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 18 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = 2*alpha**2/(1+x) + 2*beta**2/(1-x),' WRITE(*,*) ' w = 1 (alpha, beta non-negative parameters) ' WRITE(*,*) WRITE(*,*) 'AT -1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.0.5. ' WRITE(*,*) 'AT +1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.0.5. ' MUMBER = 106 GO TO 40 C 19 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-1,1) ' WRITE(*,*) WRITE(*,*) ' p = 1 - x*x, q = -2*gamma**2/(1+x) +2*beta**2/(1-x),' WRITE(*,*) ' w = 1 (gamma, beta parameters) ' WRITE(*,*) WRITE(*,*) 'AT -1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY FOR gamma = 0.' WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY FOR gamma.GT.0. ' WRITE(*,*) 'AT +1.0: ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.beta.LT.0.5. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.0.5. ' MUMBER = 107 GO TO 40 C 20 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 1 - (k**2+0.25)/x**2, w = 1 ' WRITE(*,*) ' (k a positive parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT CIRCLE, OSCILLATORY AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 108 GO TO 40 C 21 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 22 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = x**(alpha+1)*exp(-x), w = x**alpha*exp(-x) ' WRITE(*,*) ' q = 0 (alpha a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL alpha AT +INFINITY' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' WEAKLY REGULAR FOR -1.LT.alpha.LT.0. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR 0.LE.alpha.LT.1. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 109 GO TO 40 C 23 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, w = 1 ' WRITE(*,*) ' q = (alpha**2-0.25)/x**2 - (alpha+1)/2 + x**2/16' WRITE(*,*) ' (alpha a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT FOR ALL alpha AT +INFINITY' WRITE(*,*) 'AT 0: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.alpha.LT.1 BUT alpha**2.NE.0.25. ' WRITE(*,*) ' REGULAR FOR alpha**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 110 GO TO 40 C 24 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-pi/2,pi/2) ' WRITE(*,*) WRITE(*,*) ' p = 1, w = 1 ' WRITE(*,*) ' q = (beta**2-0.25)/(4*tan((x+pi/2)/2)**2)+ ' WRITE(*,*) ' (alpha**2-0.25)/(4*tan((x-pi/2)/2)**2)- ' WRITE(*,*) ' (4*alpha*beta+4*alpha+4*beta+3)/8 ' WRITE(*,*) ' (alpha, beta parameters) ' WRITE(*,*) WRITE(*,*) 'AT -pi/2: ' WRITE(*,*) ' LIMIT POINT FOR beta.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.beta.LT.1 BUT beta**2.NE.0.25.' WRITE(*,*) ' REGULAR FOR beta**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR beta.GE.1. ' WRITE(*,*) 'AT +pi/2: ' WRITE(*,*) ' LIMIT POINT FOR alpha.LE.-1. ' WRITE(*,*) ' LIMIT CIRCLE, NON-OSCILLATORY ' WRITE(*,*) ' FOR -1.LT.alpha.LT.1 BUT alpha**2.NE.0.25.' WRITE(*,*) ' REGULAR FOR alpha**2 = 0.25. ' WRITE(*,*) ' LIMIT POINT FOR alpha.GE.1. ' MUMBER = 111 GO TO 40 C 25 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0 ' WRITE(*,*) ' w = 1 when x.le.0. ' WRITE(*,*) ' = 9 when x.gt.0. ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 26 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = -1000*x, w = 1 ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' GO TO 40 C 27 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0.25*exp(2*x) - k*exp(x), w = 1 ' WRITE(*,*) ' (k a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 112 GO TO 40 C 28 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (-infinity, ' WRITE(*,*) ' +infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = k*cos(x)**2, w = 1 ' WRITE(*,*) ' (k a parameter) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT -INFINITY. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 113 GO TO 40 C 29 CONTINUE WRITE(*,*) ' -(p*y'')'' + q*y = lambda*w*y on (0,+infinity) ' WRITE(*,*) WRITE(*,*) ' p = 1, q = 0.25 + (k**2-1)/(4*x**2)), w = 1/x ' WRITE(*,*) ' (k a positive parameter .GE. 1) ' WRITE(*,*) WRITE(*,*) ' LIMIT POINT AT 0. ' WRITE(*,*) ' LIMIT POINT AT +INFINITY. ' MUMBER = 114 GO TO 40 C 40 CONTINUE WRITE(*,*) WRITE(*,*) ' IS THIS THE CORRECT DIFFERENTIAL EQUATION ? (Y/N) ' READ(*,9010) ANS IF (.NOT.(ANS.EQ.'y' .OR. ANS.EQ.'Y')) GO TO 30 IF (MUMBER.EQ.NUMBER) RETURN C C Now enter any parameters needed for these D.E.'s, or defaults. C MUMBER = MUMBER - 100 GO TO (41,42,43,44,45,46,47,48,49,50,51,52,53,54), MUMBER C 41 CONTINUE NU = 1.0 WRITE(*,*) ' Choose real parameter nu, nu = ' READ(*,*) NU RETURN C 42 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k.ne.0., k = ' READ(*,*) K RETURN C 43 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 44 CONTINUE H = 1.0 K = 1.0 WRITE(*,*) ' Choose real parameters h,k = ' READ(*,*) H,K RETURN C 45 CONTINUE BETA = 0.1 ALPHA = 0.1 WRITE(*,*) ' Choose real parameters beta,alpha = ' READ(*,*) BETA,ALPHA RETURN C 46 CONTINUE ALPHA = 0.1 BETA = 0.1 WRITE(*,*) ' Choose real parameters alpha,beta = ' READ(*,*) ALPHA,BETA RETURN C 47 CONTINUE GAMMA = 0.1 BETA = 0.1 WRITE(*,*) ' Choose real parameters gamma,beta = ' READ(*,*) GAMMA,BETA RETURN C 48 CONTINUE K = 1.0 WRITE(*,*) ' Choose real parameter k.gt.0., k = ' READ(*,*) K RETURN C 49 CONTINUE ALPHA = 0.1 WRITE(*,*) ' Choose real parameter alpha = ' READ(*,*) ALPHA RETURN C 50 CONTINUE ALPHA = 0.1 WRITE(*,*) ' Choose real parameter alpha = ' READ(*,*) ALPHA RETURN C 51 CONTINUE BETA = 0.1 ALPHA = 0.1 WRITE(*,*) ' Choose real parameters beta,alpha = ' READ(*,*) BETA,ALPHA RETURN C 52 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 53 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN C 54 CONTINUE K = 0.1 WRITE(*,*) ' Choose real parameter k = ' READ(*,*) K RETURN END C DOUBLE PRECISION FUNCTION P(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE P = 1.0 - X*X RETURN C 2 CONTINUE P = 1.0 RETURN C 3 CONTINUE P = 1.0 RETURN C 4 CONTINUE P = 1.0 RETURN C 5 CONTINUE P = EXP(-2.0*(X*LOG(ABS(X))-X)) RETURN C 6 CONTINUE P = X RETURN C 7 CONTINUE P = X RETURN C 8 CONTINUE P = 1.0/X RETURN C 9 CONTINUE P = 1.0 - X**7 RETURN C 10 CONTINUE P = SQRT(X) RETURN C 11 CONTINUE P = 1.0 RETURN C 12 CONTINUE P = 1.0 RETURN C 13 CONTINUE P = 1.0 RETURN C 14 CONTINUE P = 1.0 RETURN C 15 CONTINUE P = 1.0 RETURN C 16 CONTINUE IF (ALPHA.NE.-1.0 .AND. BETA.NE.-1.0) THEN P = (1.0-X)**(ALPHA+1.0)*(1.0+X)**(BETA+1.0) ELSE IF (ALPHA.NE.-1.0 .AND. BETA.EQ.-1.0) THEN P = (1.0-X)**(ALPHA+1.0) ELSE IF (ALPHA.EQ.-1.0 .AND. BETA.NE.-1.0) THEN P = (1.0+X)**(BETA+1.0) ELSE P = 1.0 END IF RETURN C 17 CONTINUE P = 1.0 RETURN C 18 CONTINUE P = 1.0 - X*X RETURN C 19 CONTINUE P = 1.0 - X*X RETURN C 20 CONTINUE P = 1.0 RETURN C 21 CONTINUE P = 1.0 RETURN C 22 CONTINUE P = EXP(-X) IF (ALPHA.NE.-1.0) P = P*X**(ALPHA+1.0) RETURN C 23 CONTINUE P = 1.0 RETURN C 24 CONTINUE P = 1.0 RETURN C 25 CONTINUE P = 1.0 RETURN C 26 CONTINUE P = 1.0 RETURN C 27 CONTINUE P = 1.0 RETURN C 28 CONTINUE P = 1.0 RETURN C 29 CONTINUE P = 1.0 RETURN END C DOUBLE PRECISION FUNCTION Q(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA,E,HPI COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA c GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE Q = 0.25 RETURN C 2 CONTINUE Q = 0.0 IF (NU.NE.-0.5 .AND. NU.NE.0.5) Q = (NU*NU-0.25)/X**2 RETURN C 3 CONTINUE Q = 0.0 RETURN C 4 CONTINUE Q = -1.0/X RETURN C 5 CONTINUE Q = -EXP(-2.0*(X*LOG(ABS(X))-X))*LOG(ABS(X))**2 RETURN C 6 CONTINUE Q = -X RETURN C 7 CONTINUE Q = -1.0/X RETURN C 8 CONTINUE Q = K/X**2 + K**2/X RETURN C 9 CONTINUE Q = 0.0 RETURN C 10 CONTINUE Q = 0.0 RETURN C 11 CONTINUE Q = 100.0*COS(X)**2 RETURN C 12 CONTINUE Q = 2.0*K*COS(2.0*X) RETURN C 13 CONTINUE Q = K/X + H/(X*X) IF (H .LT. -0.25) Q = Q + 1.0 RETURN C 14 CONTINUE Q = 3.0*(X-31.0)/(4.0*(X+1.0)*(X+4.0)**2) RETURN C 15 CONTINUE Q = X*X RETURN C 16 CONTINUE Q = 0.0 RETURN C 17 CONTINUE L = 1.0 E = EXP(-1.7*(X-1.3)) Q = L*(L+1.0)/X**2 - 2000.0*E*(2.0-E) RETURN C 18 CONTINUE IF (ALPHA.NE.0.0 .AND. BETA.NE.0.0) THEN Q = 2.0*ALPHA**2/(1.0+X) + 2.0*BETA**2/(1.0-X) ELSE IF (ALPHA.EQ.0.0 .AND. BETA.NE.0.0) THEN Q = 2.0*BETA**2/(1.0-X) ELSE IF (ALPHA.NE.0.0 .AND. BETA.EQ.0.0) THEN Q = 2.0*ALPHA**2/(1.0+X) ELSE Q = 0.0 END IF RETURN C 19 CONTINUE Q = -2.0*GAMMA**2/(1.0+X) + 2.0*BETA**2/(1.0-X) RETURN C 20 CONTINUE Q = 1.0 - (K**2+0.25)/X**2 RETURN C 21 CONTINUE Q = 0.0 RETURN C 22 CONTINUE Q = 0.0 RETURN C 23 CONTINUE Q = -(ALPHA+1.0)/2.0 + X**2/16.0 IF (ALPHA.NE.0.5 .AND. ALPHA.NE.-0.5) Q = Q + (ALPHA**2-0.25)/X**2 RETURN C 24 CONTINUE HPI = 2.0*ATAN(1.0) IF (BETA*BETA.NE.0.25 .AND. ALPHA*ALPHA.NE.0.25) THEN Q = (BETA**2-0.25)/(4.0*TAN((X+HPI)/2.0)**2) + 1 (ALPHA**2-0.25)/(4.0*TAN((X-HPI)/2.0)**2) - 2 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE IF (BETA*BETA.EQ.0.25 .AND. ALPHA*ALPHA.NE.0.25) THEN Q = (ALPHA**2-0.25)/(4.0*TAN((X-HPI)/2.0)**2) - 1 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE IF (BETA*BETA.NE.0.25 .AND. ALPHA*ALPHA.EQ.0.25) THEN Q = (BETA**2-0.25)/(4.0*TAN((X+HPI)/2.0)**2) - 1 (ALPHA*BETA+ALPHA+BETA+0.75)/2.0 ELSE Q = -(ALPHA*BETA+ALPHA+BETA+0.75)/2.0 END IF RETURN C 25 CONTINUE Q = 0.0 RETURN C 26 CONTINUE Q = -1000.0*X RETURN C 27 CONTINUE E = EXP(X) Q = E*(0.25*E-K) RETURN C 28 CONTINUE Q = K*COS(X)**2 RETURN C 29 CONTINUE Q = 0.25 + (K**K-1.0)/(4.0*X**2) RETURN END C DOUBLE PRECISION FUNCTION W(X) DOUBLE PRECISION X INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE W = 1.0 RETURN C 2 CONTINUE W = 1.0 RETURN C 3 CONTINUE W = 0.0 IF (X.NE.0.0) W = EXP(-2.0/X)/X**4 RETURN C 4 CONTINUE W = 1.0 RETURN C 5 CONTINUE W = EXP(-2.0*(X*LOG(ABS(X))-X)) RETURN C 6 CONTINUE W = 1.0/X RETURN C 7 CONTINUE W = 1.0 RETURN C 8 CONTINUE W = 1.0 RETURN C 9 CONTINUE W = X**7 RETURN C 10 CONTINUE W = 1.0/SQRT(X) RETURN C 11 CONTINUE W = 1.0 RETURN C 12 CONTINUE W = 1.0 RETURN C 13 CONTINUE W = 1.0 RETURN C 14 CONTINUE W = 1.0 RETURN C 15 CONTINUE W = 1.0 RETURN C 16 CONTINUE IF (ALPHA.NE.0.0 .AND. BETA.NE.0.0) THEN W = (1.0-X)**ALPHA*(1.0+X)**BETA ELSE IF (ALPHA.NE.0.0 .AND. BETA.EQ.0.0) THEN W = (1.0-X)**ALPHA ELSE IF (ALPHA.EQ.0.0 .AND. BETA.NE.0.0) THEN W = (1.0+X)**BETA ELSE W = 1.0 END IF RETURN C 17 CONTINUE W = 1.0 RETURN C 18 CONTINUE W = 1.0 RETURN C 19 CONTINUE W = 1.0 RETURN C 20 CONTINUE W = 1.0 RETURN C 21 CONTINUE W = 1.0 RETURN C 22 CONTINUE W = EXP(-X) IF (ALPHA.NE.0.0) W = W*(X**ALPHA) RETURN C 23 CONTINUE W = 1.0 RETURN C 24 CONTINUE W = 1.0 RETURN C 25 CONTINUE W = 9.0 IF (X.LE.0.0) W = 1.0 RETURN C 26 CONTINUE W = 1.0 RETURN C 27 CONTINUE W = 1.0 RETURN C 28 CONTINUE W = 1.0 RETURN C 29 CONTINUE W = 1.0/X RETURN END C SUBROUTINE UV(X,U,PUP,V,PVP,HU,HV) DOUBLE PRECISION X,U,PUP,V,PVP,HU,HV INTEGER NUMBER DOUBLE PRECISION NU,H,K,L,ALPHA,BETA,GAMMA,E,TX,HPI,L2,SQ,C,S COMMON /FLAG/NUMBER COMMON /PAR/NU,H,K,L,ALPHA,BETA,GAMMA DOUBLE PRECISION Q EXTERNAL Q C C HERE, HU MEANS -(pu')' + qu. C GO TO (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15, 1 16,17,18,19,20,21,22,23,24,25,26,27,28,29), NUMBER C 1 CONTINUE U = 1.0 PUP = 0.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PVP = 1.0 HU = 0.25*U HV = 0.25*V RETURN C 2 CONTINUE IF (NU.NE.-0.5 .AND. NU.NE.0.5 .AND. NU.NE.0.0) THEN U = X**(NU+0.5) PUP = (NU+0.5)*X**(NU-0.5) V = X**(-NU+0.5) PVP = (-NU+0.5)*X**(-NU-0.5) ELSE IF (NU.EQ.-0.5) THEN U = X PUP = 1.0 V = 1.0 PVP = 0.0 ELSE IF (NU.EQ.0.5) THEN U = X PUP = 1.0 V = -1.0 PVP = 0.0 ELSE IF (NU.EQ.0.0) THEN U = SQRT(X) PUP = 0.5/U V = U*LOG(X) PVP = (0.5*LOG(X)+1.0)/U END IF HU = 0.0 HV = 0.0 RETURN C 3 CONTINUE U = 1.0 V = X PUP = 0.0 PVP = 1.0 HU = 0.0 HV = 0.0 RETURN C 4 CONTINUE TX = LOG(ABS(X)) U = X PUP = 1.0 V = 1.0 - X*TX PVP = -1.0 - TX HU = -1.0 HV = TX RETURN C 5 CONTINUE RETURN C 6 CONTINUE U = (COS(X)+SIN(X))/SQRT(X) V = (COS(X)-SIN(X))/SQRT(X) PUP = -0.5*U + X*V PVP = -0.5*V - X*U HU = -0.25*U/X HV = -0.25*V/X RETURN C 7 CONTINUE TX = LOG(ABS(X)) U = COS(TX) V = SIN(TX) PUP = -V PVP = U HU = 0.0 HV = 0.0 RETURN C 8 CONTINUE V = X - 1.0/K U = X*X PVP = 1.0/X PUP = 2.0 HU = K + X*K**2 HV = K**2 RETURN C 9 CONTINUE U = 1.0 V = -LOG(1.0-X) PUP = 0.0 PVP = (((((X+1.0)*X+1.0)*X+1.0)*X+1.0)*X+1.0)*X+1.0 HU = 0.0 HV = -(((((6.0*X+5.0)*X+4.0)*X+3.0)*X+2.0)*X+1.0) RETURN C 10 CONTINUE U = 2.0*SQRT(X) V = 1.0 PUP = 1.0 PVP = 0.0 HU = 0.0 HV = 0.0 RETURN C 11 CONTINUE RETURN C 12 CONTINUE RETURN C 13 CONTINUE IF (H .GT. -0.25) THEN L = SQRT(H+0.25) IF (H.EQ.0.0) THEN U = X V = 1.0 + K*X*LOG(X) PUP = 1.0 PVP = K*(1.0+LOG(X)) HU = K HV = K*K*LOG(X) ELSE U = X**(0.5+L) V = X**(0.5-L) + (K/(1.0-2.0*L))*X**(1.5-L) PUP = (0.5+L)*X**(L-0.5) PVP = (0.5-L)*X**(-L-0.5) + K*(1.5-L)/(1.0-2.0*L)*X**(0.5-L) HU = K*X**(L-0.5) HV = K**2/(1.0-2.0*L)*X**(0.5-L) END IF ELSE IF (H .LT. -0.25) THEN L2 = -(H+0.25) L = SQRT(L2) C = COS(L*LOG(X)) S = SIN(L*LOG(X)) SQ = SQRT(X) U = SQ*((1.-0.25*K*X/H)*C + 0.5*K*L*X*S) V = SQ*((1.-0.25*K*X/H)*S + 0.5*K*L*X*C) PUP = (0.5*C - L*S)/SQ - 0.5*K*SQ*((0.5-H)*C + L*S)/H PVP = (0.5*S + L*C)/SQ + 0.5*K*SQ*((H-0.5)*S + L*C)/H HU = 0.5*K*K*SQ*((H+0.5)*C + L*S)/(H*H) + U HV = 0.5*K*K*SQ*((H+0.5)*S - L*C)/(H*H) + V ELSE IF (H .EQ. -0.25) THEN SQ = SQRT(X) U = SQ + K*X*SQ V = 2.0*SQ + (SQ + K*X*SQ)*LOG(X) PUP = 0.5*(1.0/SQ + 3.*K*SQ) PVP = 2.0/SQ + K*SQ + 0.5*(1.0/SQ + 3.0*K*SQ)*LOG(X) HU = K*K*SQ HV = K*K*SQ*LOG(X) ENDIF RETURN C 14 CONTINUE RETURN C 15 CONTINUE RETURN C 16 CONTINUE IF (X.LT.0.0) THEN IF (BETA.GT.-1.0 .AND. BETA.LT.0.0) THEN U = (1.0+X)**(-BETA) V = 1.0 IF (ALPHA.NE.-1.0) THEN PUP = -BETA*(1.0-X)**(ALPHA+1.0) HU = -BETA*(ALPHA+1.0)*(1.0-X)**ALPHA ELSE PUP = -BETA HU = 0.0 END IF PVP = 0.0 HV = 0.0 ELSE IF (BETA.EQ.0.0) THEN U = 1.0 V = LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 2.0*(1.0-X)**ALPHA HU = 0.0 HV = 2.0*ALPHA*(1.0-X)**(ALPHA-1.0) ELSE IF (BETA.GT.0.0 .AND. BETA.LT.1.0) THEN U = 1.0 V = (1.0+X)**(-BETA) PUP = 0.0 IF (ALPHA.NE.-1.0) THEN PVP = -BETA*(1.0-X)**(ALPHA+1.0) HV = -BETA*(ALPHA+1.0)*(1.0-X)**ALPHA ELSE PVP = -BETA HV = 0.0 END IF HU = 0.0 END IF ELSE IF (X.GE.0.0) THEN IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = (1.0-X)**(-ALPHA) V = 1.0 IF (BETA.NE.-1.0) THEN PUP = ALPHA*(1.0+X)**(BETA+1.0) HU = -ALPHA*(BETA+1.0)*(1.0+X)**BETA ELSE PUP = ALPHA HU = 0.0 END IF PVP = 0.0 HV = 0.0 ELSE IF (ALPHA.EQ.0.0) THEN U = 1.0 V = LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 2.0*(1.0+X)**BETA HU = 0.0 HV = -2.0*BETA*(1.0+X)**(BETA-1.0) ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = 1.0 V = (1.0-X)**(-ALPHA) PUP = 0.0 HU = 0.0 IF (BETA.NE.-1.0) THEN PVP = ALPHA*(1.0+X)**(BETA+1.0) HV = -ALPHA*(BETA+1.0)*(1.0+X)**BETA ELSE PVP = ALPHA HV = 0.0 END IF END IF END IF RETURN C 17 CONTINUE RETURN C 18 CONTINUE IF (X.LT.0.0) THEN IF (ALPHA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X) HV = Q(X)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.0.5) THEN U = (1.0+X)**ALPHA V = (1.0+X)**(-ALPHA) PUP = ALPHA*(1.0-X)*U PVP = -ALPHA*(1.0-X)*V HU = ALPHA*(ALPHA+1.0)*U + 2.0*BETA**2*U/(1.0-X) HV = ALPHA*(ALPHA-1.0)*V + 2.0*BETA**2*V/(1.0-X) ELSE END IF ELSE IF (X.GE.0.0) THEN IF (BETA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X) HV = Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.0.5) THEN U = (1.0-X)**BETA V = (1.0-X)**(-BETA) PUP = -BETA*(1.0+X)*U PVP = BETA*(1.0+X)*V HU = BETA*(BETA+1.0)*U + 2.0*ALPHA**2*U/(1.0+X) HV = BETA*(BETA-1.0)*V + 2.0*ALPHA**2*V/(1.0+X) ELSE END IF END IF RETURN C 19 CONTINUE IF (X.LT.0.0) THEN IF (GAMMA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X)*U HV = Q(X)*V ELSE U = COS(GAMMA*LOG(1.0+X)) V = SIN(GAMMA*LOG(1.0+X)) PUP = -GAMMA*(1.0-X)*V PVP = GAMMA*(1.0-X)*U HU = -GAMMA**2*U - GAMMA*V + 2.0*BETA**2*U/(1.0-X) HV = -GAMMA**2*V + GAMMA*U + 2.0*BETA**2*V/(1.0-X) END IF ELSE IF (X.GE.0.0) THEN IF (BETA.EQ.0.0) THEN U = 1.0 V = 0.5*LOG((1.0+X)/(1.0-X)) PUP = 0.0 PVP = 1.0 HU = Q(X)*U HV = Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.0.5) THEN U = (1.0-X)**BETA V = (1.0-X)**(-BETA) PUP = -BETA*(1.0+X)*U PVP = BETA*(1.0+X)*V HU = BETA*(BETA+1.0)*U - 2.0*GAMMA**2*U/(1.0+X) HV = BETA*(BETA-1.0)*V - 2.0*GAMMA**2*V/(1.0+X) ELSE END IF END IF RETURN C 20 CONTINUE U = SQRT(X)*COS(K*LOG(X)) V = SQRT(X)*SIN(K*LOG(X)) PUP = 0.5*U/X - K*V/X PVP = 0.5*V/X + K*U/X HU = U HV = V RETURN C 21 CONTINUE RETURN C 22 CONTINUE E = EXP(-X) IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = X**(-ALPHA) V = 1.0 PUP = -ALPHA*E PVP = 0.0 HU = -ALPHA*E HV = 0.0 ELSE IF (ALPHA.EQ.0.0) THEN U = 1.0 V = LOG(X) PUP = 0.0 PVP = E HU = 0.0 HV = E ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = 1.0 V = X**(-ALPHA) PUP = 0.0 PVP = -ALPHA*E HU = 0.0 HV = -ALPHA*E ELSE END IF RETURN C 23 CONTINUE IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN IF (ALPHA.NE.-0.5) THEN U = X**(0.5-ALPHA) V = X**(0.5+ALPHA) PUP = (0.5-ALPHA)*X**(-0.5-ALPHA) PVP = (0.5+ALPHA)*X**(-0.5+ALPHA) ELSE U = X V = 1.0 PUP = 1.0 PVP = 0.0 END IF TX = X**2/16.0-(ALPHA+1.0)/2.0 HU = TX*U HV = TX*V ELSE IF (ALPHA.EQ.0.0) THEN U = SQRT(X) V = U*LOG(X) PUP = 0.5/U PVP = (1.0+0.5*LOG(X))/U HU = (X**2/16.0-0.5)*U HV = (X**2/16.0-0.5)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN IF (ALPHA.NE.0.5) THEN U = X**(0.5+ALPHA) V = X**(0.5-ALPHA) PUP = (0.5+ALPHA)*X**(-0.5+ALPHA) PVP = (0.5-ALPHA)*X**(-0.5-ALPHA) ELSE U = X V = 1.0 PUP = 1.0 PVP = 0.0 END IF TX = X**2/16.0-(ALPHA+1.0)/2.0 HU = TX*U HV = TX*V ELSE END IF RETURN C 24 CONTINUE HPI = 2.0*ATAN(1.0) IF (X.GE.0.0) THEN IF (ALPHA.GT.-1.0 .AND. ALPHA.LT.0.0) THEN U = (HPI-X)**(0.5-ALPHA) V = (HPI-X)**(0.5+ALPHA) PUP = -(0.5-ALPHA)*(HPI-X)**(-0.5-ALPHA) PVP = -(0.5+ALPHA)*(HPI-X)**(-0.5+ALPHA) HU = (0.25-ALPHA**2)*(HPI-X)**(-1.5-ALPHA) + Q(X)*U HV = (0.25-ALPHA**2)*(HPI-X)**(-1.5+ALPHA) + Q(X)*V ELSE IF (ALPHA.EQ.0.0) THEN U = SQRT(HPI-X) V = U*LOG(HPI-X) PUP = -0.5/U PVP = -(1.0+0.5*LOG(HPI-X))/U HU = 0.25/((HPI-X)*U) + Q(X)*U HV = 0.25*LOG(HPI-X)/((HPI-X)*U) + Q(X)*V ELSE IF (ALPHA.GT.0.0 .AND. ALPHA.LT.1.0) THEN U = (HPI-X)**(0.5+ALPHA) V = (HPI-X)**(0.5-ALPHA) PUP = -(0.5+ALPHA)*(HPI-X)**(-0.5+ALPHA) PVP = -(0.5-ALPHA)*(HPI-X)**(-0.5-ALPHA) HU = (0.25-ALPHA**2)*(HPI-X)**(-1.5+ALPHA) + Q(X)*U HV = (0.25-ALPHA**2)*(HPI-X)**(-1.5-ALPHA) + Q(X)*V END IF ELSE IF (BETA.GT.-1.0 .AND. BETA.LT.0.0) THEN U = (HPI+X)**(0.5-BETA) V = (HPI+X)**(0.5+BETA) PUP = (0.5-BETA)*(HPI+X)**(-0.5-BETA) PVP = (0.5+BETA)*(HPI+X)**(-0.5+BETA) HU = (0.25-BETA**2)*(HPI+X)**(-1.5-BETA) + Q(X)*U HV = (0.25-BETA**2)*(HPI+X)**(-1.5+BETA) + Q(X)*V ELSE IF (BETA.EQ.0.0) THEN U = SQRT(HPI+X) V = U*LOG(HPI+X) PUP = 0.5/U PVP = (1.0+0.5*LOG(HPI+X))/U HU = 0.25/((HPI+X)*U) + Q(X)*U HV = 0.25*LOG(HPI+X)/((HPI+X)*U) + Q(X)*V ELSE IF (BETA.GT.0.0 .AND. BETA.LT.1.0) THEN U = (HPI+X)**(0.5+BETA) V = (HPI+X)**(0.5-BETA) PUP = (0.5+BETA)*(HPI+X)**(-0.5+BETA) PVP = (0.5-BETA)*(HPI+X)**(-0.5-BETA) HU = (0.25-BETA**2)*(HPI+X)**(-1.5+BETA) + Q(X)*U HV = (0.25-BETA**2)*(HPI+X)**(-1.5-BETA) + Q(X)*V END IF END IF RETURN C 25 CONTINUE RETURN C 26 CONTINUE RETURN C 27 CONTINUE RETURN C 28 CONTINUE RETURN C 29 CONTINUE RETURN END SHAR_EOF fi # end of overwriting check cd .. if test -f 'bsample.lnk' then echo shar: will not over-write existing file "'bsample.lnk'" else cat << SHAR_EOF > 'bsample.lnk' *Make SAMPLE.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo batchio lo ..\probsets\sample file bsample.exe SHAR_EOF fi # end of overwriting check if test -f 'bstandrd.lnk' then echo shar: will not over-write existing file "'bstandrd.lnk'" else cat << SHAR_EOF > 'bstandrd.lnk' *Make bstandrd.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo batchio lo ..\probsets\standard file bstandrd.exe SHAR_EOF fi # end of overwriting check if test -f 'd02kef.doc' then echo shar: will not over-write existing file "'d02kef.doc'" else cat << SHAR_EOF > 'd02kef.doc' IMPORTANT: For a complete specification of the routine see the NAG Fortran Library Handbook. Terms marked //...// may be implementation dependent. A. Purpose //D02KEF// finds a specified eigenvalue of a regular singular second-order Sturm-Liouville system of the form (p(x)y')' + Q(x;lambda)y = 0 on a finite or infinite range (a,b) with boundary conditions at a and b, using a Pruefer transformation and a shooting method. It also reports values of the eigenfunction and its derivatives. Provision is made for discontinuities in the coefficient functions or their derivatives. B. Specification SUBROUTINE //D02KEF//(XPOINT, M, MATCH, COEFFN, BDYVAL, K, 1 TOL, ELAM, DELAM, HMAX, MAXIT, MAXFUN, 2 MONIT, REPORT, IFAIL) INTEGER NXP, IC1, K, MAXIT, MAXFUN, IFAIL //real// XPOINT(M), TOL, ELAM, DELAM, HMAX(2,M) EXTERNAL COEFFN, BDYVAL, MONIT, REPORT C. Parameters 1: XPOINT(M) - //real// array. Input On entry: the points where the boundary conditions computed by BDYVAL are to be imposed, and also any break-points, i.e. XPOINT(1) to XPOINT(m) must contain values x(1),...,x(m) such that x(1) <= x(2) < x(3) < ... < x(m-1) <= x(m) with the following meanings: (a) x(1) and x(m) are the left and right end-points, a and b, of the domain of definition of the Sturm-Liouville system if these are finite. If either a or b is infinite, the corresponding value x(1) or x(m) may be a more-or-less arbitrarily `large' number of appropriate sign. (b) x(2) and x(m-1) are the Boundary Matching Points (BMP's), that is the points at which the left and right boundary conditions computed in BDYVAL are imposed. If the left-hand end-point is a regular point then the user should set x(2) = x(1) (= a), while if it is a singular point the user must set x(2) > x(1). Similarly x(m-1) = x(m) (= b) if the right-hand end-point is regular, and x(m-1) < x(m) if it is singular. (c) The remaining m - 4 points x(3),...,x(m-2), if any, define `break-points' which divide the interval [x(2),x(m-1)] into m - 3 sub-intervals i(1) = [x(2),x(3)], ..., i(m-3) = [x(m-2),x(m-1)] Numerical integration of the differential equation is stopped and restarted at each break-point. In simple cases no break-points are needed. However if p(x) or q(x;lambda) are given by different formulae in different parts of the range, then integration is more efficient if the range is broken up by break-points in the appropriate way. Similarly points where any jumps occur in p(x) or q(x;lambda), or in their derivatives up to the fifth order, should appear as break-points. Constraint: X(1) <= X(2) < ... < X(M-1) <= X(M). 2: M - INTEGER. Input On entry: the number of points in the array XPOINT. Constraint: M >= 4. 3: MATCH - INTEGER. Input/Output On entry: MATCH must be set to the index of the `break-point' to be used as the matching point (see Section 8.3 of the routine document in the NAG Fortran Library Manual). If MATCH is set to a value outside the range [2,m-1] then a default value is taken, corresponding to the break-point nearest the centre of the interval [XPOINT(2),XPOINT(m-1)]. On exit: the index of the break-point actually used as the matching point. 4: COEFFN - SUBROUTINE, supplied by the user. External Procedure COEFFN must compute the values of the coefficient functions p(x) and q(x;lambda) for given values of x and lambda. Section 3 of the routine document in the NAG Fortran Library Manual states conditions which p and q must satisfy. Its specification is: | SUBROUTINE COEFFN(P, Q, DQDL, X, ELAM, JINT) | //real// P, Q, DQDL, X, ELAM | INTEGER JINT | 1: P - //real//. Output | On exit: the value of p(x) for the current value of x. | 2: Q - //real//. Output | On exit: the value of q(x;lambda) for the current value of x | and the current trial value of lambda. | 3: DQDL - //real//. Output | On exit: the value of (pd q)/(pd lambda)(x;lambda) for the | current value of x and the current trial value of lambda. | However DQDL is only used in error estimation and an | approximation (say to within 20%) will suffice. | 4: X - //real//. Input | On entry: the current value of x. | 5: ELAM - //real//. Input | On entry: the current trial value of the eigenvalue parameter | lambda. | 6: JINT - INTEGER. Input | On entry: the index j of the sub-interval i(j) (see | specification of XPOINT) in which x lies. | See Sections 8.4 and 9 of the routine document in the NAG | Fortran Library Manual for examples. COEFFN must be declared as | EXTERNAL in the (sub)program from which //D02KEF// is called. | Parameters denoted as Input must **not** be changed by this | procedure. 5: BDYVAL - SUBROUTINE, supplied by the user. External Procedure BDYVAL must define the boundary conditions. For each end-point, BDYVAL must return (in YL or YR) values of y(x) and p(x)y'(x) which are consistent with the boundary conditions at the end-points; only the ratio of the values matters. Here x is a given point (XL or XR) equal to, or close to, the end-point. For a **regular** end-point (a, say), x = a; and a boundary condition of the form c(1)y(a) + c(2)y'(a) = 0 can be handled by returning constant values in YL, e.g. YL(1) = c(2) and YL(2) = -c(1)p(a). For a **singular** end-point however, YL(1) and YL(2) will in general be functions of XL and ELAM, and YR(1) and YR(2) functions of XR and ELAM, usually derived analytically from a power-series or asymptotic expansion. Examples are given in Sections 8.5 and 9 of the routine document in the NAG Fortran Library Manual. Its specification is: | SUBROUTINE BDYVAL(XL, XR, ELAM, YL, YR) | //real// XL, XR, ELAM, YL(3), YR(3) | 1: XL - //real//. Input | On entry: if a is a regular end-point of the system (so that | a = x(1) = x(2)), then XL contains a. If a is a singular | point (so that a <= x(1) < x(2)), then XL contains a point x | such that x(1) < x <= x(2)). | 2: XR - //real//. Input | On entry: if b is a regular end-point of the system (so that | x(m-1) = x(m) = b), then XR contains b. If b is a singular | point (so that x(m-1) < x(m) <= b), then XR contains a point | x such that x(m-1) <= x < x(m). | 3: ELAM - //real//. Input | On entry: the current trial value of lambda. | 4: YL(3) - //real// array. Output | On exit: YL(1) and YL(2) should contain values of y(x) and | p(x)y'(x) respectively (not both zero) which are consistent | with the boundary condition at the left-hand end-point, given | by x = XL. YL(3) should not be set. | 5: YR(3) - //real// array. Output | On exit: YR(1) and YR(2) should contain values of y(x) and | p(x)y'(x) respectively (not both zero) which are consistent | with the boundary condition at the right-hand end-point, | given by x = XR. YR(3) should not be set. | BDYVAL must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 6: K - INTEGER. Input On entry: the index k of the required eigenvalue when the eigenvalues are ordered lambda(0) < lambda (1) < lambda(2) < ... < lambda(k) < ... . Constraint: K >= 0. 7: TOL - //real//. Input On entry: the tolerance parameter which determines the accuracy of the computed eigenvalue. The error estimate held in DELAM on exit satisfies the mixed absolute/relative error test DELAM <= TOL*max(1.0,abs(ELAM)) (*) where ELAM is the final estimate of the eigenvalue. DELAM is usually somewhat smaller than the right-hand side of (*) but not several orders of magnitude smaller. Constraint: TOL > 0.0. 8: ELAM - //real//. Input/Output On entry: an initial estimate of the eigenvalue lambda-tilde. On exit: the final computed estimate, whether or not an error occurred. 9: DELAM - //real//. Input/Output On entry: an indication of the scale of the problem in the lambda-direction. DELAM holds the initial `search step' (positive or negative). Its value is not critical but the first two trial evaluations are made at ELAM and ELAM + DELAM, so the routine will work most efficiently if the eigenvalue lies between these values. A reasonable choice (if a closer bound is not known) is half the distance between adjacent eigenvalues in the neighbourhood of the one sought. In practice, there will often be a problem, similar to the one in hand but with known eigenvalues, which will help one to choose initial values for ELAM and DELAM. If DELAM = 0.0 on entry, it is given the default value of 0.25*max(1.0,abs(ELAM)). On exit: with IFAIL = 0, DELAM holds an estimate of the absolute error in the computed eigenvalue, that is abs(lambda-tilde-ELAM) approximately equal to DELAM. (In Section 8.2 of the routine document in the NAG Fortran Library Manual we discuss the assumptions under which this is true.) The true error is rarely more than twice, or less than a tenth, of the estimated error. With IFAIL <> 0, DELAM may hold an estimate of the error, or its initial value, depending on the value of IFAIL. See Section D for further details. 10: HMAX(2,M) - //real// array. Input/Output On entry: HMAX(1,j) a maximum step size to be used by the differential equation code in the jth sub-interval i(j) (as described in the specification of parameter XPOINT), for j = 1,2,...,m-3. If it is zero the routine generates a maximum step size internally. It is recommended that HMAX(1,j) be set to zero unless the coefficient functions p and q have features (such as a narrow peak) within the jth sub-interval that could be `missed' if a long step were taken. In such a case HMAX(1,j) should be set to about half the distance over which the feature should be observed. Too small a value will increase the computing time for the routine. See Section 8 of the routine document in the NAG Fortran Library Manual for further suggestions. The rest of the array is used as workspace. On exit: HMAX(1,m-1) and HMAX(1,m) contain the sensitivity coefficients sigma(l),sigma(r), described in Section 8.6 of the routine document in the NAG Fortran Library Manual. Other entries contain diagnostic output in case of an error (see Section D). 11: MAXIT - INTEGER. Input/Output On entry: a bound on n(r), the number of root-finding iterations allowed, that is the number of trial values of lambda that are used. If MAXIT <= 0, no such bound is assumed. (See also under MAXFUN.) Suggested value: MAXIT = 0. On exit: MAXIT will have been decreased by the number of iterations actually performed, whether or not it was positive on entry. 12: MAXFUN - INTEGER. Input On entry: a bound on n(f), the number of calls to COEFFN made in any one root-finding iteration. If MAXFUN <= 0, no such bound is assumed. Suggested value: MAXFUN = 0. MAXFUN and MAXIT may be used to limit the computational cost of a call to //D02KEF//, which is roughly proportional to n(r)*n(f). 13: MONIT - SUBROUTINE, supplied by the user. External Procedure MONIT is called by //D02KEF// at the end of each root-finding iteration and allows the user to monitor the course of the computation by printing out the parameters (see Section 8 of the routine document in the NAG Fortran Library Manual for an example). If no monitoring is required, the dummy subroutine D02KAY may be used. (D02KAY is included in the NAG Fortran Library. In some implementations of the Library the name is changed to KAYD02: refer to the Users' Note for your implementation.) Its specification is: | SUBROUTINE MONIT(MAXIT, IFLAG, ELAM, FINFO) | INTEGER MAXIT, IFLAG | //real// ELAM, FINFO(15) | 1: MAXIT - INTEGER. Input | On entry: the current value of the parameter MAXIT of | //D02KEF//; this is decreased by one at each iteration. | 2: IFLAG - INTEGER. Input | On entry: IFLAG describes what phase the computation is in, | as follows: | IFLAG < 0 | an error occurred in the computation of the `miss-distance' | at this iteration; an error exit from //D02KEF// with | IFAIL = -IFLAG will follow. | IFLAG = 1 | the routine is trying to bracket the eigenvalue | lambda-tilde. | IFLAG = 2 | the routine is converging to the eigenvalue lambda-tilde | (having already bracketed it). | 3: ELAM - //real//. Input | On entry: the current trial value of lambda. | 4: FINFO(15) - //real// array. Input | On entry: information about the behaviour of the shooting | method, and diagnostic information in the case of errors. It | should **not** normally be printed in full if no error has | occurred (that is, if IFLAG > 0), though the first few | components may be of interest to the user. In case of an | error (IFLAG < 0) all the components of FINFO should be | printed. The contents of FINFO are as follows: | FINFO(1): the current value of the `miss-distance' or | `residual' function f(lambda) on which the shooting method is | based. (See Section 8.2 of the routine document in the NAG | Fortran Library Manual for further notes on it.) FINFO(1) is | set to zero if IFLAG < 0. | FINFO(2): an estimate of the quantity | partial derivative(lambda) defined as follows. Consider the | perturbation in the miss-distance f(lambda) that would result | if the local error, in the solution of the differential | equation, were always positive and equal to its maximum | permitted value. Then partial derivative(lambda) is the | perturbation in lambda that would have the same effect on | f(lambda). Thus, at the zero of | f(lambda),abs(partial derivative(lambda)) is an approximate | bound on the perturbation of the zero (that is the | eigenvalue) caused by errors in numerical solution. If | partial derivative(lambda) is very large then it is possible | that there has been a programming error in COEFFN such that q | is independent of lambda. If this is the case, an error exit | with IFAIL = 5 should follow. FINFO(2) is set to zero if | IFLAG < 0. | FINFO(3): the number of internal iterations, using the same | value of lambda and tighter accuracy tolerances, needed to | bring the accuracy (that is the value of | partial derivative(lambda)) to an acceptable value. Its value | should normally be 1.0, and should almost never exceed 2.0. | FINFO(4): the number of calls to COEFFN at this iteration. | FINFO(5): the number of successful steps taken by the | internal differential equation solver at this iteration. A | step is successful if it is used to advance the integration | (cf. COUT(8) in specification of //D02PAF//). | FINFO(6): the number of unsuccessful steps used by the | internal integrator at this iteration (cf. COUT(9) in | specification of //D02PAF//). | FINFO(7): the number of successful steps at the maximum step | size taken by the internal integrator at this iteration (cf. | COUT(3) in specification of //D02PAF//). | FINFO(8): is not used. | FINFO(9) to FINFO(15): set to zero, unless IFLAG < 0 in which | case they hold the following values describing the point of | failure: | FINFO(9): contains the index of the sub-interval where | failure occurred, in the range 1 to m - 3. In case of an | error in BDYVAL, it is set to 0 or m - 2 depending on whether | the left or right boundary condition caused the error. | FINFO(10): the value f the independent variable x, the point | at which error occurred. In case of an error in BDYVAL, it is | set to the value of XL or XR as appropriate (see the | specification of BDYVAL). | FINFO(11), FINFO(12), FINFO(13): the current values of the | Pruefer dependent variables beta, phi and rho respectively. | These are set to zero in case of an error in BDYVAL. | FINFO(14): the local-error tolerance being used by the | internal integrator at the point of failure. This is set to | zero in the case of an error in BDYVAL. | FINFO(15): the last integration mesh point. This is set to | zero in the case of an error in BDYVAL. | MONIT must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 14: REPORT - SUBROUTINE, supplied by the user. External Procedure This routine provides the means by which the user may compute the eigenfunction y(x) and its derivative at each integration mesh point x. (See Section 8 of the routine document in the NAG Fortran Library Manual for an example). Its specification is: | SUBROUTINE REPORT (X, V, JINT) | INTEGER JINT | //real// X, V(3) | 1: X - //real//. Input | On entry: the current value of the independent variable x. | See Section 8.3 of the routine document in the NAG Fortran | Library Manual for the order in which values of x are | supplied. | 2: V(3) - //real// array. Input | On entry: V(1), V(2), V(3) hold the current values of the | Pruefer variables beta, phi, rho respectively. | 3: JINT - INTEGER. Input | On entry: JINT indicates the sub-interval between | break-points in which X lies exactly as for the routine | COEFFN, **except** that at the extreme left end-point (when | x = XPOINT(2)) JINT is set to 0 and at the extreme right | end-point (when x = x(r) = XPOINT(m-1)) JINT is set to m - 2. | REPORT must be declared as EXTERNAL in the (sub)program from | which //D02KEF// is called. Parameters denoted as Input must | **not** be changed by this procedure. 15: IFAIL - INTEGER. Input/Output On entry: IFAIL must be set to 0, -1 or 1. For users not familiar with this parameter (described in Chapter P01 in the NAG Fortran Library Manual or this HELP system) the recommended value is 0. On exit: IFAIL = 0 unless the routine detects an error (see Section D). D. Error Indicators and Warnings Errors detected by the routine: IFAIL = 1 A parameter error. All parameters (except IFAIL) are left unchanged. The reason for the error is shown by the value of HMAX(2,1) as follows: HMAX(2,1) = 1: M < 4; HMAX(2,1) = 2: K < 0; HMAX(2,1) = 3: TOL <= 0.0; HMAX(2,1) = 4: XPOINT(1) to XPOINT(m) are not in ascending order. HMAX(2,2) gives the position i in XPOINT where this was detected. IFAIL = 2 At some call to BDYVAL, invalid values were returned, that is, either YL(1) = YL(2) = 0.0, or YR(1) = YR(2) = 0.0 (a programming error in BDYVAL). See the last call of MONIT for details. This error exit will also occur if p(x) is zero at the point where the boundary condition is imposed. Probably BDYVAL was called with XL equal to a singular end-point a or with XR equal to a singular end-point b. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 3 At some point between XL and XR the value of p(x) computed by COEFFN became zero or changed sign. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 4 MAXIT > 0 on entry, and after MAXIT iterations the eigenvalue had not been found to the required accuracy. IFAIL = 5 The `bracketing' phase (with parameter IFLAG of MONIT equal to 1) failed to bracket the eigenvalue within ten iterations. This is caused by an error in formulating the problem (for example, q is independent of lambda), or by very poor initial estimates of ELAM, DELAM. On exit ELAM and ELAM + DELAM give the end-points of the interval within which no eigenvalue was located by the routine. IFAIL = 6 MAXFUN > 0 on entry, and the last iteration was terminated because more than MAXFUN calls to COEFFN were used. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 7 To obtain the desired accuracy the local error tolerance was set so small at the start of some sub-interval that the differential equation solver could not choose an initial step size large enough to make significant progress. See the last call of MONIT for diagnostics. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 8 At some point inside a sub-interval the step size in the differenital equation solver was reduced to a value too small to make significant progress (for the same reasons as with IFAIL = 7). This could be due to pathological behaviour of p(x) and q(x;lambda) or to an unreasonable accuracy requirement or to the current value of lambda making the equations `stiff'. See the last call of MONIT for details. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 9 TOL is too small for the problem being solved and the //machine precision// is being used. The final value of ELAM should be a very good approximation to the eigenvalue. IFAIL = 10 //C05AZF//, called by //D02KEF//, has terminated with the error exit corresponding to a pole of the residual function f(lambda). This error exit should not occur, but if it does, try solving the problem again with a smaller value for TOL. IFAIL = 11 A serious error has occurred in D02KDY. Check all subroutine calls and array dimensions. Seek expert help. HMAX(2,1) holds the failure exit number from D02KDY. This error exit is caused by being unable to set up or solve the differential equation at some iteration, and will be immediately preceded by a call of MONIT giving diagnostic information. IFAIL = 12 A serious error has occurred in //C05AZF//. Check all subroutine calls and array dimensions. Seek expert help. HMAX(2,1) holds the failure exit number from C05AZF. HMAX(2,2) holds the value of parameter IND of //C05AZF//. SHAR_EOF fi # end of overwriting check if test -f 'd02kef.lnk' then echo shar: will not over-write existing file "'d02kef.lnk'" else cat << SHAR_EOF > 'd02kef.lnk' *Form DLL for D02KEF *None of its subordinate routines are to be visible from outside liboffset 41000000 suppress lo d02kef entry d02kef file d02kef.lib SHAR_EOF fi # end of overwriting check if test -f 'evsimp.lnk' then echo shar: will not over-write existing file "'evsimp.lnk'" else cat << SHAR_EOF > 'evsimp.lnk' lo evsimp lo sltstpak lo \sl\probsets\standard file SHAR_EOF fi # end of overwriting check if test -f 'filelist' then echo shar: will not over-write existing file "'filelist'" else cat << SHAR_EOF > 'filelist' filelist slattrib.bat sltar.bat slpkzip.bat librarie.dir slsetup.bat read.me PROBSETS/standard.f PROBSETS/sample.f D02KEF/d02kef.lnk D02KEF/d02kef.f D02KEF/d02kef.doc SLEDGE/sledgemd.lnk SLEDGE/sledgemd.f SLEIGN2/sleig2md.f SLEIGN2/sleig2md.lnk SLEIGN2/EXTRAS/sleign2x.tex SLEIGN2/EXTRAS/drived.f SLEIGN2/EXTRAS/sleign2.doc SLEIGN2/EXTRAS/sleign2.hlp SLEIGN2/EXTRAS/sleign2.txt SLEIGN2/EXTRAS/makepqwd.f SLEIGN2/EXTRAS/sleign2d.f SLEIGN2/EXTRAS/xamplesd.f MARCOPAK/marcomod.lnk MARCOPAK/marcomod.f SLDRIVER/safeio.f SLDRIVER/slpset.f SLDRIVER/slhelp0.hlp SLDRIVER/sld02k.hlp SLDRIVER/batchio.f SLDRIVER/standard.lnk SLDRIVER/sltstpak.f SLDRIVER/dbmod.f SLDRIVER/sldriver.f SLDRIVER/slconsts.f SLDRIVER/bstandrd.lnk SLDRIVER/solvrs.f SLDRIVER/slutil.f SLDRIVER/sample.lnk SLDRIVER/slbrows.hlp SLDRIVER/errflags.hlp SLDRIVER/evsimp.f SLDRIVER/evsimp.lnk SLDRIVER/sltstvar.f SLDRIVER/nagf90.mk SLDRIVER/salftn90.mk SLDRIVER/initpuff.hlp SLDRIVER/bsample.lnk SLDRIVER/samplrun.dat SLDRIVER/samplrun.out SLDRIVER/standard/keep.me SLDRIVER/standard/TRUEVALS/evtru.29 SLDRIVER/standard/TRUEVALS/evtru.40 SLDRIVER/standard/TRUEVALS/evtru.01 SLDRIVER/standard/TRUEVALS/evtru.19 SLDRIVER/standard/TRUEVALS/evtru.36 SLDRIVER/standard/TRUEVALS/evtru.35 SLDRIVER/standard/TRUEVALS/evtru.34 SLDRIVER/standard/TRUEVALS/evtru.41 SLDRIVER/standard/TRUEVALS/evtru.07 SLDRIVER/standard/TRUEVALS/evtru.20 SLDRIVER/standard/TRUEVALS/eftru.01 SLDRIVER/standard/TRUEVALS/eftru.21 SLDRIVER/standard/TRUEVALS/eftru.28 SLDRIVER/standard/TRUEVALS/eftru.36 SLDRIVER/standard/TRUEVALS/eftru.29 SLDRIVER/standard/TRUEVALS/eftru.02 SLDRIVER/standard/TRUEVALS/sdtru.57 SLDRIVER/standard/TRUEVALS/sdtru.56 SLDRIVER/standard/TRUEVALS/evtru.32 SLDRIVER/standard/TRUEVALS/evtru.28 SLDRIVER/standard/TRUEVALS/evtru.30 SLDRIVER/standard/TRUEVALS/evtru.15 SLDRIVER/standard/TRUEVALS/evtru.18 SLDRIVER/standard/TRUEVALS/evtru.21 SLDRIVER/standard/TRUEVALS/evtru.43 SLDRIVER/standard/TRUEVALS/evtru.23 SLDRIVER/standard/TRUEVALS/evtru.05 SLDRIVER/standard/TRUEVALS/evtru.02 SLDRIVER/standard/TRUEVALS/evtru.22 SLDRIVER/standard/TRUEVALS/eftru.07 SLDRIVER/standard/TRUEVALS/eftru.20 SLDRIVER/standard/TRUEVALS/eftru.22 SLDRIVER/standard/TRUEVALS/eftru.35 SLDRIVER/standard/TRUEVALS/eftru.41 SLDRIVER/standard/TRUEVALS/eftru.15 SLDRIVER/sample/keep.me LATEX/sltstpak.tex LATEX/slref.bib LATEX/graph2.eps LATEX/sldriver.tex LATEX/epsf.tex LATEX/jdpdefs.tex LATEX/sltstalg.tex LATEX/graph1.eps LATEX/esub2acm.sty LATEX/sltstalg.bbl LATEX/sltstpak.bbl LATEX/sldriver.bbl SLEIGN/sleignmd.lnk SLEIGN/sleignmd.f SHAR_EOF fi # end of overwriting check if test -f 'librarie.dir' then echo shar: will not over-write existing file "'librarie.dir'" else cat << SHAR_EOF > 'librarie.dir' *sample LIBRARIE.DIR for Salford DBOS system *to make known the Dynamic Link Libraries of Solver code *57000000 onward C:\FTN90\F90LIB.LIB C:\FTN90\F90LIB.LIB *42000000 onward c:\sl\marcopak\marcopak.lib c:\sl\marcopak\marcopak.lib *43000000 onward c:\sl\sledge\sledge.lib c:\sl\sledge\sledge.lib *44000000 onward c:\sl\sleign\sleign.lib c:\sl\sleign\sleign.lib *45000000 onward c:\sl\sleign2\sleign2.lib c:\sl\sleign2\sleign2.lib SHAR_EOF fi # end of overwriting check if test -f 'marcomod.lnk' then echo shar: will not over-write existing file "'marcomod.lnk'" else cat << SHAR_EOF > 'marcomod.lnk' *Form DLL for MARCOMOD (MARCOPAK as a module) *Make the top-level routines SL01F, SL02F, etc visible from outside *but none of their subordinate routines are to be visible liboffset 42000000 lo marcomod file marcopak.lib SHAR_EOF fi # end of overwriting check if test -f 'nagf90.mk' then echo shar: will not over-write existing file "'nagf90.mk'" else cat << SHAR_EOF > 'nagf90.mk' # File:Makefile, revision of Aug 1998 # Purpose: # Manage the files making up the SLDRIVER package, when using the # NAG f90 system under Unix # Author : John Pryce, RMCS, Shrivenham, Swindon, UK #(pryce@rmcs.cranfield.ac.uk) # Disclaimer: # This file is provided as is, with no claim that it operates # correctly in all circumstances. # References: # SLDRIVER User Guide & Tutorial, RMCS Tech. Rep. SEAS/CISE/96/JDP01 # ###################### INSTRUCTIONS FOR USE ############################## #1.This file must be placed in, and invoked from, the 'sldriver' directory #under the home directory of the SL package. This ensures that the #'.mod' (module specification) files are put in this directory. # #2.Set SL to the home directory of the SL package: SL=/nfs/quince/d2/home/cur/trh/SandPit/CALGO/789 # #3.Define the compiler F90=f90 -c LINK=f90 #4.If desired, reset these compilation options: OPTS= #5.The extension of a module specification file: MOD=mod #The following can be typed at the DOS prompt: #COMMAND |EFFECT #------------------------------------------------------------------------ #mk|makes standard.x if necessary, and launches it. #mk standard.x |as above but without launching it. #mk sample |makes sample.x if necessary, and launches it. #mk bstandrd.x |makes bstandrd.x if necessary, doesn't launch it. #mk sample.x |as above but without launching it. #etc... (the above are the most useful). ######################################################################### ## Run the main executable, which uses the STANDARD problem set standard: standard.x standard.x standard.x: sldriver.o slutil.o solvrs.o dbmod.o \ safeio.o sltstpak.o standard.o $(LINK) -o standard.x sldriver.o slutil.o solvrs.o dbmod.o safeio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o standard.o ## Alternative executable, using SAMPLE problem set sample: sample.x sample.x sample.x: sldriver.o slutil.o solvrs.o dbmod.o \ safeio.o sltstpak.o sample.o $(LINK) -o sample.x sldriver.o slutil.o solvrs.o dbmod.o safeio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o sample.o ## Batch-run executable, using STANDARD problem set bstandrd.x: sldriver.o slutil.o solvrs.o dbmod.o \ batchio.o sltstpak.o standard.o $(LINK) -o bstandrd.x sldriver.o slutil.o solvrs.o dbmod.o batchio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o standard.o ## Batch-run executable, using SAMPLE problem set bsample.x: sldriver.o slutil.o solvrs.o dbmod.o \ batchio.o sltstpak.o sample.o $(LINK) -o bsample.x sldriver.o slutil.o solvrs.o dbmod.o batchio.o \ sltstvar.o slpset.o \ sledgemd.o sleignmd.o sleig2md.o marcomod.o \ sltstpak.o sample.o ##Make all the executables: all.x: standard.x bstandrd.x sample.x bsample.x ## General compilation rule .f.o: $(F90) $(OPTS) $< ## The main-program source sldriver.o: sldriver.f dbmod.o safeio.o slutil.o solvrs.o \ slconsts.o slpset.o sltstpak.o $(F90) $(OPTS) sldriver.f ## The database facilities dbmod.o:dbmod.f safeio.o slutil.o slconsts.o slpset.o $(F90) $(OPTS) dbmod.f ## The solver interfaces solvrs.o: solvrs.f safeio.o slutil.o slconsts.o \ sltstpak.o sledge.o sleign.o marcopak.o sleign2.o $(F90) $(OPTS) solvrs.f ## Utilities #safeio.o: safeio.f #$(F90) $(OPTS) safeio.f #batchio.o:batchio.f #$(F90) $(OPTS) batchio.f #slutil.o: slutil.f #$(F90) $(OPTS) slutil.f #slconsts.o: slconsts.f #$(F90) $(OPTS) slconsts.f #slpset.o: slpset.f #$(F90) $(OPTS) slpset.f ## SLTSTPAK: problem/solver interface routines sltstpak.o: sltstpak.f sltstvar.o testmod.$(MOD) $(F90) $(OPTS) sltstpak.f ## Problem-set routines ##BUG HERE! I don't know how to make MK distinguish between different ##problem sets, so at present it only seems to work if one makes the ##standard executable before the sample one (TESTMOD.MOD gets out of ##kilter otherwise?) testmod.mod: standard.o ##testmod.mod: sample.o standard.o: $(SL)/probsets/standard.f sltstvar.o $(F90) $(OPTS) $(SL)/probsets/standard.f sample.o: $(SL)/probsets/sample.f sltstvar.o $(F90) $(OPTS) $(SL)/probsets/sample.f ## The solvers. They live in their own directories. ## Compilation is to be done from within the SLDRIVER directory ## so that the .o and .mod files get stored there. sledge.o: $(SL)/sledge/sledgemd.f $(F90) $(OPTS) $(SL)/sledge/sledgemd.f sleign.o: $(SL)/sleign/sleignmd.f $(F90) $(OPTS) $(SL)/sleign/sleignmd.f marcopak.o: $(SL)/marcopak/marcomod.f $(F90) $(OPTS) $(SL)/marcopak/marcomod.f sleign2.o:$(SL)/sleign2/sleig2md.f $(F90) $(OPTS) $(SL)/sleign2/sleig2md.f SHAR_EOF fi # end of overwriting check if test -f 'read.me' then echo shar: will not over-write existing file "'read.me'" else cat << SHAR_EOF > 'read.me' INSTALLATION INSTRUCTIONS FOR THE SLDRIVER PACKAGE -------------------------------------------------- (Fortran 90 version 4.1) The package comes as an MS-DOS 3.5 in. diskette, containing both a PC and a Unix version of the files. 1.Installation files for PC ------------------------- The diskette contains a self-extracting compressed file SLZIP.EXE created by the PKZIP package, version 2.04g, plus this READ.ME file. It takes up about 0.5Mb, while the uncompressed files occupy around 1.5Mb. The directory structure should be re-created under a subdirectory, for instance C:\SL, by moving to that directory and issuing the command (the -d is essential!) a:slzip -d The resulting directory tree is shown below. C:\SL | SLSETUP.BAT ... Batchfile to compile all code under | Salford FTN90 | SLPKZIP.BAT ... Batchfile to re-create archive disk | +---SLDRIVER ... The main code of the package | | BATCHIO.FOR ... 'batch' version of SAFEIO | | DBMOD.FOR ... database routines module DBMOD | | SAFEIO.FOR ... safe interactive input module SAFEIO | | SLCONSTS.FOR ... global constants used by SLDRIVER | | SLDRIVER.FOR ... main program & module SLMOD | | SLPSET.FOR ... common variables: current SLDRIVER state | | SLTSTPAK.FOR ... general interface of problems to solvers | | SLTSTVAR.FOR ... common variables: current SLTSTPAK state | | SLUTIL.FOR ... utility routines module SLUTIL | | SOLVRS.FOR ... specific solvers interface module SOLVRS | | | +---STANDARD ... To hold output from STANDARD program | | | | | \---TRUEVALS | | Files EVTRU.nn, EFTRU.nn of "true" ev & efn data | | | \---SAMPLE ... To hold output from SAMPLE program | | | \---TRUEVALS | +---PROBSETS | STANDARD.FOR ... Include this problem set to make STANDARD.EXE | SAMPLE.FOR ... and this one to make SAMPLE.EXE | +---SLEIGN ... Bailey-Gordon-Shampine package | SLEIGN.FOR | +---D02KEF ... Pryce package, NAG 1978 | D02KEF.FOR (not used in current SLDRIVER) | +---MARCOPAK ... Marletta-Pryce package | MARCOPAK.FOR | +---SLEDGE ... Fulton-Pruess package | SLEDGE.FOR | +---SLEIGN2 ... Bailey-Everitt-Zettl revision of SLEIGN | SLEIGN2.FOR | | | \---EXTRAS | \---TEX ... Documentation files SLTSTPAK.TEX ... ACM Trans. Math. Softw. articles SLTSTALG.TEX on SLTSTPAK SLDRIVER.TEX ... User guide plus various auxiliary (.bbl, .sty, .eps etc) files 2.Installation files for Unix --------------------------- The diskette contains a compressed file SLTAR.Z which is the result of processing the above directory structure using DOS versions of the utilities dos2unix (to convert DOS newline CR-LF to Unix newline LF), tar (to put the whole file structure into one file) and gzip (to compress the result). Owing to an apparent bug in the tar program I was unable to convert the filenames to lower-case, which is inconvenient but not serious. To install the package under Unix: - Mount the diskette and copy SLTAR.Z to a suitable directory, say sl. - Use gzip -d or equivalent, to decompress. - Use tar -x to recreate the directory structure under the sl directory. I successfully did this on a Sun under Solaris. 3.Modifications to the source code -------------------------------- The source has proved almost platform-independent but will need, at least, the following adjustments: - The program creates files in subdirectories and has to be aware of the path-naming conventions used by the host operating system. This is encapsulated in routine ADDDIR in SLDRIVER.FOR. In this, change the data initialization of the variable OPSYS from 0 to whatever is appropriate for your system. If you do not, the program will still work but it will ask the user for this information at run time. - Each of the solvers has settings of machine precision and other parameters of the arithmetic. With the help of the solver documentation, make any needed changes. - In the BATCHIO version of SAFEIO, there are lines in routine SPAUSE which trap a CTRL-C at the keyboard when using the Salford FTN90 system. If using another compiler, comment out these lines or replace the call to GET_KEY1@ by the appropriate code for your system. 4.Variants -------- Alternative versions of the program are as follows: - To create the SAMPLE program replace the object file of the STANDARD problem set by the SAMPLE file when linking. - To create the `batch' program replace the SAFEIO object file by the BATCHIO file when linking. This gives 4 combinations, STANDARD.EXE, SAMPLE.EXE, BSTANDRD.EXE and BSAMPLE.EXE 5.Creating the executables ------------------------ The source files must be compiled in an order that respects the module dependencies. (The SL-solver codes do not depend on anything else but they must be compiled before SOLVRS.FOR.) Two files are provided which help to automate the process under the Salford Fortran 90 system and should be easily converted for other systems: SLSETUP.BAT is a MS-DOS script in the toplevel directory. It must be invoked from within that directory. If all goes well, this compiles all source, forms DLLs from the solvers (check for address conflicts with any DLLs of your own!) and links STANDARD.EXE, SAMPLE.EXE, BSTANDRD.EXE and BSAMPLE.EXE MAKEFILE in the SLDRIVER directory uses MK, the Salford version of the 'make' utility. It must be invoked from within that directory. E.g. typing mk standard.exe creates or updates STANDARD.EXE, while mk standard runs it, creating it if necessary. Since the source files live in several directories and contain modules, we must be careful to make the module information (.MOD files in Salford system) accessible to the compiler. This has been done by always invoking the compiler from the SLDRIVER directory so that all the .MOD files are put in this directory. 6.A TRIAL RUN Each run of the interactive version of the program produces a 'playback' file PLAYBACK.DAT containing the sequence of commands and data input by the user, which can be re-input to the batch version of the program. File SAMPLRUN.DAT in the SLDRIVER directory is a copy of the playback file produced by a trial run of STANDARD.EXE. It tests each of the four solvers in turn on Problem 1 in the 'Standard' problem set: first to find eigenvalues of indices 0 to 10; then to find eigenvalues and eigenfunction values of indices 9 to 10. Finally it tests SLEDGE's Spectral Density Function facility on Problem 48. Type bstandrd < samplrun.dat to test the program bstandrd.exe. Then type standard to test the interactive version, and give it the same sequence of inputs (you have to press ENTER at various points where the batch version does not require this.) In either case you should see output essentially identical to that in the file SAMPLRUN.OUT in the SLDRIVER directory. 7.DOCUMENTATION This is in the LATEX directory. Compiling SLDRIVER.TEX (a LaTeX 2.09 document) will produce the user guide. SHAR_EOF fi # end of overwriting check if test -f 'salftn90.mk' then echo shar: will not over-write existing file "'salftn90.mk'" else cat << SHAR_EOF > 'salftn90.mk' # File: Makefile for SLDRIVER package, revision of Aug 1998 #!Using LINK77 which needs .lnk files (instead of SLINK) # Purpose: # Manage the files making up the SLDRIVER package, when using the # Salford FTN90 system under DOS/Windows 3.1 or Windows 95 # Author : John Pryce, RMCS, Shrivenham, Swindon, UK #(pryce@rmcs.cranfield.ac.uk) # Disclaimer: # This file is provided as is, with no claim that it operates # correctly in all circumstances. # References: # SLDRIVER User Guide & Tutorial, RMCS Tech. Rep. SEAS/CISE/96/JDP01 # ###################### INSTRUCTIONS FOR USE ############################## # This file must be placed in, and invoked from, the 'sldriver' directory #under the home directory of the SL package. This ensures that the #'.$M' (module specification) files are put in this directory. #2.Set SL to the home directory of the SL package: SL=C:\sl4.1 BIN=$(SL)\SLDRIVER # #3.Define the compiler & linking mechanism F90=FTN90 LINK=LINK77 #4.If desired, reset these compilation options. # /BINARY stuff is needed so object file goes in current directory # even if source isn't. #OPTS=/CHECK /SILENT /ERRORLOG /BINARY $(BIN)\$@ OPTS=/CHECK_ALL /SILENT /BINARY $(BIN)\$@ #5.Various file extensions: F=for # Fortran (fixed format) file M=mod # module specification file: O=obj # object file X=exe # executable .SUFFIXES: .$F .$O ## General compilation rule .$F.$O: $(F90) $(OPTS) $< #The following can be typed at the DOS prompt: #COMMAND |EFFECT #------------------------------------------------------------------------ #mk |makes standard.exe if necessary, and launches it. #mk standard.exe |as above but without launching it. #mk sample |makes sample.exe if necessary, and launches it. #mk bstandrd.exe |makes bstandrd.exe if necessary, doesn't launch it. #mk sample.exe |as above but without launching it. #etc... (the above are the most useful). ######################################################################### ## Run the main executable, which uses the STANDARD problem set standard: standard.$X RUN77 standard.$X standard.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ safeio.$O sltstpak.$O standard.$O # $(LINK) -out:standard.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O safeio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O standard.$O LINK77 standard.lnk ## Alternative executable, using SAMPLE problem set sample: sample.$X RUN77 sample.$X sample.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ safeio.$O sltstpak.$O sample.$O # $(LINK) -out:sample.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O safeio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O sample.$O LINK77 sample.lnk ## Batch-run executable, using STANDARD problem set bstandrd.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ batchio.$O sltstpak.$O standard.$O # $(LINK) -out:standard.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O batchio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O standard.$O LINK77 bstandrd.lnk ## Batch-run executable, using SAMPLE problem set bsample.$X: sldriver.$O slutil.$O solvrs.$O dbmod.$O \ batchio.$O sltstpak.$O sample.$O # $(LINK) -out:sample.$X sldriver.$O slutil.$O solvrs.$O dbmod.$O batchio.$O \ # sltstvar.$O slpset.$O \ # sledge.$O sleign.$O sleign2.$O marcopak.$O \ # sltstpak.$O sample.$O LINK77 bsample.lnk ## The main-program source sldriver.$O: sldriver.$F dbmod.$O safeio.$O slutil.$O solvrs.$O \ slconsts.$O slpset.$O sltstpak.$O $(F90) $(OPTS) sldriver.$F ## The database facilities dbmod.$O:dbmod.$F safeio.$O slutil.$O slconsts.$O slpset.$O $(F90) $(OPTS) dbmod.$F ## The solver interfaces solvrs.$O: solvrs.$F safeio.$O slutil.$O slconsts.$O \ sltstpak.$O sledge.$O sleign.$O marcopak.$O sleign2.$O $(F90) $(OPTS) solvrs.$F ## Utilities #safeio.$O: safeio.$F #$(F90) $(OPTS) safeio.$F #batchio.$O:batchio.$F #$(F90) $(OPTS) batchio.$F #slutil.$O: slutil.$F #$(F90) $(OPTS) slutil.$F #slconsts.$O: slconsts.$F #$(F90) $(OPTS) slconsts.$F #slpset.$O: slpset.$F #$(F90) $(OPTS) slpset.$F ## SLTSTPAK: problem/solver interface routines sltstpak.$O: sltstpak.$F sltstvar.$O testmod.$M $(F90) $(OPTS) sltstpak.$F ## Problem-set routines ##BUG HERE! I don't know how to make MK distinguish between different ##problem sets, so at present it only seems to work if one changes this ##rule & deletes standard.$O & sample.$O before running 'make' to ##create the executable for a different problem set. ##(TESTMOD.MOD gets out of kilter otherwise?) testmod.$M: standard.$O ##testmod.$M: sample.$O standard.$O: $(SL)\PROBSETS\standard.$F sltstvar.$O $(F90) $(OPTS) $(SL)\PROBSETS\standard.$F sample.$O: $(SL)\PROBSETS\sample.$F sltstvar.$O $(F90) $(OPTS) $(SL)\PROBSETS\sample.$F ## The solvers. They live in their own directories. ## Compilation is to be done from within the SLDRIVER directory ## so that the .$O and .$M files get stored there. sledge.$O: $(SL)\SLEDGE\sledgemd.$F $(F90) $(OPTS) $(SL)\SLEDGE\sledgemd.$F sleign.$O: $(SL)\SLEIGN\sleignmd.$F $(F90) $(OPTS) $(SL)\SLEIGN\sleignmd.$F marcopak.$O: $(SL)\MARCOPAK\marcomod.$F $(F90) $(OPTS) $(SL)\MARCOPAK\marcomod.$F sleign2.$O:$(SL)\SLEIGN2\sleig2md.$F $(F90) $(OPTS) $(SL)\SLEIGN2\sleig2md.$F SHAR_EOF fi # end of overwriting check if test -f 'sample.lnk' then echo shar: will not over-write existing file "'sample.lnk'" else cat << SHAR_EOF > 'sample.lnk' *Make SAMPLE.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo safeio lo ..\probsets\sample file sample.exe SHAR_EOF fi # end of overwriting check if test -f 'slattrib.bat' then echo shar: will not over-write existing file "'slattrib.bat'" else cat << SHAR_EOF > 'slattrib.bat' rem Remove archive attribute from all files (recursing into subdirectories) attrib -a *.*/s rem Now put back for the ones we want attrib +a slattrib.bat attrib +a slpkzip.bat attrib +a slsetup.bat attrib +a sltar.bat attrib +a librarie.dir attrib +a read.me attrib +a d02kef\d02kef.doc attrib +a d02kef\d02kef.for attrib +a d02kef\d02kef.lnk attrib +a latex\slref.bib attrib +a latex\graph1.eps attrib +a latex\graph2.eps attrib +a latex\jdpdefs.tex attrib +a latex\epsf.tex attrib +a latex\esub2acm.sty attrib +a latex\sldriver.tex attrib +a latex\sldriver.bbl attrib +a latex\sltstalg.tex attrib +a latex\sltstalg.bbl attrib +a latex\sltstpak.tex attrib +a latex\sltstpak.bbl attrib +a marcopak\marcomod.for attrib +a marcopak\marcomod.lnk attrib +a probsets\sample.for attrib +a probsets\standard.for attrib +a sldriver\makefile attrib +a sldriver\samplrun.dat attrib +a sldriver\samplrun.out attrib +a sldriver\batchio.for attrib +a sldriver\dbmod.for attrib +a sldriver\safeio.for attrib +a sldriver\slconsts.for attrib +a sldriver\sldriver.for attrib +a sldriver\slpset.for attrib +a sldriver\sltstpak.for attrib +a sldriver\sltstvar.for attrib +a sldriver\slutil.for attrib +a sldriver\solvrs.for attrib +a sldriver\errflags.hlp attrib +a sldriver\initpuff.hlp attrib +a sldriver\slbrows.hlp attrib +a sldriver\sld02k.hlp attrib +a sldriver\slhelp0.hlp attrib +a sldriver\bsample.lnk attrib +a sldriver\bstandrd.lnk attrib +a sldriver\sample.lnk attrib +a sldriver\standard.lnk attrib +a sldriver\evsimp.for attrib +a sldriver\evsimp.lnk attrib +a sldriver\sample\keep.me attrib +a sldriver\standard\keep.me attrib +a sldriver\standard\truevals\evtru.01 attrib +a sldriver\standard\truevals\evtru.02 attrib +a sldriver\standard\truevals\evtru.05 attrib +a sldriver\standard\truevals\evtru.07 attrib +a sldriver\standard\truevals\evtru.15 attrib +a sldriver\standard\truevals\evtru.18 attrib +a sldriver\standard\truevals\evtru.19 attrib +a sldriver\standard\truevals\evtru.20 attrib +a sldriver\standard\truevals\evtru.21 attrib +a sldriver\standard\truevals\evtru.22 attrib +a sldriver\standard\truevals\evtru.23 attrib +a sldriver\standard\truevals\evtru.28 attrib +a sldriver\standard\truevals\evtru.29 attrib +a sldriver\standard\truevals\evtru.30 attrib +a sldriver\standard\truevals\evtru.32 attrib +a sldriver\standard\truevals\evtru.34 attrib +a sldriver\standard\truevals\evtru.35 attrib +a sldriver\standard\truevals\evtru.36 attrib +a sldriver\standard\truevals\evtru.40 attrib +a sldriver\standard\truevals\evtru.41 attrib +a sldriver\standard\truevals\evtru.43 attrib +a sldriver\standard\truevals\eftru.01 attrib +a sldriver\standard\truevals\eftru.02 attrib +a sldriver\standard\truevals\eftru.07 attrib +a sldriver\standard\truevals\eftru.15 attrib +a sldriver\standard\truevals\eftru.20 attrib +a sldriver\standard\truevals\eftru.21 attrib +a sldriver\standard\truevals\eftru.22 attrib +a sldriver\standard\truevals\eftru.28 attrib +a sldriver\standard\truevals\eftru.29 attrib +a sldriver\standard\truevals\eftru.35 attrib +a sldriver\standard\truevals\eftru.36 attrib +a sldriver\standard\truevals\eftru.41 attrib +a sldriver\standard\truevals\sdtru.56 attrib +a sldriver\standard\truevals\sdtru.57 attrib +a sledge\sledgemd.for attrib +a sledge\sledgemd.lnk attrib +a sleign\sleignmd.for attrib +a sleign\sleignmd.lnk attrib +a sleign2\sleig2md.for attrib +a sleign2\sleig2md.lnk attrib +a sleign2\extras\sleign2.doc attrib +a sleign2\extras\drived.for attrib +a sleign2\extras\makepqwd.for attrib +a sleign2\extras\sleign2d.for attrib +a sleign2\extras\xamplesd.for attrib +a sleign2\extras\sleign2.hlp attrib +a sleign2\extras\sleign2x.tex attrib +a sleign2\extras\sleign2.txt SHAR_EOF fi # end of overwriting check if test -f 'sledgemd.lnk' then echo shar: will not over-write existing file "'sledgemd.lnk'" else cat << SHAR_EOF > 'sledgemd.lnk' *Make DLL for SLEDGEMD (SLEDGE made into a module) *Only SLEDGE & INTERV are visible from outside liboffset 43000000 lo sledgemd file sledge.lib SHAR_EOF fi # end of overwriting check if test -f 'sleig2md.lnk' then echo shar: will not over-write existing file "'sleig2md.lnk'" else cat << SHAR_EOF > 'sleig2md.lnk' *Make DLL for SLEIG2MD (SLEIGN2 as a module) *None of its subordinate routines are to be visible from outside map sleig2md.map xref sleig2md.xrf liboffset 45000000 lo sleig2md file sleign2.lib SHAR_EOF fi # end of overwriting check if test -f 'sleignmd.lnk' then echo shar: will not over-write existing file "'sleignmd.lnk'" else cat << SHAR_EOF > 'sleignmd.lnk' *Make DLL for SLEIGNMD (SLEIGN as a module) *Only routine SLEIGN is visible from outside liboffset 44000000 lo sleignmd file sleign.lib SHAR_EOF fi # end of overwriting check if test -f 'slpkzip.bat' then echo shar: will not over-write existing file "'slpkzip.bat'" else cat << SHAR_EOF > 'slpkzip.bat' rem Batchfile to create distribution archive of SLDRIVER package rem It must live in the top level directory of the package rem (usually C:\SL) and this must be the current directory when it rem is called rem It forms, in this same directory, a self-extracting PKZIP 2.05g rem archive of the files in the package. rem This is left in the file rem slzip.exe rem in the directory referred to by %TEMP%. rem If the lines at the end are uncommented it copies to drive A: rem - this zip file rem - the uncompressed READ.ME file rem - the PKZIP software (not neded for extraction but useful!) rem !! Ensure disk in A: is blank to start with !! rem !!! CONFIGURATION DATA !!! set PK=C:\PK set TEMP=C:\TEMP set PATH=%PK%;%PATH% rem Set 'archive' attribute on all files to be stored & on no others: call slattrib pkzip slzip -rp -i *.* zip2exe slzip del slzip.zip move slzip.exe %TEMP%\slzip.exe rem copy read.me a: rem copy %TEMP%\slzip.exe a:\ rem xcopy %PK% a:\pk\ /s SHAR_EOF fi # end of overwriting check if test -f 'slsetup.bat' then echo shar: will not over-write existing file "'slsetup.bat'" else cat << SHAR_EOF > 'slsetup.bat' rem COPYRIGHT J D PRYCE 1998 rem PURPOSE rem Batchfile to do all the compilation & linking with Salford system rem To be adapted for other Fortran systems. rem USAGE rem To be placed in the top-level directory of the package (usually rem c:\sl) and invoked from there. rem NOTES rem This is provided as an alternative to the MAKEFILE but the latter rem is more convenient when it works. rem ADJUST THE FOLLOWING CONFIGURATION SETTINGS AS NEEDED: rem COPT = options for Salford FTN90 compiler set COPT=/ca/debug rem First we move to the main source-files directory. All compilation rem is done there so that .MOD files are placed there. cd sldriver ftn90 ..\marcopak\marcomod.for%COPT% cd ..\marcopak link77 marcomod.lnk cd ..\sldriver ftn90 ..\sledge\sledgemd.for%COPT% cd ..\sledge link77 sledgemd.lnk cd ..\sldriver ftn90 ..\sleign\sleignmd.for%COPT% cd ..\sleign link77 sleignmd.lnk cd ..\sldriver ftn90 ..\sleign2\sleig2md.for%COPT% cd ..\sleign2 link77 sleig2md.lnk cd ..\sldriver ftn90 slconsts.for%COPT% ftn90 slpset.for%COPT% ftn90 safeio.for%COPT% ftn90 batchio.for%COPT% ftn90 slutil.for%COPT% ftn90 dbmod.for%COPT% ftn90 sltstvar.for%COPT% ftn90 ..\probsets\standard.for%COPT% ftn90 ..\probsets\sample.for%COPT% ftn90 sltstpak.for%COPT% ftn90 solvrs.for%COPT% ftn90 sldriver.for%COPT% link77 standard.lnk link77 sample.lnk link77 bstandrd.lnk link77 bsample.lnk SHAR_EOF fi # end of overwriting check if test -f 'sltar.bat' then echo shar: will not over-write existing file "'sltar.bat'" else cat << SHAR_EOF > 'sltar.bat' rem Batchfile to create Unix format distrib archive of SLDRIVER package rem It forms a new directory structure under \SLUNIX holding the rem DOS2UNIX'ed versions of the files, which it then TAR's and GZIP's rem into a file SLTAR.Z in the main SL directory. rem Uses the DOS versions of Unix tools TAR GZIP etc., must be in Path! rem *********CHANGE THIS CONFIGURATION INFO IF NECESSARY*************** set SU=C:\slunix set SL=C:\sl4.1 rem Set 'archive' attribute on all files to be stored & on no others: cd %SL% call slattrib deltree %SU% md %SU% rem form copy of all these files xcopy %SL% %SU%\ /a/s cd %SU% for %%f in (*.*) do call d2u %%f cd %SU%\d02kef for %%f in (*.*) do call d2u %%f cd %SU%\marcopak for %%f in (*.*) do call d2u %%f cd %SU%\sledge for %%f in (*.*) do call d2u %%f cd %SU%\sleign for %%f in (*.*) do call d2u %%f cd %SU%\sleign2 for %%f in (*.*) do call d2u %%f cd %SU%\sleign2\extras for %%f in (*.*) do call d2u %%f cd %SU%\sldriver for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\standard for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\standard\truevals for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\sample for %%f in (*.*) do call d2u %%f cd %SU%\sldriver\sample\truevals for %%f in (*.*) do call d2u %%f cd %SU%\probsets for %%f in (*.*) do call d2u %%f cd %SU%\latex for %%f in (*.*) do call d2u %%f rem all dos2unix'ed, now archive them cd %SU% tar -f %SL%\sl.tar -cv . cd %SL% gzip -c sl.tar > sltar.z SHAR_EOF fi # end of overwriting check if test -f 'standard.lnk' then echo shar: will not over-write existing file "'standard.lnk'" else cat << SHAR_EOF > 'standard.lnk' *Make STANDARD.EXE using the object files listed *and also the DLLs for the solvers: * SLEDGE * SLEIGN * SL02F * SLEIGN2 lo sldriver lo slutil lo solvrs lo dbmod lo slconsts lo sltstvar lo slpset lo sltstpak lo safeio lo ..\probsets\standard file standard.exe SHAR_EOF fi # end of overwriting check if test -f 'standard\sledge48.m' then echo shar: will not over-write existing file "'standard\sledge48.m'" else cat << SHAR_EOF > 'standard\sledge48.m' %Classification of endpoints: A = F F F F B = T T T F sdf=[ ... 0.00000000000000 0.00000000000000 1.00000000000000 0.00000000000000 2.22222222222222 0.00000000000000 3.75000000000000 0.392099772362319 5.71428571428572 1.35834702624313 8.33333333333333 3.15859111742592 12.0000000000000 6.44669639246795 17.5000000000000 12.5234199239914 26.6666666666667 25.5692176083643 45.0000000000000 59.3153712664915 100.000000000000 205.774698088845 ]; lambda=sdf(:,1); rho=sdf(:,2); %sledge/1 48 1.00D-04 9 10 14.5991 3447308 SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'Src' then mkdir 'Src' fi cd 'Src' if test ! -d 'Fortran90' then mkdir 'Fortran90' fi cd 'Fortran90' if test ! -d 'Dp' then mkdir 'Dp' fi cd 'Dp' if test ! -d 'd02kef' then mkdir 'd02kef' fi cd 'd02kef' if test -f 'd02kef.f' then echo shar: will not over-write existing file "'d02kef.f'" else cat << SHAR_EOF > 'd02kef.f' SUBROUTINE C05AZF(X,Y,FX,TOLX,IR,C,IND,IFAIL) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-496 (AUG 1986). C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='C05AZF') C .. Scalar Arguments .. DOUBLE PRECISION FX, TOLX, X, Y INTEGER IFAIL, IND, IR C .. Array Arguments .. DOUBLE PRECISION C(17) C .. Local Scalars .. DOUBLE PRECISION AB, DIFF, DIFF1, DIFF2, REL, RMAX, TOL, TOL1 INTEGER I LOGICAL T C .. Local Arrays .. CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION X02AJF, X02AKF INTEGER P01ABF EXTERNAL X02AJF, X02AKF, P01ABF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, DBLE, SQRT, INT C .. Executable Statements .. I = 0 IF ((IND.GT.0 .AND. IND.LE.4) .OR. IND.EQ.-1) GO TO 20 C USER NOT CHECKED IND OR CHANGED IT I = 2 IND = 0 GO TO 640 20 IF (TOLX.GT.0.D0 .AND. (IR.EQ.0 .OR. IR.EQ.1 .OR. IR.EQ.2)) * GO TO 40 I = 3 IND = 0 GO TO 640 40 REL = 1.D0 AB = 1.D0 IF (IR.EQ.1) REL = 0.D0 IF (IR.EQ.2) AB = 0.D0 IF (IND.EQ.-1) GO TO 80 GO TO (60,100,180,480) IND 60 C(3) = X IND = 2 RETURN 80 C(3) = X 100 IF (FX.NE.0.D0) GO TO 140 120 Y = X IND = 0 I = 0 GO TO 640 140 C(4) = FX C(15) = ABS(FX) C(16) = 0.D0 X = Y Y = C(3) C(2) = C(4) C(5) = X IF (IND.EQ.-1) GO TO 160 IND = 3 RETURN 160 FX = C(1) IND = 3 180 IF (FX.EQ.0.D0) GO TO 120 IF (SIGN(1.D0,FX).NE.SIGN(1.D0,C(2))) GO TO 200 IND = 0 I = 1 GO TO 640 200 C(6) = FX C(13) = SQRT(X02AJF()) C(15) = MAX(C(15),ABS(FX)) C(14) = X02AKF() C(16) = 0.0D0 220 C(1) = C(5) C(2) = C(6) C(17) = 0.D0 240 IF (ABS(C(2)).GE.ABS(C(4))) GO TO 280 IF (C(1).EQ.C(5)) GO TO 260 C(7) = C(5) C(8) = C(6) 260 C(5) = C(3) C(6) = C(4) X = C(1) C(3) = X C(4) = C(2) C(1) = C(5) C(2) = C(6) 280 TOL = 0.5D0*TOLX*MAX(AB,REL*ABS(C(3))) TOL1 = 2.0D0*X02AJF()*MAX(AB,REL*ABS(C(3))) DIFF2 = 0.5D0*(C(1)-C(3)) C(12) = DIFF2 DIFF2 = DIFF2 + C(3) IF (C(12).EQ.0.D0) GO TO 340 IF (ABS(C(12)).LE.TOL) GO TO 580 IF (ABS(C(12)).LE.TOL1) GO TO 340 IF (C(17).LT.2.5D0) GO TO 300 C(11) = C(12) GO TO 460 300 TOL = TOL*SIGN(1.D0,C(12)) DIFF1 = (C(3)-C(5))*C(4) IF (C(17).GT.1.5D0) GO TO 320 DIFF = C(6) - C(4) GO TO 380 320 IF (C(7).NE.C(3) .AND. C(7).NE.C(5)) GO TO 360 340 IND = 0 I = 5 GO TO 640 360 C(9) = (C(8)-C(4))/(C(7)-C(3)) C(10) = (C(8)-C(6))/(C(7)-C(5)) DIFF1 = C(10)*DIFF1 DIFF = C(9)*C(6) - C(10)*C(4) 380 IF (DIFF1.GE.0.D0) GO TO 400 DIFF1 = -DIFF1 DIFF = -DIFF 400 IF (ABS(DIFF1).GT.C(14) .AND. DIFF1.GT.DIFF*TOL) GO TO 420 C(11) = TOL GO TO 460 420 IF (DIFF1.GE.C(12)*DIFF) GO TO 440 C(11) = DIFF1/DIFF GO TO 460 440 C(11) = C(12) 460 C(7) = C(5) C(8) = C(6) C(5) = C(3) C(6) = C(4) C(3) = C(3) + C(11) X = C(3) Y = C(1) IND = 4 RETURN 480 IF (FX.EQ.0.D0) GO TO 120 C(4) = FX RMAX = ABS(FX) IF (C(13)*RMAX.LE.C(15)) GO TO 500 IF (C(16).EQ.1.D0) C(16) = -1.D0 IF (C(16).EQ.0.D0) C(16) = 1.D0 GO TO 520 500 C(16) = 0.D0 520 IF (C(2).GE.0.D0) GO TO 540 T = C(4) .LE. 0.D0 GO TO 560 540 T = C(4) .GE. 0.D0 560 IF (T) GO TO 220 I = INT(C(17)+0.1D0) I = I + 1 IF (C(11).EQ.C(12)) I = 0 C(17) = DBLE(I) GO TO 240 580 IF (C(16).GE.0.D0) GO TO 600 I = 4 GO TO 620 600 Y = C(1) I = 0 620 IND = 0 640 IFAIL = P01ABF(IFAIL,I,SRNAME,0,P01REC) RETURN END SUBROUTINE D02KAY(NIT,IFLAG,ELAM,FINFO) C MARK 11.5 RELEASE. NAG COPYRIGHT 1986. C DUMMY MONIT ROUTINE FOR D02KAF, D02KDF OR D02KEF C .. Scalar Arguments .. DOUBLE PRECISION ELAM INTEGER IFLAG, NIT C .. Array Arguments .. DOUBLE PRECISION FINFO(15) C .. Executable Statements .. RETURN END DOUBLE PRECISION FUNCTION D02KDS(X) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C EXP AVOIDING UNDERFLOW ERROR C .. Scalar Arguments .. DOUBLE PRECISION X C .. External Functions .. DOUBLE PRECISION X02AMF EXTERNAL X02AMF C .. Intrinsic Functions .. INTRINSIC EXP, LOG C .. Executable Statements .. D02KDS = 0.D0 IF (X.GE.LOG(X02AMF())) D02KDS = EXP(X) RETURN END SUBROUTINE D02KDT(V,Y,PYP,K,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C .. Scalar Arguments .. DOUBLE PRECISION PYP, Y INTEGER IFAIL, K C .. Array Arguments .. DOUBLE PRECISION V(3) C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, PHI, R2 C .. Intrinsic Functions .. INTRINSIC LOG, ATAN2, DBLE C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. B = V(1) IF (B.LE.ZER) GO TO 100 R2 = Y*Y*B + PYP*PYP/B IF (R2.EQ.ZER) GO TO 80 V(3) = LOG(R2) PHI = ATAN2(Y*B,PYP) IF (K.GE.0) GO TO 20 C INITIAL BOUNDARY CONDITION IF (PHI.LT.ZER) PHI = PHI + PI IF (PHI.GE.PI) PHI = PHI - PI GO TO 40 C FINAL BOUNDARY CONDITION 20 IF (PHI.LE.ZER) PHI = PHI + PI IF (PHI.GT.PI) PHI = PHI - PI PHI = PHI + DBLE(K)*PI 40 V(2) = TWO*PHI IFAIL = 0 60 RETURN 80 IFAIL = 1 GO TO 60 100 IFAIL = 2 GO TO 60 END DOUBLE PRECISION FUNCTION D02KDU(X,COEFFN) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C COEFFN C .. Scalar Arguments .. DOUBLE PRECISION X C .. Subroutine Arguments .. EXTERNAL COEFFN C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, * TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION DQDL, P, Q C .. Intrinsic Functions .. INTRINSIC SQRT C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, * PSIGN, MINSC, BP, YL, YR, JINT C .. Executable Statements .. CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) Q = P*Q P = MINSC*P P = P*P D02KDU = SQRT(SQRT(P*P+Q*Q)) RETURN END SUBROUTINE D02KDV(Y,BNEW,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-499 (AUG 1986). C .. Scalar Arguments .. DOUBLE PRECISION BNEW INTEGER IFAIL C .. Array Arguments .. DOUBLE PRECISION Y(3) C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, BUP, CPHI, SPHI C .. Intrinsic Functions .. INTRINSIC LOG, ATAN2, COS, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. B = Y(1) IF (B.LE.ZER .OR. BNEW.LE.ZER) GO TO 20 Y(1) = BNEW BUP = B/BNEW B = BNEW/B CPHI = COS(Y(2)) SPHI = SIN(Y(2)) Y(2) = Y(2) + TWO*ATAN2((B-ONE)*SPHI,B+ONE-(B-ONE)*CPHI) Y(3) = Y(3) + LOG((B+BUP-(B-BUP)*CPHI)/TWO) IFAIL = 0 RETURN 20 IFAIL = 1 RETURN END SUBROUTINE D02KDW(N,X,V,F,COEFFN,COEFF1,M,ARR) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 8 REVISED. IER-227 (APR 1980). C MARK 11.5(F77) REVISED. (SEPT 1985.) C POLYGONAL SCALING METHOD C SEVERAL FORMULAE FOR P,Q OVER RANGE,SELECTED BY JINT C COEFF1, COEFFN C .. Scalar Arguments .. DOUBLE PRECISION X INTEGER M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), F(N), V(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION B, C, DQDL, P, Q, S, T1, T2 C .. Intrinsic Functions .. INTRINSIC ABS, COS, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) C TEST IF P(X) WAS 0 OR CHANGED SIGN EARLIER (PSIGN=0) C OR AT THIS CALL (PSIGN .NE. 0 BUT P*PSIGN .LE. 0) IF (P*PSIGN.LE.ZER) GO TO 20 IF (P.LT.ZER) Q = -Q P = ABS(P) B = V(1) T1 = B/P - Q/B T2 = BP/B C = COS(V(2)) S = SIN(V(2)) F(1) = BP F(2) = B/P + Q/B + T1*C + T2*S F(3) = -T2*C + T1*S RETURN 20 F(1) = ZER F(2) = ZER F(3) = ZER PSIGN = ZER RETURN END SUBROUTINE D02KDY(X,XEND,N,Y,CIN,TOL,FCN,COMM,CONST,COUT,W,IW,IW1, * COEFFN,COEFF1,ARR,M,IFAIL) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 7F REVISED. IER-209 (OCT 1979) C MARK 7G REVISED. IER-216 (FEB 1980) C MARK 8 REVISED. IER-227 (APR 1980), IER-246 (MAY 1980). C MARK 8A REVISED. IER-251 (AUG 1980). C MARK 11 REVISED. IER-419 (FEB 1984). C MARK 11D REVISED. IER-469 (NOV.1985). C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C MARK 13 REVISED. IER-633 (APR 1988). C MARK 14 REVISED. IER-715 (DEC 1989). C MARK 14B REVISED. IER-837 (MAR 1990). C INTEGRATES THE N DIFFERENTIAL EQUATIONS DEFINED C BY FCN FROM X TO XEND. THE VALUES AT X C OF THE SOLUTION MUST BE GIVEN IN Y C AND THE CALCULATED VALUES ARE RETURNED C IN THE SAME VECTOR. THE LOCAL ERROR C PER STEP IS CONTROLLED BY TOL. VARIOUS C OPTIONS ARE CONTROLLED BY CIN AND C THE WORKSPACE W WHICH MUST HAVE C FIRST DIMENSION N1 .GE. N AND C SECOND DIMENSION .GE.7. USEFUL C OUTPUT IS ALSO RETURNED IN CIN AND C W, PERMITTING EFFICIENT INTEGRATION. C C COEFF1, COEFFN, FCN C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='D02KDY') C .. Scalar Arguments .. DOUBLE PRECISION TOL, X, XEND INTEGER IFAIL, IW, IW1, M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), CIN(6), COMM(5), CONST(3), COUT(14), * W(IW,IW1), Y(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN, FCN C .. Local Scalars .. DOUBLE PRECISION COUT12, EXP, EXPI, FAC, FAC1, FAC2, FAC3, FAC4, * FAC5, FAC6, FAC7, FAC8, FAC9, FNORM, HEST, * HEST1, RAT, RAT1, S, SMALL, T, TOLEST, XORIG, * YNORM INTEGER I, I1, IEND, IND, ISIG, ISTEP, J, K, N2 LOGICAL CALLS, INIT, INTER, REDUCE, START, TEST C .. Local Arrays .. CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION D02PAY, X02AJF, X02AKF INTEGER P01ABF EXTERNAL D02PAY, X02AJF, X02AKF, P01ABF C .. External Subroutines .. EXTERNAL D02KDZ C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, DBLE, SQRT, INT C .. Save statement .. SAVE START C .. Data statements .. DATA FAC/10.D0/, FAC1/0.1D0/, FAC3/2.D0/, * FAC4/0.8D0/, FAC5/0.25D0/, FAC6/0.25D0/, * FAC8/0.2D0/, FAC9/0.2D0/ C .. Executable Statements .. C C SET CONSTANTS C XORIG = X HEST1 = 0.D0 INIT = .FALSE. EXP = FAC6 EXPI = FAC5 IND = 0 ISIG = 0 INTER = .FALSE. ISTEP = 2 N2 = 7 TEST = .FALSE. CALLS = .FALSE. COUT12 = 0.D0 IF (CIN(1).NE.7.D0) GO TO 20 COUT12 = COUT(12) CIN(1) = 1.D0 GO TO 40 20 COUT(12) = 0.D0 40 IF (CIN(1).EQ.0.D0) GO TO 100 DO 60 I = 1, 3 IF (COMM(I).NE.0.D0) GO TO 100 60 CONTINUE IF (CIN(1).NE.5.D0 .OR. COMM(4).LE.0.D0) GO TO 80 TEST = .TRUE. IF (CIN(2).GE.3.D0) GO TO 360 GO TO 860 80 IF (CIN(1).NE.6.D0 .OR. COMM(4).GE.0.D0) GO TO 100 TEST = .TRUE. IF (CIN(2).GE.3.D0) GO TO 360 GO TO 720 C C ARGUMENT TESTS C 100 IF (IW.GE.N .AND. N.GT.0 .AND. IW1.GE.7) GO TO 140 C WORKSPACE WRONGLY DIMENSIONED 120 IND = 1 CIN(1) = -1.D0 GO TO 2620 140 IF (TOL.GT.0.D0) GO TO 160 C ERROR TOLERANCE NOT POSITIVE IND = 1 CIN(1) = -2.D0 GO TO 2620 160 IF (CIN(1).EQ.0.D0) GO TO 180 IF (CIN(1).EQ.1.D0) GO TO 240 IF (CIN(1).GE.2.D0 .AND. CIN(1).LE.6.D0) GO TO 280 C CIN(1) OUT OF RANGE IND = 1 CIN(1) = -3.D0 GO TO 2620 C C SET INPUT AND OUTPUT PARAMETERS C 180 DO 200 I = 2, 5 CIN(I) = 0.D0 200 CONTINUE DO 220 I = 1, 4 COMM(I) = 0.D0 220 CONTINUE CONST(1) = 0.D0 CONST(2) = FAC3 CONST(3) = FAC4 240 COUT(11) = X02AJF() SMALL = X02AKF() COUT(13) = ABS(CIN(3)) COUT(14) = ABS(CIN(4)) CIN(6) = 0.D0 ISTEP = 0 S = 0.D0 DO 260 I = 1, N S = MAX(S,ABS(Y(I))) 260 CONTINUE INIT = .TRUE. COUT(1) = 0.D0 COUT(2) = 0.D0 COUT(3) = 0.D0 COUT(4) = X COUT(5) = X COUT(6) = S COUT(7) = S COUT(8) = 0.D0 COUT(9) = 0.D0 COUT(10) = 0.D0 IF (CIN(1).EQ.0.D0) GO TO 800 GO TO 320 C C ARGUMENT TESTS FOR CIN(1).GT.0. C 280 IF ((COUT(4).GE.COUT(5) .AND. X.LT.COUT(4)) .OR. (COUT(4) * .LT.COUT(5) .AND. X.GE.COUT(4))) GO TO 300 IF (X.EQ.XEND) GO TO 320 IF ((X.GE.COUT(4) .AND. XEND.GE.X) .OR. (X.LT.COUT(4) * .AND. XEND.LT.X)) GO TO 320 300 CIN(1) = 1.D0 INTER = .TRUE. GO TO 240 320 IF (CIN(2).EQ.0.D0 .OR. CIN(2).EQ.1.D0 .OR. CIN(2) * .EQ.2.D0 .OR. CIN(2).EQ.3.D0 .OR. CIN(2).EQ.4.D0) GO TO 340 C CIN(2) OUT OF RANGE IND = 1 CIN(1) = -4.D0 GO TO 2620 340 IF (CIN(2).LT.3.D0) GO TO 420 360 IF (IW1.LT.8) GO TO 120 N2 = 8 DO 380 I = 1, N IF (W(I,7).GT.0.D0) GO TO 380 C SCALING OF TOLERANCE NON-POSITIVE IND = 1 CIN(1) = -5.D0 GO TO 2620 380 CONTINUE IF (CIN(2).EQ.4.D0) GO TO 420 IF (IW1.LT.9) GO TO 120 N2 = 9 DO 400 I = 1, N IF (Y(I).NE.0.D0 .OR. W(I,8).GT.0.D0) GO TO 400 C FLOOR ZERO AND SOLUTION ZERO IN SAME COMPONENT IND = 1 CIN(1) = -6.D0 GO TO 2620 400 CONTINUE 420 IF ( .NOT. TEST) GO TO 440 IF (COMM(4).LT.0.D0) GO TO 720 GO TO 860 440 IF (CONST(1).EQ.0.D0) GO TO 480 IF (CONST(1).EQ.1.D0) GO TO 460 C CONST(1) INVALID IND = 1 CIN(1) = -7.D0 GO TO 2620 460 EXPI = FAC9 EXP = FAC8 480 IF (CONST(2).GE.0.D0 .AND. CONST(3).GE.0.D0) GO TO 520 C CONST(2) OR CONST(3) INVALID 500 IND = 1 CIN(1) = -8.D0 GO TO 2620 520 IF (CONST(2).EQ.0.D0) CONST(2) = FAC3 IF (CONST(3).EQ.0.D0) CONST(3) = FAC4 IF (CONST(2).LE.1.D0/CONST(3) .OR. CONST(2).LE.1.D0 .OR. CONST(3) * .GE.1.D0) GO TO 500 IF (COMM(1).GE.0.D0) GO TO 540 C COMM(1) OUT OF RANGE IND = 1 CIN(1) = -9.D0 GO TO 2620 540 IF (COMM(1).GT.0.D0) CALLS = .TRUE. IF (COMM(2).EQ.0.D0) GO TO 580 IF (COMM(2).GT.0.D0) GO TO 560 C COMM(2) OUT OF RANGE IND = 1 CIN(1) = -10.D0 GO TO 2620 560 IF (COUT(6).LT.COMM(2)) GO TO 580 C INITIAL VECTOR TOO LARGE IND = 1 COMM(2) = 0.D0 CIN(1) = -11.D0 GO TO 2620 580 IF (COMM(3).EQ.0.D0) GO TO 640 IF (IW1.LT.10) GO TO 120 N2 = 8 IF (CIN(2).EQ.3.D0) N2 = 11 IF (IW1.LT.N2) GO TO 120 DO 600 I = 1, N IF (Y(I).NE.W(I,9)) GO TO 600 C INITIAL VECTOR ATTAINS GIVEN VALUE IND = 1 COMM(3) = 0.D0 CIN(1) = -12.D0 GO TO 2620 600 CONTINUE DO 620 I = 1, N W(I,10) = Y(I) 620 CONTINUE C C TEST INPUT PARAMETERS FOR INTERRUPT ON POSITION C 640 IF (COMM(4).GE.0.D0) GO TO 800 IF (CIN(1).GT.1.D0) GO TO 720 IF (X.EQ.XEND .AND. COMM(5).EQ.X) GO TO 880 IF (X.NE.XEND) GO TO 680 C VALUE OF CIN(1) DOES NOT PERMIT EXTRAPOLATION 660 IND = 1 CIN(1) = -13.D0 GO TO 780 680 IF ((X.GE.COMM(5) .AND. XEND.LT.COMM(5)) .OR. (X.LT.COMM(5) * .AND. XEND.GE.COMM(5))) GO TO 800 IF (INTER) GO TO 700 C VALUE OF CIN(1) DOES NOT PERMIT EXTRAPOLATION GO TO 660 C ORDER OF POINTS X,COUT(4) AND COUT(5) INCORRECT 700 IND = 1 CIN(1) = -14.D0 GO TO 780 720 IF (X.EQ.COUT(5) .OR. X.EQ.COUT(4)) GO TO 700 IF ((X.GE.COUT(4) .AND. COUT(4).LT.COUT(5)) .OR. (X.LT.COUT(4) * .AND. COUT(4).GE.COUT(5))) GO TO 700 IF (X.EQ.XEND) GO TO 880 IF (SIGN(1.D0,XEND-X).NE.SIGN(1.D0,X-COUT(5))) GO TO 700 IF (COMM(5).EQ.COUT(5) .OR. COMM(5).EQ.XEND) GO TO 740 IF (SIGN(1.D0,COMM(5)-COUT(5)).NE.SIGN(1.D0,COMM(5)-XEND)) * GO TO 740 C INTERRUPT POINT NOT IN RANGE IND = 1 CIN(1) = -15.D0 GO TO 780 740 IF (COMM(5).EQ.COUT(5) .OR. COMM(5).EQ.X) GO TO 760 IF (SIGN(1.D0,COMM(5)-COUT(5)).EQ.SIGN(1.D0,COMM(5)-X)) * GO TO 800 760 CIN(1) = 6.D0 780 COMM(4) = 0.D0 GO TO 2620 C C SET DEFAULTS C 800 IF (TEST) GO TO 860 IF (ABS(CIN(4)).GT.ABS(CIN(3)) .OR. CIN(4).EQ.0.D0) GO TO 820 C USER SET HMIN.GT.HMAX IND = 1 CIN(1) = -16.D0 GO TO 2620 820 COUT(13) = MAX(2.D0*COUT(11)*ABS(XEND-X),ABS(CIN(3))) FAC7 = 0.5D0 IF (CIN(1).GE.2.D0) FAC7 = 1.D0 COUT(14) = FAC7*ABS(XEND-X) IF (CIN(4).EQ.0.D0) GO TO 840 COUT(14) = MIN(ABS(COUT(14)),ABS(CIN(4))) 840 IF (CIN(1).GE.2.D0) GO TO 860 CALL FCN(N,X,Y,W(1,1),COEFFN,COEFF1,M,ARR) IF (CALLS) COMM(1) = COMM(1) - 1.D0 C C INITIALISATION C 860 IF (X.NE.XEND) GO TO 920 IF (CIN(1).LE.1.D0) GO TO 900 IF (CIN(1).NE.2.D0 .OR. CIN(6).NE.0.D0) GO TO 900 C REPEATED CALL WITH X=XEND IND = 1 CIN(1) = -17.D0 GO TO 2620 C C RETURN WHEN X=XEND C 880 COMM(4) = 0.D0 900 CIN(5) = 0.D0 CIN(6) = 0.D0 CIN(1) = 2.D0 GO TO 2620 C C X.NE.XEND INITIALLY C 920 IEND = 0 REDUCE = .FALSE. RAT1 = 1.D0 IF (CIN(1).EQ.0.D0) GO TO 960 IF (CIN(1).EQ.1.D0) CIN(6) = CIN(5) IF (CIN(6).EQ.0.0D0) GO TO 940 IF (SIGN(1.D0,CIN(6)).NE.SIGN(1.D0,XEND-X)) CIN(6) = 0.D0 940 IF (CIN(2).EQ.2.D0) FAC2 = SMALL/COUT(11) IF (ABS(CIN(6)).GE.COUT(13) .AND. CIN(1).GE.2.D0) GO TO 1500 960 ISTEP = 0 START = .TRUE. IF (CIN(6).NE.0.D0) GO TO 1160 C C ESTIMATE STEP C CIN(1) = 1.D0 FNORM = 0.D0 YNORM = 0.D0 DO 980 I = 1, N YNORM = MAX(YNORM,ABS(Y(I))) FNORM = MAX(FNORM,ABS(W(I,1))) 980 CONTINUE TOLEST = TOL J = INT(CIN(2)+0.1D0) + 1 GO TO (1000,1140,1020,1040,1080) J 1000 S = MAX(1.D0,YNORM) GO TO 1120 1020 S = MAX(YNORM,FAC2) GO TO 1120 1040 DO 1060 I = 1, N T = W(I,7)*MAX(W(I,8),ABS(Y(I))) IF (I.EQ.1) S = T S = MIN(S,T) 1060 CONTINUE GO TO 1120 1080 DO 1100 I = 1, N IF (I.EQ.1) S = W(1,7) S = MIN(S,W(I,7)) 1100 CONTINUE 1120 TOLEST = TOLEST*S 1140 S = SQRT(COUT(11)) CIN(6) = (XEND-X)*(TOLEST*COUT(11))**EXPI*MAX(S,YNORM) * /MAX(S,FNORM) 1160 DO 1180 I = 1, N W(I,4) = Y(I) W(I,5) = W(I,1) 1180 CONTINUE IF (ABS(CIN(6)).LT.COUT(13)) CIN(6) = SIGN(COUT(13),XEND-X) IF (ABS(CIN(6)).GT.COUT(14)) CIN(6) = SIGN(COUT(14),CIN(6)) ISIG = 1 GO TO 1600 C C RETURN FOR INITIAL STEP C 1200 IF (COMM(1).GT.0.D0 .OR. .NOT. CALLS) GO TO 1260 C TOO MANY FCN CALLS TAKEN STARTING 1220 IND = 7 DO 1240 I = 1, N Y(I) = W(I,4) 1240 CONTINUE COUT(9) = COUT(9) + 1.D0 GO TO 2620 1260 IF (ABS(HEST).LT.ABS(CIN(6))) GO TO 1280 C C ESTIMATED STEP LARGER THAN INITIAL STEP C IF (ABS(CIN(6))*CONST(2).GT.COUT(14)) GO TO 1420 IF (ABS(HEST).GT.COUT(14)) HEST = SIGN(COUT(14),HEST) IF (REDUCE) GO TO 1420 IF (ABS(HEST).LT.CONST(2)*CONST(2)*ABS(CIN(6))) GO TO 1420 CIN(6) = HEST GO TO 1460 1280 IF (ABS(CIN(6)).GT.COUT(13)) GO TO 1340 C ERROR TOLERANCE TOO SMALL FOR INITIAL STEP 1300 COUT(9) = COUT(9) + 1.D0 DO 1320 I = 1, N Y(I) = W(I,4) 1320 CONTINUE IND = 4 GO TO 2620 C C ESTIMATED STEP SMALLER THAN INITIAL STEP C 1340 T = CIN(6)/CONST(2) IF (ABS(HEST).GT.ABS(T)) GO TO 1420 T = T*FAC1 IF (ABS(HEST).LT.ABS(T)) HEST = T CIN(6) = HEST IF (ABS(CIN(6)).LT.COUT(13)) CIN(6) = SIGN(COUT(13),XEND-X) GO TO 1440 C C INSIGNIFICANT ERROR ESTIMATE ON INITIAL STEP C 1360 CONTINUE IF (REDUCE) GO TO 1380 IF (ABS(CIN(6)).EQ.COUT(14)) GO TO 1400 CIN(6) = CIN(6)*FAC IF (ABS(CIN(6)).GT.COUT(14)) CIN(6) = SIGN(COUT(14),CIN(6)) GO TO 1460 1380 IF (ISIG.EQ.3) GO TO 1300 ISIG = 3 CIN(6) = CIN(6)/FAC3 GO TO 1440 C C INITIAL STEP ACCEPTED C 1400 HEST = CIN(6) 1420 START = .FALSE. GO TO 2000 C C INITIAL STEP REJECTED TRY AGAIN C 1440 REDUCE = .TRUE. 1460 DO 1480 I = 1, N Y(I) = W(I,2) 1480 CONTINUE COUT(9) = COUT(9) + 1.D0 GO TO 1560 C C TAKE A STEP, CHECK AGAINST LENGTH OF RANGE C 1500 IF (ISTEP.LT.2) ISTEP = ISTEP + 1 1520 IF (D02PAY(X,CIN(6),XEND)*SIGN(1.0D0,XEND-X).LT.0.0D0) * GO TO 1560 IF (ISTEP.EQ.-1) GO TO 1540 CIN(6) = XEND - X RAT1 = ABS(COUT(4)-X)/ABS(CIN(6)) 1540 IEND = 1 1560 DO 1580 I = 1, N W(I,4) = W(I,2) W(I,5) = W(I,3) 1580 CONTINUE 1600 CALL D02KDZ(X,CIN(6),N,Y,FCN,W,IW,N2,COEFFN,COEFF1,M,ARR) IF (CALLS) COMM(1) = COMM(1) - 4.D0 C C ESTIMATE NEW STEP C IF (CIN(2).GE.3.D0) GO TO 1800 S = 0.D0 T = 0.D0 J = 0 DO 1620 I = 1, N IF (S.GT.ABS(W(I,6))) GO TO 1620 J = I T = W(I,N2) S = ABS(W(I,6)) 1620 CONTINUE IF (T.EQ.0.D0) GO TO 1680 1640 RAT = RAT1 IF (START) GO TO 1360 IF (J.NE.INT(COUT(10)+0.1D0)) GO TO 1980 HEST = CIN(6) IF (ABS(HEST).EQ.COUT(14) .OR. IEND.EQ.1) GO TO 1980 IF (ABS(HEST).LT.ABS(HEST1)) GO TO 1660 HEST1 = HEST RAT = CONST(2) GO TO 1980 1660 IND = 3 GO TO 2620 1680 J = 0 K = INT(CIN(2)+0.1D0) + 1 GO TO (1720,1700,1760) K 1700 RAT = (TOL/S)**EXP GO TO 1980 1720 T = 1.D0 DO 1740 I = 1, N T = MAX(T,ABS(Y(I))) 1740 CONTINUE RAT = (TOL*T/S)**EXP GO TO 1980 1760 T = FAC2 DO 1780 I = 1, N T = MAX(T,ABS(Y(I))) 1780 CONTINUE RAT = (TOL*T/S)**EXP GO TO 1980 1800 IF (CIN(2).EQ.4.D0) GO TO 1840 DO 1820 I = 1, N C RELATIVE ERROR FAILURE IF (W(I,8).GT.0.0D0) GO TO 1820 IF ((Y(I).GE.0.0D0 .AND. W(I,2).GE.0.0D0) .OR. (Y(I) * .LT.0.0D0 .AND. W(I,2).LT.0.0D0)) GO TO 1820 IND = 6 GO TO 2620 1820 CONTINUE 1840 J = -1 I1 = 0 DO 1960 I = 1, N IF (W(I,6).NE.0.D0) GO TO 1880 IF (W(I,N2).EQ.0.D0) GO TO 1860 IF (I1.EQ.0) J = I GO TO 1960 1860 IF (J.LT.0) J = I GO TO 1960 1880 IF (CIN(2).EQ.4.D0) GO TO 1900 T = MAX(W(I,8),ABS(Y(I)))*W(I,7)/ABS(W(I,6)) GO TO 1920 1900 T = W(I,7)/ABS(W(I,6)) 1920 IF (I1.EQ.0) GO TO 1940 IF (S.LE.T) GO TO 1960 1940 S = T J = 0 I1 = 1 IF (W(I,N2).EQ.1.D0) J = I 1960 CONTINUE IF (J.NE.0) GO TO 1640 RAT = (TOL*S)**EXP 1980 HEST = RAT*CIN(6) IF (START) GO TO 1200 C C TEST ESTIMATED STEP C 2000 IF (ABS(HEST).GE.ABS(CIN(6))) GO TO 2140 C C STEP REJECTED C RAT1 = 1 IEND = 0 IF (ISTEP.LT.0) GO TO 2100 COUT12 = 1.D0 IF (X.EQ.XORIG) COUT(12) = 1.D0 HEST = HEST*CONST(3) COUT(9) = COUT(9) + 1.D0 DO 2020 I = 1, N Y(I) = W(I,2) W(I,3) = W(I,5) W(I,2) = W(I,4) 2020 CONTINUE T = CIN(6)/CONST(2) IF (ABS(HEST).LT.ABS(T)) HEST = T CIN(6) = HEST IF (ABS(CIN(6)).GE.COUT(13)) GO TO 2060 C STEP LENGTH TOO SMALL 2040 IND = 2 GO TO 2620 2060 IF (COMM(1).GT.0.D0 .OR. .NOT. CALLS) GO TO 1520 IF (ISTEP.LT.2) GO TO 1220 C TOO MANY FCN CALLS 2080 IND = 5 GO TO 2620 C C STEP REJECTED AFTER INTERRUPT IN FIRST STEP C 2100 IF (COMM(1).LT.0.D0) GO TO 1220 CIN(6) = (X-COUT(4))*0.5D0 IF (ABS(CIN(6)).LT.COUT(13)) GO TO 2040 X = COUT(4) DO 2120 I = 1, N Y(I) = W(I,4) W(I,1) = W(I,5) 2120 CONTINUE COUT(9) = COUT(9) + 2.D0 INIT = .TRUE. ISTEP = 0 GO TO 1600 C C STEP ACCEPTED C 2140 COUT(5) = COUT(4) COUT(4) = X X = X + CIN(6) HEST1 = 0.D0 COUT(10) = DBLE(J) COUT(8) = COUT(8) + 1.D0 IF ( .NOT. INIT) GO TO 2160 INIT = .FALSE. CIN(5) = CIN(6) COUT(1) = CIN(6) COUT(2) = CIN(6) GO TO 2180 2160 IF (ABS(CIN(6)).LT.ABS(COUT(1))) COUT(1) = CIN(6) IF (ABS(CIN(6)).GT.ABS(COUT(2))) COUT(2) = CIN(6) 2180 IF (HEST.EQ.CIN(6) .AND. ABS(HEST).EQ.COUT(14)) GO TO 2260 HEST = HEST*CONST(3) IF (ABS(CIN(6)).EQ.COUT(14) .OR. IEND.EQ.1) COUT(3) = COUT(3) + * 1.D0 IF (COUT12.EQ.0.D0) GO TO 2200 COUT12 = 0.D0 HEST = 0.5D0*(HEST+CIN(6)) 2200 IF (IEND.EQ.1) GO TO 2220 T = CONST(2)*CIN(6) IF (ABS(HEST).GT.ABS(T)) HEST = T IF (ABS(HEST).GT.COUT(14)) HEST = SIGN(COUT(14),HEST) IF (ABS(HEST).LT.COUT(13)) HEST = SIGN(COUT(13),XEND-X) GO TO 2240 2220 CIN(6) = CIN(6)*RAT1 IF (ABS(CIN(6)).GE.ABS(HEST)) GO TO 2260 2240 CIN(6) = HEST 2260 S = 0.D0 DO 2280 I = 1, N S = MAX(S,ABS(Y(I))) 2280 CONTINUE COUT(6) = MAX(S,COUT(6)) COUT(7) = MIN(S,COUT(7)) CALL FCN(N,X,Y,W(1,1),COEFFN,COEFF1,M,ARR) IF (CIN(1).EQ.0.D0) GO TO 2580 IF (COMM(3).EQ.0.D0) GO TO 2320 DO 2300 I = 1, N IF (ABS(Y(I)-W(I,9)).LT.ABS(W(I,10)-W(I,9))) W(I,10) = Y(I) 2300 CONTINUE 2320 IF ( .NOT. CALLS) GO TO 2340 COMM(1) = COMM(1) - 1.D0 IF (COMM(1).LE.0.D0) GO TO 2080 2340 IF (IEND.EQ.1) GO TO 2600 IF (ISTEP.GE.0) GO TO 2360 ISTEP = -ISTEP GO TO (2460,2440,2620,2520) ISTEP C C TEST INTERRUPTS C 2360 IF (COMM(3).EQ.0.D0) GO TO 2420 DO 2400 I = 1, N IF (Y(I).EQ.W(I,9)) GO TO 2380 IF ((W(I,2).GE.W(I,9) .AND. Y(I).GE.W(I,9)) .OR. (W(I,2) * .LT.W(I,9) .AND. Y(I).LT.W(I,9))) GO TO 2400 C COMPONENTS ACHIEVE GIVEN VALUE 2380 CIN(1) = 3.D0 IF (ISTEP.EQ.0) GO TO 2540 GO TO 2460 2400 CONTINUE C NORM OF SOLUTION TOO LARGE TOO CONTINUE 2420 IF (COMM(2).EQ.0.D0 .OR. COUT(6).LT.COMM(2)) GO TO 2480 CIN(1) = 4.D0 IF (ISTEP.EQ.0) GO TO 2540 2440 COMM(2) = 0.0D0 GO TO 2620 2460 COMM(3) = 0.0D0 GO TO 2620 2480 IF (COMM(4).EQ.0.D0) GO TO 2560 IF (COMM(4).LT.0.D0) GO TO 2500 C INTERRUPT EVERY STEP CIN(1) = 5.D0 IF (ISTEP.EQ.0) GO TO 2540 GO TO 2620 2500 IF ((COMM(5).GE.X .AND. XEND.GE.X) .OR. (COMM(5) * .LT.X .AND. XEND.LT.X)) GO TO 2560 C INTERRUPT AT SPECIFIED POINT CIN(1) = 6.D0 IF (ISTEP.EQ.0) GO TO 2540 2520 COMM(4) = 0.0D0 GO TO 2620 2540 IF (COMM(1).LT.0.D0) GO TO 1220 ISTEP = -INT(CIN(1)-1.5D0) GO TO 1520 2560 IF (COMM(1).LT.0.D0) GO TO 2080 2580 IF (IEND.EQ.0) GO TO 1500 C NORMAL RETURN 2600 CIN(1) = 2.D0 X = XEND C C RETURN TO MAIN PROGRAM C 2620 IF (CALLS .AND. COMM(1).EQ.0.D0) COMM(1) = -1.D0 IFAIL = P01ABF(IFAIL,IND,SRNAME,0,P01REC) IF (CIN(1).GE.0.D0 .AND. IFAIL.GT.0) CIN(1) = 8.D0 RETURN END SUBROUTINE D02KDZ(X,H,N,Y,FCN,W,IW1,IW2,COEFFN,COEFF1,M,ARR) C MARK 7 RELEASE. NAG COPYRIGHT 1978. C MARK 8 REVISED. IER-227 (APR 1980). C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C COEFF1, COEFFN, FCN C .. Scalar Arguments .. DOUBLE PRECISION H, X INTEGER IW1, IW2, M, N C .. Array Arguments .. DOUBLE PRECISION ARR(M), W(IW1,IW2), Y(N) C .. Subroutine Arguments .. EXTERNAL COEFF1, COEFFN, FCN C .. Local Scalars .. DOUBLE PRECISION EPS, S INTEGER I, N1 C .. Local Arrays .. DOUBLE PRECISION C(10) C .. External Functions .. DOUBLE PRECISION X02AJF EXTERNAL X02AJF C .. Intrinsic Functions .. INTRINSIC ABS, MAX C .. Executable Statements .. EPS = X02AJF() C(1) = 1.D0/6.D0 C(2) = 1.D0/3.D0 C(3) = 0.125D0 C(4) = 0.375D0 C(5) = 0.5D0 C(6) = 1.5D0 C(7) = 2.0D0 C(8) = 2.D0/3.D0 C(9) = 0.2D0 C(10) = 4.D0/3.D0 N1 = 6 IF (IW2.EQ.4) N1 = 4 IF (IW2.EQ.6) N1 = 5 DO 20 I = 1, N W(I,3) = Y(I) + C(2)*H*W(I,1) 20 CONTINUE CALL FCN(N,X+C(2)*H,W(1,3),W(1,N1),COEFFN,COEFF1,M,ARR) DO 40 I = 1, N IF (N1.EQ.5) W(I,4) = 0.5D0*(W(I,N1)-W(I,1))*C(2)*H W(I,3) = Y(I) + C(1)*H*(W(I,1)+W(I,N1)) 40 CONTINUE CALL FCN(N,X+C(2)*H,W(1,3),W(1,N1),COEFFN,COEFF1,M,ARR) DO 60 I = 1, N W(I,2) = Y(I) + H*(C(3)*W(I,1)+C(4)*W(I,N1)) 60 CONTINUE CALL FCN(N,X+C(5)*H,W(1,2),W(1,3),COEFFN,COEFF1,M,ARR) DO 100 I = 1, N IF (N1.EQ.4) GO TO 80 W(I,IW2) = -C(2)*W(I,1) - C(10)*W(I,3) + C(6)*W(I,N1) 80 W(I,2) = Y(I) + H*(C(5)*W(I,1)-C(6)*W(I,N1)+C(7)*W(I,3)) 100 CONTINUE CALL FCN(N,X+H,W(1,2),W(1,N1),COEFFN,COEFF1,M,ARR) DO 140 I = 1, N W(I,2) = Y(I) Y(I) = Y(I) + H*(C(1)*(W(I,1)+W(I,N1))+C(8)*W(I,3)) IF (N1.EQ.4) GO TO 120 W(I,3) = W(I,N1) W(I,N1) = C(9)*H*(W(I,IW2)+C(1)*W(I,N1)) S = 0.D0 IF (ABS(W(I,N1)).LE.30.D0*C(9)*EPS*ABS(H)*MAX(ABS(W(I,IW2)) * ,C(1)*ABS(W(I,3)))) S = 1.D0 W(I,IW2) = S 120 W(I,3) = W(I,1) 140 CONTINUE RETURN END SUBROUTINE D02KEF(XPOINT,NXP,IC1,COEFFN,BDYVAL,K,TOL,ELAM,DELAM, * HMAX,MAXIT,MAXFUN,MONIT,REPORT,IFAIL) C MARK 8 RELEASE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C C MEANING OF COMMON VARIABLES: C ZER,ONE,TWO,PI - CONSTANTS WITH INDICATED VALUES C LAMDA - CURRENT VALUE OF EIGENVALUE ESTIMATE. SET AND USED IN C EIGODE. USED IN AUX,OPTSC. C PSIGN - SAMPLE P(X) VALUE. SET IN PRUFER, USED IN AUX. C MINSC - MINIMUM ALLOWED SCALEFACTOR. SET IN EIGODE, USED IN C OPTSC. C BP - USED BY THE POLYGONAL SCALING METHOD. THE CURRENT C VALUE OF THE DERIVATIVE OF B(X). SET IN PRUFER, USED I C C BDYVAL, COEFFN, MONIT, REPORT C .. Parameters .. CHARACTER*6 SRNAME PARAMETER (SRNAME='D02KEF') C .. Scalar Arguments .. DOUBLE PRECISION DELAM, ELAM, TOL INTEGER IC1, IFAIL, K, MAXFUN, MAXIT, NXP C .. Array Arguments .. DOUBLE PRECISION HMAX(2,NXP), XPOINT(NXP) C .. Subroutine Arguments .. EXTERNAL BDYVAL, COEFFN, MONIT, REPORT C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION D, DELAM1, DETOL, DETOLL, DETOLR, DMIN, EL0, * EL1, F0, F1, GAMMA, SIGNSI, TEMP0, TEMP1, TEMP2, * TEMP3, TEMP4, TEMP5, TEMP6, TEMP7, TEMP8, TENU, * TOL2, V3BDYL, V3BDYR, V3L, V3R, X, XL, XOLD, XR, * ZETA INTEGER I, IBACK, IC, IFAIL1, IFLAG, ILOOP, IND, ISTAT1, * ISTATE, ITOP, IXP, MAXFN1, NINT, NXP1 C .. Local Arrays .. DOUBLE PRECISION C(17), F(15), V(21), VL(7) CHARACTER*1 P01REC(1) C .. External Functions .. DOUBLE PRECISION D02KDS, D02KDU, X01AAF, X02AJF INTEGER P01ABF EXTERNAL D02KDS, D02KDU, X01AAF, X02AJF, P01ABF C .. External Subroutines .. EXTERNAL C05AZF, D02KDT, D02KDV, D02KEZ C .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, SIGN, LOG, DBLE C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Executable Statements .. ZER = 0.D0 ONE = 1.D0 TWO = 2.D0 PI = X01AAF(0.0D0) TENU = 10.D0*X02AJF() C C PARAMETER CHECKS, DEFAULT VALUES ETC. IF (NXP.LT.4) GO TO 320 IF (K.LT.0) GO TO 340 IF (TOL.LE.ZER) GO TO 360 NINT = NXP - 3 XL = XPOINT(2) XR = XPOINT(NXP-1) C CHECK XPOINT(I) IN ASC. ORDER AND FIND POSN. OF MATCHING C POINT. DMIN = TWO*ABS(XR-XL) NXP1 = NXP - 1 XOLD = XPOINT(1) DO 40 I = 2, NXP1 X = XPOINT(I) IF (X.LT.XOLD) GO TO 380 D = ABS((XL-X)+(XR-X)) IF (D.GT.DMIN) GO TO 20 IC = I DMIN = D 20 XOLD = X 40 CONTINUE IF ((IC1.LT.2) .OR. (IC1.GT.NXP1)) IC1 = IC IC = IC1 I = NXP IF (XPOINT(NXP).LT.XOLD) GO TO 380 C MINSC = ONE/TENU GAMMA = ZER IF (XL.EQ.XR) GO TO 60 MINSC = 4.D0/ABS(XR-XL) GAMMA = (XPOINT(IC)-XL)/(XR-XL) 60 CONTINUE C DO 80 I = 1, NXP HMAX(2,I) = ZER 80 CONTINUE C TOL2 = TOL/TWO DELAM1 = DELAM IF (DELAM1.EQ.ZER) DELAM1 = .25D0*MAX(ONE,ABS(ELAM)) C HAVE REPORT ROUTINE SWITCHED OFF INITIALLY V(6) = ZER C INITIAL RHO VALUES AT XL,XR TAKEN AS ZERO C ON FIRST ITERATION V3L = ZER V3R = ZER C C INITIAL VALUES OF TOLERANCE PARAMS LOG(ETA) AT XL,XR. DETOLL = LOG(1.D-4) DETOLR = DETOLL C INITIALIZE FAIL-FLAG FOR MISS DISTANCE CODE. IFAIL1 = 0 EL1 = ELAM EL0 = ELAM + DELAM1 C INITIAL EVALUATION, F=F(EL1) . ISTATE = 1 LAMDA = EL1 IBACK = 1 GO TO 520 100 IF (IFAIL1.GT.0) GO TO 460 F1 = F(1) C ENTER BRACKETING LOOP. IF (F1.EQ.ZER) GO TO 180 C THROUGHOUT THE ROOTFINDING, MAINTAIN EL1,EL0 AS TWO MOST C RECENT C APPROXIMATIONS, WITH ABS(F(EL0)).GE.ABS(F(EL1)) C IBACK = 2 LAMDA = EL0 ILOOP = 0 120 ILOOP = ILOOP + 1 GO TO 520 140 IF (IFAIL1.GT.0) GO TO 440 EL0 = LAMDA F0 = F(1) IF (ABS(F0).GT.ABS(F1)) GO TO 160 EL0 = EL1 F0 = F1 EL1 = LAMDA F1 = F(1) 160 IF (F1.EQ.ZER) GO TO 180 IF (F0*F1.LT.ZER) GO TO 200 LAMDA = EL1 - TWO*(EL0-EL1) IF (ILOOP.LE.8) GO TO 120 C HERE HAVE FAILED TO BRACKET ROOT AFTER 10 EVALUATIONS IFAIL1 = 5 GO TO 440 C ON FINDING FMISS EXACTLY 0 ON C 1ST EVAL OR WHEN BRACKETING 180 EL0 = EL1 GO TO 280 C ROOT BETWEEN EL0 AND EL1.. START CALLING ROOTFINDER 200 IFLAG = 1 ISTATE = 2 IBACK = 3 IND = -1 C(1) = F0 220 CALL C05AZF(EL1,EL0,F1,TOL2,0,C,IND,IFLAG) IF (IND.EQ.0) GO TO 260 IF (IND.NE.4 .OR. IFLAG.NE.1) GO TO 420 LAMDA = EL1 GO TO 520 240 IF (IFAIL1.GT.0) GO TO 440 F1 = F(1) GO TO 220 C ON EXIT FROM LOOP TEST FAILURE PARAM OF C05AZF 260 IF (IFLAG.NE.0) GO TO 420 C SWITCH REPORT ROUTINE ON AND C REPEAT INTEGRATION 280 V(6) = ONE LAMDA = EL1 IBACK = 4 GO TO 520 300 IF (IFAIL1.GT.0) GO TO 460 IFAIL1 = 0 GO TO 440 C *** C ERROR PROCESSING FOR MAIN ROUTINE C *** C PARAMETER ERROR NXP,K OR TOL 320 HMAX(2,1) = 1.D0 GO TO 400 340 HMAX(2,1) = 2.D0 GO TO 400 360 HMAX(2,1) = 3.D0 GO TO 400 380 HMAX(2,1) = 4.D0 HMAX(2,2) = DBLE(I) 400 IFAIL1 = 1 HMAX(2,2) = ZER IF (HMAX(2,1).EQ.4.D0) HMAX(2,2) = DBLE(I) GO TO 500 420 IFAIL1 = 12 IF (IFLAG.EQ.4) IFAIL1 = 10 IF (IFLAG.EQ.5) IFAIL1 = 9 440 ELAM = EL1 DELAM = ABS(F(2)) + ABS(EL0-EL1) 460 HMAX(2,1) = ZER HMAX(2,2) = ZER IF (IFAIL1.EQ.0) GO TO 500 IF (IFAIL1.EQ.5) DELAM = EL0 - EL1 IF (IFAIL1.NE.11) GO TO 480 HMAX(2,1) = TEMP1 HMAX(2,2) = TEMP2 480 IF (IFAIL1.NE.12) GO TO 500 HMAX(2,1) = DBLE(IFLAG) HMAX(2,2) = DBLE(IND) 500 IFAIL = P01ABF(IFAIL,IFAIL1,SRNAME,0,P01REC) RETURN C *** C CODE TO COMPUTE MISS DISTANCE. C *** 520 F(3) = ZER 540 F(3) = F(3) + ONE IF (IFAIL1.LT.0) GO TO 960 MAXIT = MAXIT - 1 MAXFN1 = MAXFUN F(1) = ZER F(2) = ZER DO 560 I = 4, 15 F(I) = ZER 560 CONTINUE HMAX(1,NXP-1) = ZER HMAX(1,NXP) = ZER YL(3) = ZER YR(3) = ZER CALL BDYVAL(XL,XR,LAMDA,YL,YR) C SET PARAMETERS APPLICABLE TO SHOOTING EITHER DIRECTION. V(7) = MAX(ONE,ABS(LAMDA))*TOL2 C SET PARAMS FOR SHOOTING C FROM XL. JINT = 1 V(1) = D02KDU(XL,COEFFN) CALL D02KDT(V,YL(1),YL(2),-1,IFAIL1) IF (IFAIL1.NE.0) GO TO 900 V3BDYL = V(3) V(3) = V3L V(4) = ZER V(5) = DETOLL + V(3) X = XL IF (V(6).NE.ZER) CALL REPORT(X,V,0) IF (IC.LT.3) GO TO 600 DO 580 IXP = 3, IC JINT = IXP - 2 CALL D02KEZ(X,XPOINT(IXP),V,COEFFN,MAXFN1,HMAX(1,JINT) * ,REPORT,IFAIL1) F(5) = F(5) + V(15) F(6) = F(6) + V(16) F(7) = F(7) + V(10) IF (IFAIL1.NE.0) GO TO 760 580 CONTINUE C 600 DO 620 I = 1, 7 VL(I) = V(I) 620 CONTINUE C C SET PARAMS FOR SHOOTING C FROM XR. JINT = NINT V(1) = D02KDU(XR,COEFFN) CALL D02KDT(V,YR(1),YR(2),K,IFAIL1) IF (IFAIL1.NE.0) GO TO 920 V3BDYR = V(3) V(3) = V3R V(4) = ZER V(5) = DETOLR + V(3) X = XR IF (V(6).NE.ZER) CALL REPORT(X,V,NINT+1) ITOP = NXP - IC IF (2.GT.ITOP) GO TO 660 DO 640 I = 2, ITOP IXP = NXP - I JINT = IXP - 1 CALL D02KEZ(X,XPOINT(IXP),V,COEFFN,MAXFN1,HMAX(1,JINT) * ,REPORT,IFAIL1) F(5) = F(5) + V(15) F(6) = F(6) + V(16) F(7) = F(7) + V(10) IF (IFAIL1.NE.0) GO TO 760 640 CONTINUE C 660 CONTINUE C HAVE NOW SHOT C FROM XL, RESULTS IN VL, C FROM XR, RESULTS IN C V. C CONVERT TO SAME SCALE AND COMPUTE MISS-DISTANCE. CALL D02KDV(VL,V(1),IFAIL1) F(1) = (VL(2)-V(2))/(PI+PI) C COMPUTE ERROR ESTIMATE INFO. TEMP0 = VL(5) - VL(3) TEMP1 = V(5) - V(3) TEMP2 = D02KDS(-ABS(TEMP0-TEMP1)) IF (GAMMA.EQ.ZER .OR. (GAMMA.NE.ONE .AND. TEMP0.LT.TEMP1)) * GO TO 680 TEMP3 = TEMP0 TEMP4 = ONE TEMP5 = TEMP2 GO TO 700 680 TEMP3 = TEMP1 TEMP4 = TEMP2 TEMP5 = ONE 700 TEMP6 = TEMP4*GAMMA + TEMP5*(ONE-GAMMA) TEMP7 = TEMP4*VL(4) - TEMP5*V(4) IF (TEMP7.EQ.0.0D0) TEMP7 = TENU TEMP7 = SIGN(MAX(ABS(TEMP7),TENU*ABS(TEMP6)),TEMP7) F(2) = -TEMP7/TEMP6 ZETA = ABS(F(2)*V(7)) F(2) = ONE/F(2) TEMP8 = -TEMP3 - LOG(ABS(TEMP7)/TWO) V3L = V3L + TEMP8 - VL(3) V3R = V3R + TEMP8 - V(3) SIGNSI = SIGN(ONE,TEMP7) HMAX(1,NXP-1) = -D02KDS(-V3BDYL+V3L)*SIGNSI HMAX(1,NXP) = D02KDS(V3R-V3BDYR)*SIGNSI TEMP2 = TEMP3 + LOG(.75D0*TEMP6*MAX(ZETA,1.D-2)) C DETOL=IDEALISED VALUE OF V(5) FOR NEXT ITERATION) DETOL = TEMP2 + TEMP8 C BUT INTRODUCE CAUTION DETOLL = MIN(DETOLL+TWO,DETOL-V3L) DETOLR = MIN(DETOLR+TWO,DETOL-V3R) C IFAIL1 = 0 IF (MAXIT.EQ.0) IFAIL1 = -1 ISTAT1 = ISTATE 720 CONTINUE C F(4) = MAXFUN - MAXFN1 CALL MONIT(MAXIT,ISTAT1,LAMDA,F) IF (IFAIL1.GT.0) GO TO 740 IF (ZETA.LT.ONE) GO TO 540 740 GO TO (100,140,240,300) IBACK 760 GO TO (780,800,800,820,840,780,840,860,780) * IFAIL1 780 IFAIL1 = 11 TEMP1 = DBLE(IFAIL1) TEMP2 = V(18) GO TO 880 800 IFAIL1 = 8 GO TO 880 820 IFAIL1 = 7 GO TO 880 840 IFAIL1 = 6 GO TO 880 860 IFAIL1 = 3 880 ISTAT1 = -IFAIL1 F(9) = JINT F(10) = X F(11) = V(1) F(12) = V(2) F(13) = V(3) F(14) = V(18) F(15) = V(11) GO TO 720 C BDYVAL ERROR AT XL 900 F(9) = ZER F(10) = XL GO TO 940 C BDYVAL ERROR AT XR 920 F(9) = DBLE(NXP-2) F(10) = XR 940 IFAIL1 = 2 ISTAT1 = -IFAIL1 GO TO 720 C C MAXIT ERROR 960 IFAIL1 = 4 GO TO 740 END SUBROUTINE D02KEZ(X,XEND,V,COEFFN,MAXFUN,HINFO,REPORT,IFAIL) C MARK 8 RELEASE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-501 (AUG 1986). C COEFFN, REPORT C .. Scalar Arguments .. DOUBLE PRECISION X, XEND INTEGER IFAIL, MAXFUN C .. Array Arguments .. DOUBLE PRECISION HINFO(2), V(21) C .. Subroutine Arguments .. EXTERNAL COEFFN, REPORT C .. Scalars in Common .. DOUBLE PRECISION BP, LAMDA, MINSC, ONE, PI, PSIGN, TWO, ZER INTEGER JINT C .. Arrays in Common .. DOUBLE PRECISION YL(3), YR(3) C .. Local Scalars .. DOUBLE PRECISION BNEW, CACC1, CACC2, DQDL, EPSDE, FAC1, FAC2, P, * Q, SY, SYOLD, TEMP, V2OLD, X1, XMAXFN, XOLD INTEGER IFAIL1 C .. Local Arrays .. DOUBLE PRECISION CIN(6), COMM(5), CONST(3), W(3,7) C .. External Functions .. DOUBLE PRECISION D02KDS, D02KDU EXTERNAL D02KDS, D02KDU C .. External Subroutines .. EXTERNAL D02KDV, D02KDW, D02KDY C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN, LOG, COS, DBLE, SIN C .. Common blocks .. COMMON /AD02KD/ZER, ONE, TWO, PI, LAMDA, PSIGN, MINSC, * BP, YL, YR, JINT C .. Data statements .. DATA COMM(1), COMM(2), COMM(3), COMM(4), * COMM(5)/0.D0, 0.D0, 0.D0, 1.D0, 0.D0/, CONST(1), * CONST(2), CONST(3)/0.D0, 0.D0, 0.D0/, * CIN(2)/1.D0/, CACC1/4.D0/ C .. Executable Statements .. CACC2 = LOG(CACC1) CIN(1) = ONE CIN(3) = ZER CIN(4) = HINFO(1) CIN(5) = HINFO(2) C IF MAXFUN.LE.0 ADD ON BIG QUANTITY XMAXFN = ZER IF (MAXFUN.LE.0) XMAXFN = 32767.D0 COMM(1) = DBLE(MAXFUN) + XMAXFN C GIVE CIN(6) A STARTING VALUE AS IT IS USED IN CALCULATING BP CIN(6) = CIN(5) IF (CIN(6).EQ.ZER) CIN(6) = (XEND-X)*0.125D0 C RE-SCALE PRUFER VARIABLES IF NECESSARY BNEW = D02KDU(X,COEFFN) IF (BNEW.NE.V(1)) CALL D02KDV(V,BNEW,IFAIL) C INITIAL EVALUATION OF BP IF (X.EQ.XEND) GO TO 120 X1 = X + CIN(6) C INITIAL EVALUATION OF INTEGRAND FOR SENSITIVITY INTEGRAL CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) TEMP = MAX(D02KDU(X1,COEFFN)-V(1),-ABS(Q*CIN(6))) BP = TEMP/CIN(6) SY = D02KDS(V(3)-V(5))*DQDL/V(1) C STORE INITIAL P(X) IN COMMON SO AUX CAN CHECK SIGN CHANGE IF (P.EQ.0.0D0) GO TO 180 PSIGN = SIGN(ONE,P) C C MAIN LOOP - ADVANCES INTEGRATION ONE STEP C 20 CONTINUE C SET SOFT FAIL IFAIL1 = 1 C SET LOCAL ERROR TOLERANCE FOR THIS STEP EPSDE = D02KDS(V(5)-V(3)) EPSDE = EPSDE/(ONE+100.D0*EPSDE) C STORE OLD VALUES FOR SENSITIVITY INTEGRAL XOLD = X SYOLD = SY V2OLD = V(2) C CALL D02KDY(X,XEND,3,V,CIN,EPSDE,D02KDW,COMM,CONST,V(8) * ,W,3,7,COEFFN,COEFFN,HINFO,1,IFAIL1) C C PSIGN SET TO 0 SHOWS P(X) ZERO OR CHANGED SIGN IF (PSIGN.EQ.ZER) GO TO 180 IF (IFAIL1.NE.0) GO TO 160 C C ADVANCE ESTIMATE OF SENSITIVITY INTEGRAL CALL COEFFN(P,Q,DQDL,X,LAMDA,JINT) SY = D02KDS(V(3)-V(5))*DQDL/V(1) TEMP = V(2) - V2OLD IF (ABS(TEMP).LE.0.75D0) GO TO 40 FAC1 = ONE - (SIN(V(2))-SIN(V2OLD))/TEMP FAC2 = FAC1 GO TO 60 40 FAC1 = ONE - COS(V2OLD) FAC2 = ONE - COS(V(2)) 60 CONTINUE V(4) = V(4) + (X-XOLD)*(SYOLD*FAC1+SY*FAC2)/TWO C CHECK IF ACCURACY UNNECESSARILY HIGH 80 IF (ABS(V(4)*V(7)).LE.CACC1) GO TO 100 V(4) = V(4)/CACC1 SY = SY/CACC1 V(5) = V(5) + CACC2 GO TO 80 100 CONTINUE C C PREPARE FOR NEXT STEP, AND LOOP BACK IF (V(6).NE.ZER) CALL REPORT(X,V,JINT) IF (X.NE.X1) CALL D02KDV(V,D02KDU(X,COEFFN),IFAIL) IF (X.EQ.XEND) GO TO 120 IF (CIN(1).NE.5.D0) GO TO 200 X1 = X + CIN(6) IF (ABS(XEND-X).LT.ABS(CIN(6))) GO TO 110 TEMP = MAX(D02KDU(X1,COEFFN)-V(1),-ABS(Q*CIN(6))) BP = TEMP/CIN(6) 110 CONTINUE CALL D02KDW(3,X,V,W(1,1),COEFFN,COEFFN,1,HINFO) COMM(1) = COMM(1) - ONE C AND LOOP BACK IF (COMM(1).GT.ZER) GO TO 20 IFAIL1 = 5 GO TO 160 C BEFORE EXIT, SET OUTPUT VALUES ETC. 120 IFAIL = 0 140 MAXFUN = COMM(1) - XMAXFN HINFO(2) = CIN(5) RETURN C C FAILURE EXITS 160 IFAIL = IFAIL1 V(18) = EPSDE GO TO 140 180 IFAIL = 8 V(18) = EPSDE GO TO 140 200 IFAIL = 9 V(18) = CIN(1) GO TO 140 END DOUBLE PRECISION FUNCTION D02PAY(X,H,XEND) C MARK 14 RELEASE. NAG COPYRIGHT 1989. C .. Scalar Arguments .. DOUBLE PRECISION H, X, XEND C .. Local Scalars .. DOUBLE PRECISION TEMP C .. External Functions .. DOUBLE PRECISION D02PAZ, X02AJF EXTERNAL D02PAZ, X02AJF C .. Intrinsic Functions .. INTRINSIC ABS, MAX, SIGN C .. Executable Statements .. TEMP = D02PAZ(X+H) - XEND IF (ABS(TEMP).LE.2.0D0*X02AJF()*MAX(ABS(X),ABS(XEND))) * TEMP = X02AJF()*SIGN(1.0D0,XEND-X) D02PAY = TEMP RETURN END DOUBLE PRECISION FUNCTION D02PAZ(X) C MARK 14 RELEASE. NAG COPYRIGHT 1989. C .. Scalar Arguments .. DOUBLE PRECISION X C .. Executable Statements .. D02PAZ = X RETURN END INTEGER FUNCTION P01ABF(IFAIL,IERROR,SRNAME,NREC,REC) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C MARK 13 REVISED. IER-621 (APR 1988). C MARK 13B REVISED. IER-668 (AUG 1988). C C P01ABF is the error-handling routine for the NAG Library. C C P01ABF either returns the value of IERROR through the routine C name (soft failure), or terminates execution of the program C (hard failure). Diagnostic messages may be output. C C If IERROR = 0 (successful exit from the calling routine), C the value 0 is returned through the routine name, and no C message is output C C If IERROR is non-zero (abnormal exit from the calling routine), C the action taken depends on the value of IFAIL. C C IFAIL = 1: soft failure, silent exit (i.e. no messages are C output) C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) C IFAIL =-13: soft failure, noisy exit but standard messages from C P01ABF are suppressed C IFAIL = 0: hard failure, noisy exit C C For compatibility with certain routines included before Mark 12 C P01ABF also allows an alternative specification of IFAIL in which C it is regarded as a decimal integer with least significant digits C cba. Then C C a = 0: hard failure a = 1: soft failure C b = 0: silent exit b = 1: noisy exit C C except that hard failure now always implies a noisy exit. C C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. C C .. Scalar Arguments .. INTEGER IERROR, IFAIL, NREC CHARACTER*(*) SRNAME C .. Array Arguments .. CHARACTER*(*) REC(*) C .. Local Scalars .. INTEGER I, NERR CHARACTER*72 MESS C .. External Subroutines .. EXTERNAL P01ABZ, X04AAF, X04BAF C .. Intrinsic Functions .. INTRINSIC ABS, MOD C .. Executable Statements .. IF (IERROR.NE.0) THEN C Abnormal exit from calling routine IF (IFAIL.EQ.-1 .OR. IFAIL.EQ.0 .OR. IFAIL.EQ.-13 .OR. * (IFAIL.GT.0 .AND. MOD(IFAIL/10,10).NE.0)) THEN C Noisy exit CALL X04AAF(0,NERR) DO 20 I = 1, NREC CALL X04BAF(NERR,REC(I)) 20 CONTINUE IF (IFAIL.NE.-13) THEN WRITE (MESS,FMT=99999) SRNAME, IERROR CALL X04BAF(NERR,MESS) IF (ABS(MOD(IFAIL,10)).NE.1) THEN C Hard failure CALL X04BAF(NERR, * ' ** NAG hard failure - execution terminated' * ) CALL P01ABZ ELSE C Soft failure CALL X04BAF(NERR, * ' ** NAG soft failure - control returned') END IF END IF END IF END IF P01ABF = IERROR RETURN C 99999 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', * ' =',I6) END SUBROUTINE P01ABZ C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C Terminates execution when a hard failure occurs. C C ******************** IMPLEMENTATION NOTE ******************** C The following STOP statement may be replaced by a call to an C implementation-dependent routine to display a message and/or C to abort the program. C ************************************************************* C .. Executable Statements .. STOP END DOUBLE PRECISION FUNCTION X01AAF(X) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE VALUE OF THE MATHEMATICAL CONSTANT PI. C C X IS A DUMMY ARGUMENT C C IT MAY BE NECESSARY TO ROUND THE REAL CONSTANT IN THE C ASSIGNMENT STATEMENT TO A SMALLER NUMBER OF SIGNIFICANT C DIGITS IN ORDER TO AVOID COMPILATION PROBLEMS. IF SO, THEN C THE NUMBER OF DIGITS RETAINED SHOULD NOT BE LESS THAN C . 2 + INT(FLOAT(IT)*ALOG10(IB)) C WHERE IB IS THE BASE FOR THE REPRESENTATION OF FLOATING- C . POINT NUMBERS C . AND IT IS THE NUMBER OF IB-ARY DIGITS IN THE MANTISSA OF C . A FLOATING-POINT NUMBER. C C .. Scalar Arguments .. DOUBLE PRECISION X C .. Executable Statements .. X01AAF = 3.14159265358979323846264338328D0 RETURN END DOUBLE PRECISION FUNCTION X02AJF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. C RETURNS B**(1-P) OTHERWISE C C .. Executable Statements .. x02ajf = 1.110223024625157D-16 RETURN END DOUBLE PRECISION FUNCTION X02AKF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS B**(EMIN-1) (THE SMALLEST POSITIVE MODEL NUMBER) C C .. Executable Statements .. x02akf = 1d-300 c x02akf = 2.9387358770557188D-39 RETURN END DOUBLE PRECISION FUNCTION X02AMF() C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS THE 'SAFE RANGE' PARAMETER C I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT C FOR ANY X WHICH SATISFIES X.GE.Z AND X.LE.1/Z C THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER C ERROR C C -X C 1.0/X C SQRT(X) C LOG(X) C EXP(LOG(X)) C Y**(LOG(X)/LOG(Y)) FOR ANY Y C C .. Executable Statements .. x02amf = 1d-300 c x02amf = 2.9387358770557188D-39 RETURN END SUBROUTINE X04AAF(I,NERR) C MARK 7 RELEASE. NAG COPYRIGHT 1978 C MARK 7C REVISED IER-190 (MAY 1979) C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 14 REVISED. IER-829 (DEC 1989). C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER C (STORED IN NERR1). C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO C VALUE SPECIFIED BY NERR. C C .. Scalar Arguments .. INTEGER I, NERR C .. Local Scalars .. INTEGER NERR1 C .. Save statement .. SAVE NERR1 C .. Data statements .. DATA NERR1/6/ C .. Executable Statements .. IF (I.EQ.0) NERR = NERR1 IF (I.EQ.1) NERR1 = NERR RETURN END SUBROUTINE X04BAF(NOUT,REC) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C X04BAF writes the contents of REC to the unit defined by NOUT. C C Trailing blanks are not output, except that if REC is entirely C blank, a single blank character is output. C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, C then no output occurs. C C .. Scalar Arguments .. INTEGER NOUT CHARACTER*(*) REC C .. Local Scalars .. INTEGER I C .. Intrinsic Functions .. INTRINSIC LEN C .. Executable Statements .. IF (NOUT.GE.0) THEN C Remove trailing blanks DO 20 I = LEN(REC), 2, -1 IF (REC(I:I).NE.' ') GO TO 40 20 CONTINUE C Write record to external file 40 WRITE (NOUT,FMT=99999) REC(1:I) END IF RETURN C 99999 FORMAT (A) END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'marcopak' then mkdir 'marcopak' fi cd 'marcopak' if test -f 'marcomod.f' then echo shar: will not over-write existing file "'marcomod.f'" else cat << SHAR_EOF > 'marcomod.f' module MARCOMOD private public:: sl01f,sl02f,sl02fm,sl03f,sl03fm,sl04f,sl04fm,sl05f, + sl05fm,sl06fm,sl07f,sl07fm contains C SL01F & SL02F complete text (including NAG routines) SUBROUTINE SL01F(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,AINFO,BINFO, & SYM,WK,IWK,KNOB,TOL,IFAIL) C This routine counts the number of eigenvalues in a given range C [emin,emax]. If emax lies in the continuous spectrum and emin C does not, then an estimate will be made of the infimum of the C continuous spectrum and this will be returned in lieu of emax. C The eigenvalues are counted by returning kmin and kmax, the C indices of the lowest and highest index eigenvalues lying in C the interval. C C Brief specification: C C a,b: real. On entry, a and b specify the actual interval (a,b)on which C the (regular or singular) problem is posed. On exit, they C specify the (possibly shorter) interval on which it was solved. C emin, emax: real. On entry, [emin,emax] is the interval in which the C code must count the eigenvalues. If this interval intersects C the continuous spectrum then provided emin does not lie in the C continuous spectrum the routine will locate a number elam such C that the infimum of the continuous spectrum is believed C to occur in (elam,elam+tol). The routine will then use the C interval [emin,elam] in place of [emin,emax]: it will count C the eigenvalues in this interval, and return elam in place C of emax. If emin is in the continuous spectrum or within a C distance tol of the continuous spectrum, the routine will C return with kmin = kmax = -10. C coeffn: subroutine supplied by the user. Specification: C SUBROUTINE coeffn(x,p,q,w) C DOUBLE PRECISION x,p,q,w C C x: On entry, a value of the independent variable in (a,b). C Must be unchanged on exit. C C p,q,w: On exit these must specify the values of the C C coefficients p(x), q(x), w(x). C setup: subroutine supplied by the user. Specification: C SUBROUTINE setup(y,pdy,elam,iend) C INTEGER iend C DOUBLE PRECISION y,pdy,elam C C iend: Specifies the end of the interval at which the b.c.'s C C are to be applied. If iend = 0, then B.C.'s are required C C at the left hand end, while iend = 1 requests b.c.'s at C C the right-hand end. Must not be changed on exit. C C y,pdy: On exit, these must specify values of y(.) and py'(.) C C which are consistent with the B.C.'s at the appropriate C C end. C C elam: On entry, elam specifies the current value of the C C eigenparameter. It is included since in many problems C C the boundary conditions are dependent on this parameter. C kmin, kmax: integers. On exit, these specify respectively the highest and C lowest indices of eigenvalues in [emin,elam], where elam is emax C if emax is not in the continuous spectrum, and is an estimate of C the infimum of the continuous spectrum otherwise. (see C description of emax above). If emin is within a distance tol of C the inf of the continuous spectrum then kmin and kmax will both C be set to -10 on exit. If the routine detects no eigenvalues in C the range [emin,emax] then it will return with kmin > kmax. C knob: integer. The maximum number of endpoint shifts which the routine C is allowed to make in the course of the computation. Default C value of 60 should only be increased in special circumstances. C To select default value set knob < 10 on entry. The minimum C value of knob within the routine is therefore 10. On exit, C knob will have either the default value if selected, or the C value assigned by the user on entry. C ainfo: character*1. On entry ainfo must be set as follows: C If x=a is a finite regular endpoint set ainfo = 'R' or ainfo = 'r'. C If x=a is a finite singular endpoint set ainfo ='S' or ainfo = 's' C If a=-infinity set ainfo = 'I' or ainfo = 'i'. C binfo: character*1. On entry binfo must be set as follows: C If x=b is a finite regular endpoint set binfo = 'R' or binfo = 'r'. C If x=b is a finite singular endpoint set binfo ='S' or binfo = 's' C If b=+infinity set binfo = 'I' or ainfo = 'i'. C sym: logical. If the problem is symmetric about the midpoint (a+b)/2 C (taken as 0 if the endpoints are infinite) then set sym = .true., C otherwise sym should be .false. C wk: real array of dimension precisely (0:iwk,1:4). Used as workspace. C iwk: integer. On entry, iwk must have a value which satisfies C iwk > 10 + knob, C where knob has the value defined by the user if this is > 9, C and is otherwise equal to 60. Unchanged on exit. C tol: real. This parameter controls the computation in various ways. It is C used in the location of the infimum of the continuous spectrum C if necessary (see description of emax given above) and generally C any eigenvalue which lies within the interval [emin,elam] (where C elam = min(emax,inf{Continuous Spectrum}) with at least tol C clearance from each end, should be counted. Unchanged on exit. C ifail: integer. The error flag. C .. Parameters .. INTEGER IPARAM PARAMETER (IPARAM=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,B,EMAX,EMIN,TOL INTEGER IFAIL,IWK,KMAX,KMIN,KNOB LOGICAL SYM CHARACTER AINFO*1,BINFO*1 C .. C .. Array Arguments .. DOUBLE PRECISION WK(0:IWK,1:4) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. INTEGER ASTAT,BSTAT,ICOFUN,IFO,ISING,N,NREC CHARACTER SRNAME*6 C .. C .. Local Arrays .. DOUBLE PRECISION PARAMS(1:IPARAM) CHARACTER REC(2)*80 C .. C .. External Functions .. cc DOUBLE PRECISION X02AJF cc INTEGER P01ABF cc EXTERNAL X02AJF,P01ABF C .. C .. External Subroutines .. cc EXTERNAL CNTER C .. C .. Intrinsic Functions .. INTRINSIC ABS,MAX C .. SRNAME = 'SL01F' ICOFUN = 2 IFO = IFAIL IFAIL = 0 IF (AINFO.EQ.'R' .OR. AINFO.EQ.'r') THEN ASTAT = 0 ELSE IF (AINFO.EQ.'S' .OR. AINFO.EQ.'s') THEN ASTAT = 1 ELSE IF (AINFO.EQ.'I' .OR. AINFO.EQ.'i') THEN ASTAT = 2 ELSE ASTAT = 3 END IF IF (BINFO.EQ.'R' .OR. BINFO.EQ.'r') THEN BSTAT = 0 ELSE IF (BINFO.EQ.'S' .OR. BINFO.EQ.'s') THEN BSTAT = 1 ELSE IF (BINFO.EQ.'I' .OR. BINFO.EQ.'i') THEN BSTAT = 2 ELSE BSTAT = 3 END IF C Check input for errors. IF (IWK.LT.10 .OR. (ASTAT.EQ.3) .OR. (BSTAT.EQ.3) .OR. & (SYM.AND.ASTAT.NE.BSTAT) .OR. EMAX.LT.EMIN+TOL .OR. & TOL.LT.0.D0 .OR. (ASTAT.NE.2.AND.BSTAT.NE.2.AND.B.LE.A) .OR. & ABS(IFO).GT.1) THEN IFAIL = 1 NREC = 1 IF (ASTAT.EQ.3) THEN WRITE (REC,FMT=9010) GO TO 100 END IF IF (BSTAT.EQ.3) THEN WRITE (REC,FMT=9020) GO TO 100 END IF IF (SYM .AND. ASTAT.NE.BSTAT) THEN WRITE (REC,FMT=9030) GO TO 100 END IF IF (IWK.LT.10) THEN WRITE (REC,FMT=9000) IWK GO TO 100 END IF NREC = 2 IF (EMAX.LT.EMIN+TOL) THEN WRITE (REC,FMT=9040) EMIN,EMAX GO TO 100 END IF NREC = 1 IF (TOL.LT.0.D0) THEN WRITE (REC,FMT=9050) TOL GO TO 100 END IF NREC = 2 IF (ASTAT.NE.2 .AND. BSTAT.NE.2 .AND. B.LE.A) THEN WRITE (REC,FMT=9060) A,B GO TO 100 END IF IF (ABS(IFO).GT.1) THEN WRITE (REC,FMT=9070) IFO IFO = -1 GO TO 100 END IF END IF 9000 FORMAT ('** IWK must be at least 10, IWK =',i8) 9010 FORMAT ('** Invalid input value of AINFO') 9020 FORMAT ('** Invalid input value of BINFO') 9030 FORMAT ('** For symmetric problems AINFO must equal BINFO') 9040 FORMAT ('** EMAX-EMIN-TOL must be non-negative,',/,'** EMIN = ', & G18.8,' EMAX = ',G18.8) 9050 FORMAT ('** TOL must be strictly positive, TOL =',g18.8) 9060 FORMAT ('** For regular problems A < B is required ',/,'** A = ', & g18.8,' B = ',g18.8) 9070 FORMAT ('** On entry IFAIL must be -1, 0 or +1 ',/, & '** Input value of IFAIL = ',i8) C END of error trapping IF (ASTAT.NE.0 .AND. BSTAT.EQ.0) THEN ISING = 1 ELSE IF (BSTAT.NE.0 .AND. ASTAT.EQ.0) THEN ISING = 2 ELSE IF (ASTAT.NE.0 .AND. BSTAT.NE.0) THEN ISING = 3 ELSE ISING = 0 END IF IF (ASTAT.EQ.2 .AND. BSTAT.EQ.2) THEN A = -1.D0 B = 1.D0 ICOFUN = 1 GO TO 10 END IF IF (ASTAT.EQ.2 .AND. BSTAT.NE.2) THEN A = -1.D0 B = B/ (1.D0+ABS(B)) ICOFUN = 1 END IF IF (BSTAT.EQ.2 .AND. ASTAT.NE.2) THEN A = A/ (1.D0+ABS(A)) B = 1.D0 ICOFUN = 1 END IF 10 N = IWK CALL CNTER(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,ISING,SYM,WK(0,1), & WK(1,2),WK(1,3),WK(1,4),N,KNOB,TOL,PARAMS,IPARAM, & ICOFUN,IFAIL) IF (IFAIL.NE.0) THEN GO TO (20,30,40,50,60,70,80,90) IFAIL 20 WRITE (REC,FMT=9080) 9080 FORMAT ('** Input parameter error') GO TO 100 30 WRITE (REC,FMT=9090) 9090 FORMAT ('** Integration halted: step-size too small') GO TO 100 40 WRITE (REC,FMT=9100) 9100 FORMAT ('** Invalid boundary conditions') GO TO 100 50 WRITE (REC,FMT=9110) 9110 FORMAT ('** IWK was too small for given TOL') GO TO 100 60 WRITE (REC,FMT=9120) 9120 FORMAT ('** Uncertainty about start of continuous spectrum') GO TO 100 70 WRITE (REC,FMT=9130) 9130 FORMAT ( & '** Too many attempts to find start of continuous spectrum' & ) GO TO 100 80 WRITE (REC,FMT=9140) 9140 FORMAT ('Tighter TOL required for computation of KMAX') GO TO 100 90 WRITE (REC,FMT=9150) 9150 FORMAT ('May be eigenvalues close to EMIN or EMAX') GO TO 100 END IF IF (ICOFUN.EQ.1) THEN A = A/MAX((1.D0-ABS(A)),X02AJF(1.D0)) B = B/MAX((1.D0-ABS(B)),X02AJF(1.D0)) END IF RETURN 100 IFAIL = P01ABF(IFO,IFAIL,SRNAME,NREC,REC) RETURN END SUBROUTINE SL01F C -------------------------------------------------------------------- SUBROUTINE CNTER(A,B,EMIN,EMAX,KMIN,KMAX,COEFFN,SETUP,ISING,ISYMM, & XMESH,PP,QP,WP,N,MAXITS,TOL,PARAMS,IPARAM,ICOFUN, & IFAIL) C .. Scalar Arguments .. DOUBLE PRECISION A,B,EMAX,EMIN,TOL INTEGER ICOFUN,IFAIL,IPARAM,ISING,KMAX,KMIN,MAXITS,N LOGICAL ISYMM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM),PP(1:N),QP(1:N),WP(1:N), & XMESH(0:N) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION AT,ATRUNC,BT,BTRUNC,CSPEC,DLAM,ELAM,FX,H, & PI,RMAX,RTRY,TRUNC,XS,YS INTEGER I,IFLAG,IND,IP1,IR,MAXEVS,NEVS,NP LOGICAL IRELOC C .. C .. Local Arrays .. DOUBLE PRECISION C(17) C .. C .. External Functions .. cc DOUBLE PRECISION DACC,X01AAF,X02ALF cc EXTERNAL DACC,X01AAF,X02ALF C .. C .. External Subroutines .. cc EXTERNAL C05AZF,CEKSPK,COARSE,INITIA C .. C .. Intrinsic Functions .. INTRINSIC ABS,DBLE,INT,LOG,MAX,SQRT C .. C Initial error traps: IF (ABS(IFAIL).GT.1) THEN IFAIL = -ABS(IFAIL) GO TO 60 END IF IF (N.LT.10 .OR. TOL.LE.0.D0 .OR. TOL.GE.1.D0 .OR. B.LE.A .OR. & EMIN.GE. (EMAX-TOL)) THEN IFAIL = 1 GO TO 60 END IF C End of input checks. C Set some constants: PI = X01AAF(1.D0) IF (MAXITS.LT.10) MAXITS = 60 MAXEVS = (LOG(EMAX-EMIN)-LOG(TOL))/LOG(2.D0) + 20 NP = 10 C Stage 1: set up an initial discretisation of the problem. IF (ISING.EQ.0) THEN C Omit the check for continuous spectrum, go straight to the C counting stage. ATRUNC = A BTRUNC = B AT = A BT = B CALL COARSE(NP,ATRUNC,BTRUNC,XMESH,0) CALL INITIA(COEFFN,PP,QP,WP,XMESH,NP,PARAMS,IPARAM,ICOFUN) GO TO 30 ELSE IF (ISING.EQ.1) THEN ATRUNC = A + (B-A)/6.D0 BTRUNC = B ELSE IF (ISING.EQ.2) THEN BTRUNC = B - (B-A)/6.D0 ATRUNC = A ELSE TRUNC = (B-A)/6.D0 ATRUNC = A + TRUNC BTRUNC = B - TRUNC END IF C Get the first mesh and coefficient functions: CALL COARSE(NP,ATRUNC,BTRUNC,XMESH,0) CALL INITIA(COEFFN,PP,QP,WP,XMESH,NP,PARAMS,IPARAM,ICOFUN) C Check to see if emax is in continuous spectrum: IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(EMAX,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 C If emax is not in the continuous spectrum then set the truncated C endpoints and go to the eigenvalue counting stage: IF (CSPEC.LT.0.D0) THEN ATRUNC = AT BTRUNC = BT GO TO 30 END IF C If we are here then it means that emax is in the continuous spectrum. C In such a case, we must also check emin. IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(EMIN,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 IF (CSPEC.GT.0.D0) THEN C In this case emin is also in the continuous spectrum. There are therefore C no eigenvalues in [emin,emax]. Denote this by setting kmin = kmax = -10. KMIN = -10 KMAX = KMIN RETURN END IF C If we are here then it means that the infimum of the continous spectrum C lies somewhere in (emin,emax]. We must find this infimum. We will do so C by using a rootfinding routine (C05AZF). Because we are rootfinding on a C discontinuous function, C05AZF will be using bisection. XS = EMIN YS = EMAX IND = -1 IR = 1 NEVS = 0 FX = -1.D0 C(1) = 1.D0 IFLAG = 1 10 CALL C05AZF(XS,YS,FX,TOL/20.D0,IR,C,IND,IFLAG) IF (IND.EQ.0) THEN IF (IFLAG.NE.0 .AND. IFLAG.NE.5) THEN IFAIL = 5 GO TO 60 END IF GO TO 20 END IF IF (IND.LT.2 .OR. IND.GT.4) THEN IFAIL = 5 GO TO 60 END IF NEVS = NEVS + 1 IF (NEVS.GT.MAXEVS) THEN IFAIL = 6 GO TO 60 END IF IRELOC = .true. AT = ATRUNC BT = BTRUNC CALL CEKSPK(XS,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,FX,DLAM,PARAMS,IPARAM,ICOFUN,IFAIL) IF (IFAIL.NE.0) GO TO 60 GO TO 10 20 ELAM = XS C We have now found elam, an approximation to the infimum of the continuous C spectrum. We will proceed to the counting stage with EMAX = MAX(EMIN,ELAM-TOL/10.D0) IF (EMAX.LE.EMIN) THEN KMIN = -10 KMAX = KMIN RETURN END IF C Counting stage: we now count the number of eigenvalues in [emin,emax]. C We do this by finding kmin and kmax, respectively the lowest and highest C indices of eigenvalues in this interval. We need to be able to compute C D(emin) and D(emax) to fairly high accuracy. C Stage 1 of counting: find truncated ends. 30 IRELOC = .false. AT = XMESH(0) BT = XMESH(NP) CALL CEKSPK(EMAX,A,B,AT,BT,XMESH,PP,QP,WP,NP,N,MAXITS,TOL,COEFFN, & SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS,IPARAM,ICOFUN, & IFAIL) IF (IFAIL.NE.0) GO TO 60 IF (CSPEC.GT.0.D0) THEN IFAIL = 7 GO TO 60 END IF C We now have truncated ends given by at,bt C and so we can make two extra-accurate evaluations of D(elam). This C will require the use of our stepsize-controlling version of the C Prufer theta-integrator. C Evaluation of D(emin): ELAM = EMIN 40 IF (ISYMM) THEN RMAX = 0.5D0* (A+B) IP1 = NP/2 ELSE RMAX = (ELAM*WP(1)-QP(1))/PP(1) IP1 = 1 DO 50 I = 1,NP - 1 RTRY = (ELAM*WP(I)-QP(I))/PP(I) IF (RMAX.LT.RTRY) THEN IP1 = I RMAX = RTRY END IF 50 CONTINUE RMAX = XMESH(IP1) END IF C H = MIN((XMESH(1)-XMESH(0)), (XMESH(NP)-XMESH(NP-1))) H = (XMESH(NP)-XMESH(0))/DBLE(NP) DLAM = DACC(ELAM,AT,BT,RMAX,COEFFN,SETUP,H,TOL/1.D1,PARAMS,IPARAM, & ICOFUN,IFAIL) IF (IFAIL.NE.0) GO TO 60 C WRITE (6,*) 'ELAM,D/PI:',ELAM,DLAM/(4.D0*ATAN(1.D0)) IF (ELAM.LT.EMAX) THEN IF (DLAM.LE.0.D0) THEN KMIN = 0 IF (DLAM.GT. (-TOL)) IFAIL = 8 ELSE DLAM = DLAM/PI KMIN = INT(DLAM) RMAX = ABS(DLAM-KMIN) IF (RMAX.GT. (1.D0-TOL) .OR. RMAX.LT.TOL) IFAIL = 8 IF ((DLAM-DBLE(KMIN)*PI).NE.0.D0) KMIN = KMIN + 1 END IF ELAM = EMAX GO TO 40 ELSE DLAM = DLAM/PI KMAX = INT(DLAM) RMAX = ABS(DLAM-KMAX) IF (RMAX.GT. (1.D0-TOL) .OR. RMAX.LT.TOL) IFAIL = 8 END IF IF (KMIN.GT.KMAX) THEN KMIN = -10 KMAX = -10 END IF C Ifail = 8 means that there may be an eigenvalue lurking very close to C one of the endpoints, which would be difficult to detect. C Successful termination: A = AT B = BT RETURN 60 RETURN END SUBROUTINE CNTER C ------------------------------------------------------------------- DOUBLE PRECISION FUNCTION DACC(ELAM,A,B,C,COEFFN,SETUP,H,TOL, & PARAMS,IPARAM,ICOFUN,IFAIL) C .. Parameters .. DOUBLE PRECISION ONE,HALF,TRD PARAMETER (ONE=1.D0,HALF=5.D-1,TRD=ONE/3.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,B,C,ELAM,H,TOL INTEGER ICOFUN,IFAIL,IPARAM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION ABSERR,DI,DTH1,ERR,FAC,HMAX,HO,P,PDY,PI,Q,SCALE, & SNEW,THETA,THETA1,THETA2,W,X1,XFIN,XMID,XO,Y INTEGER ICNT,KNTRY LOGICAL STEP1,TRANS C .. C .. External Functions .. cc DOUBLE PRECISION SCL,X01AAF,X02AJF cc EXTERNAL SCL,X01AAF,X02AJF C .. C .. External Subroutines .. cc EXTERNAL BCONS,COEFUN,ONESTP C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,MAX,MIN,SIGN,SQRT C .. PI = X01AAF(1.D0) IFAIL = 0 STEP1 = .TRUE. HMAX = ABS(H) HO = SIGN(1.D0,H)*MIN(SQRT(TOL),ABS(H)) H = HO ICNT = 0 C Step from a to c XO = A XFIN = C DI = ONE KNTRY = 0 X1 = XO + H CALL COEFUN((XO+X1)*HALF,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. TRANS = ICOFUN .EQ. 1 .OR. ICOFUN .EQ. 3 CALL BCONS(SETUP,Y,PDY,ELAM,XO,P,Q,W,0,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN THETA = ATAN2(Y,PDY) C ------------------------- Stepping stage ------------------------- 10 THETA1 = THETA THETA2 = THETA SCALE = ONE SNEW = ONE X1 = XO + H IF ((X1-XFIN)*DI.GT.0.D0) X1 = XFIN C Do one-step + two half-steps to integrate with error estimate. XMID = HALF* (XO+X1) CALL COEFUN(XMID,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XO,X1,DI,SCALE,THETA1,P,ELAM*W-Q) CALL COEFUN(HALF* (XO+XMID),P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XO,XMID,DI,SNEW,THETA2,P,ELAM*W-Q) CALL COEFUN(HALF* (XMID+X1),P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL ONESTP(XMID,X1,DI,SNEW,THETA2,P,ELAM*W-Q) THETA1 = SCL(THETA1,ONE/SCALE) THETA2 = SCL(THETA2,ONE/SNEW) C Error estimate: ERR = (THETA1-THETA2)*TRD ABSERR = ABS(ERR) C WRITE (6,6000) XO,XMID,X1,H,ABSERR C6000 FORMAT ('XO,XMID,X1,H,ABSERR:',5G16.6) IF (ABSERR.GT.TOL) THEN C WRITE (6,*) 'Error too large, repeating step' KNTRY = KNTRY + 1 IF (ABS(H).LT.SQRT(X02AJF(H)) .AND. KNTRY.GT.16) THEN IFAIL = 2 RETURN END IF H = H*MIN(8.D-1, (TOL/ABSERR)**TRD) GO TO 10 END IF IF (ABSERR.LT.0.8D0*TOL .AND. KNTRY.EQ.0) THEN C WRITE (6,*) 'Error too small' C IF (step1) WRITE (6,*) 'Repeating step' H = H/MAX(2.D-1, (ABSERR/ (0.8D0*TOL))**TRD) FAC = HMAX*MAX(ONE,XMID**2) H = SIGN(1.D0,H)*MIN(FAC,ABS(H)) IF (STEP1 .AND. ABS(H).LT.FAC) GO TO 10 END IF STEP1 = .FALSE. KNTRY = 0 THETA = THETA2 - ERR XO = X1 ICNT = ICNT + 1 IF ((XFIN-X1)*DI.GT.0.D0) GO TO 10 C --------------------- END of stepping stage ------------------------ C If we have got here then it means that we have finished an integration. IF (DI.GT.0.D0) THEN DTH1 = THETA XO = B XFIN = C DI = -ONE H = HO*DI X1 = XO + H CALL COEFUN((XO+X1)*HALF,P,Q,W,COEFFN,PARAMS,IPARAM,ICOFUN) CALL BCONS(SETUP,Y,PDY,ELAM,XO,P,Q,W,1,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN THETA = PI - ATAN2(Y,PDY) STEP1 = .TRUE. GO TO 10 END IF DACC = DTH1 - THETA RETURN END FUNCTION DACC C ------------------------------------------------------------------- SUBROUTINE CEKSPK(ELAM,A,B,AT,BT,XMESH,PP,QP,WP,N,NMAX,MAXITS,TOL, & COEFFN,SETUP,IRELOC,ISYMM,CSPEC,DLAM,PARAMS, & IPARAM,ICOFUN,IFAIL) C Routine for spectral analysis. Tells when a value of elam is in the C continuous spectrum. Used as part of a rootfinding process to find C the infimum of the continuous spectrum. C C Brief Specification: C C elam: real. On entry elam must specify the value of lambda to be C tested. Unchanged on exit. C a,b: real. On entry, the endpoints of the whole interval on which C the problem is posed. Unchanged on exit. C at,bt: real. On entry, proposed initial truncation points from which C stepping towards the singular endpoint(s) will take place. C On exit, the points at which the algorithm stopped the C truncation procedure. C xmesh: real array of dimension at least (0:nmax). On entry, the C entries xmesh(0),..,xmesh(n) specify a mesh covering the C interval (at,bt), and must be strictly increasing with C xmesh(0) = at, xmesh(n) = bt. On exit, if ireloc was C .true. on entry then xmesh will be unchanged; otherwise, C xmesh will contain the mesh which was in use when the C interval truncation algorithm stopped, and n will be the C number of intervals in this mesh. C pp,qp,wp: real arrays of dimension at least (1:nmax). On entry, the C entries in pp(1),..,pp(n), qp(1),..,qp(n), wp(1),..,wp(n) C specify coefficient values. On exit they will be unchanged C if ireloc was .true. on entry, otherwise they will be C altered to agree with the new xmesh array (see above). C n: integer. On entry, n specifies the number of intervals in the C current mesh. If ireloc is .true. on entry then n will be C unchanged on exit; otherwise n will be the number of C intervals in the new mesh (see xmesh above). C nmax: integer. On entry, nmax specifies the maximum amount of storage C which is available for meshpoints and coefficient values. C nmax must be strictly greater than n, and must satisfy C nmax > n + maxits C if there is to be no risk failure. Unchanged on exit. C maxits: integer. The maximum number of moves of truncated endpoints C which will be made before declaring that no suitable C truncated endpoints can be found and that elam must lie C in the continuous spectrum. In general maxits = 60 will be C adequate, but at tight tolerances tol it may be advisable C to increase maxit. Unchanged on exit. C tol: real. On entry, the tolerance to which two successive approximations C to D(elam) with different truncated endpoints must agree before C the endpoints are deemed to be satisfactory and elam is C declared not to lie in the continuous spectrum. Unchanged on C exit. C COEFFN, SETUP: subroutines supplied by the user for the evaluation of C coefficients and boundary conditions. C ireloc: logical. Controls whether or not the arrays xmesh, pp, qp, wp, C and the integer n are changed on exit. See above. Unchanged C on exit. C isymm: logical. On entry, isymm = .true. tells the routine that the C problem is symmetric about (a+b)/2. In this case the truncated C interval (at,bt) should be symmetric in the same way. C Unchanged on exit. C cspec: real. This parameter is for output only and serves to tell the user C whether or not elam was found to be in the continuous spectrum. C cspec = -1 on exit ==> elam is not in continuous spectrum. C cspec = +1 on exit ==> elam is in the continuous spectrum. C dlam: real. On exit, this parameter gives the final approximation obtained C for D(elam). Only meaningful if cspec = -1 on exit. C ifail: integer. The error flag. C C END of brief specification. C Declarations: C .. Parameters .. DOUBLE PRECISION HALF,TQTR PARAMETER (HALF=5.D-1,TQTR=7.5d-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION A,AT,B,BT,CSPEC,DLAM,ELAM,TOL INTEGER ICOFUN,IFAIL,IPARAM,MAXITS,N,NMAX LOGICAL IRELOC,ISYMM C .. C .. Array Arguments .. DOUBLE PRECISION PARAMS(1:IPARAM),PP(1:NMAX),QP(1:NMAX), & WP(1:NMAX),XMESH(0:NMAX) C .. C .. Subroutine Arguments .. EXTERNAL COEFFN,SETUP C .. C .. Local Scalars .. DOUBLE PRECISION ATRUNC,BTRUNC,DL1,DL2,DTHA,DTHB,FYNYT,OVFLOW,PDY, & SC,SHIFT,TH,TOLRED,Y,H INTEGER I,I1,I2,IP1,ISING,ISINGO,ITIME,KNTR LOGICAL TRANS C .. C .. External Functions .. cc DOUBLE PRECISION D,DTHETA,X01AAF,X02AHF,X02ALF cc EXTERNAL D,DTHETA,X01AAF,X02AHF,X02ALF C .. C .. Intrinsic Functions .. INTRINSIC ABS,ATAN2,MIN,SQRT C .. C .. External Subroutines .. cc EXTERNAL BCONS,COEFUN C .. OVFLOW = SQRT(X02ALF(1.D0)) IFAIL = 0 TOLRED = TOL*1.D-1 C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. TRANS = ICOFUN .EQ. 1 .OR. ICOFUN .EQ. 3 C Stage 1: Find out which ends are singular. IF (A.EQ.AT .AND. B.EQ.BT) THEN CSPEC = -1 RETURN ELSE IF (A.LT.AT .AND. B.EQ.BT) THEN ISING = 1 ELSE IF (A.EQ.AT .AND. B.GT.BT) THEN ISING = 2 ELSE ISING = 3 END IF ISINGO = ISING C Stage 2: Initialise the stepping procedure. C Set size of coarse mesh: SHIFT = XMESH(1) - XMESH(0) C Mark ends of input arrays: I1 = 1 I2 = N C END of marking; special action if two singular points: ITIME = 0 KNTR = 0 IF (ISING.EQ.3) THEN ITIME = 1 ISING = 1 END IF C First approximation to D(elam): DL1 = D(ELAM,N,N/2,PP,QP,WP,XMESH,SETUP,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN 10 IF (ISING.EQ.1) THEN C Add a point at the left hand end. IF ((N+1).GT.NMAX) THEN IFAIL = 4 RETURN END IF DO 20 I = N,1,-1 IP1 = I + 1 XMESH(IP1) = XMESH(I) PP(IP1) = PP(I) QP(IP1) = QP(I) WP(IP1) = WP(I) 20 CONTINUE XMESH(1) = XMESH(0) XMESH(0) = XMESH(0) - MIN(SHIFT,TQTR* (XMESH(0)-A)) CALL COEFUN(HALF* (XMESH(1)+XMESH(0)),PP(1),QP(1),WP(1), & COEFFN,PARAMS,IPARAM,ICOFUN) N = N + 1 I1 = I1 + 1 I2 = I2 + 1 END IF C END of adding point at left-hand side. IF (ISING.EQ.2 .OR. ISYMM) THEN C Add point at right hand side. N = N + 1 IF (N.GT.NMAX) THEN IFAIL = 4 RETURN END IF XMESH(N) = XMESH(N-1) + MIN(SHIFT,TQTR* (B-XMESH(N-1))) CALL COEFUN(HALF* (XMESH(N)+XMESH(N-1)),PP(N),QP(N),WP(N), & COEFFN,PARAMS,IPARAM,ICOFUN) END IF DL2 = D(ELAM,N,N/2,PP,QP,WP,XMESH,SETUP,TRANS,IFAIL) IF (IFAIL.NE.0) RETURN C Check for convergence IF (ABS(DL2-DL1).LT.TOLRED) GO TO 30 C If we got past the last block then we have to make another step KNTR = KNTR + 1 IF (KNTR.GE.MAXITS) GO TO 50 H = ABS(XMESH(1) - XMESH(0)) FYNYT = (ELAM*WP(1)-QP(1))/PP(1) IF ((FYNYT.GE.0.0D0.AND.H*SQRT(ABS(FYNYT)).GE.1.0D-2*X02AHF(0.D0)) & .OR.ABS(FYNYT).GE.OVFLOW) GO TO 50 H = ABS(XMESH(N)-XMESH(N-1)) FYNYT = (ELAM*WP(N)-QP(N))/PP(N) IF ((FYNYT.GE.0.0D0.AND.H*SQRT(ABS(FYNYT)).GE.1.0D-2*X02AHF(0.D0)) & .OR.ABS(FYNYT).GE.OVFLOW) GO TO 50 C If we got past the last line then we have not yet decided whether or C not we are in the continuous spectrum. Do another endpoint shift: DL1 = DL2 GO TO 10 C Various exits now follow C First the exit in case where dl2-dl1 has converged - we are not in the C continuous spectrum. 30 IF (ITIME.EQ.1 .AND. .NOT.ISYMM) THEN C We have two endpoints to do and only one has been done -- go back & do C the other. ITIME = 2 ISING = 2 DL1 = DL2 GO TO 10 END IF AT = XMESH(0) BT = XMESH(N) C One last check for continuous spectrum: IF (ISINGO.NE.0) THEN DTHA = 0.D0 DTHB = 0.D0 IF (ISINGO.GT.1) THEN CALL BCONS(SETUP,Y,PDY,ELAM,BT,PP(N),QP(N),WP(N),1,TRANS, & IFAIL) IF (IFAIL.NE.0) RETURN TH = ATAN2(Y,PDY) SC = 1.D0 BTRUNC = BT DTHB = DTHETA(TH,SC,ELAM,BTRUNC,B,COEFFN,PARAMS,IPARAM, & ICOFUN) END IF IF (ISINGO.NE.2) THEN CALL BCONS(SETUP,Y,PDY,ELAM,AT,PP(1),QP(1),WP(1),0,TRANS, & IFAIL) IF (IFAIL.NE.0) RETURN TH = ATAN2(Y,PDY) SC = 1.D0 ATRUNC = XMESH(0) DTHA = DTHETA(TH,SC,ELAM,ATRUNC,A,COEFFN,PARAMS,IPARAM, & ICOFUN) END IF IF ((DTHA+DTHB).GE.1.D1*X01AAF(1.D0)) GO TO 50 END IF IF (IRELOC) THEN N = I2 - I1 + 1 XMESH(0) = XMESH(I1-1) DO 40 I = 1,N IP1 = I1 + I - 1 XMESH(I) = XMESH(IP1) PP(I) = PP(IP1) QP(I) = QP(IP1) WP(I) = WP(IP1) 40 CONTINUE END IF DLAM = DL2 CSPEC = -1.D0 RETURN C Next the case where dl2-dl1 did not converge - we are in the continuous C spectrum 50 AT = XMESH(0) BT = XMESH(N) IF (IRELOC) THEN N = I2 - I1 + 1 XMESH(0) = XMESH(I1-1) DO 60 I = 1,N IP1 = I1 + I - 1 XMESH(I) = XMESH(IP1) PP(I) = PP(IP1) QP(I) = QP(IP1) WP(I) = WP(IP1) 60 CONTINUE END IF DLAM = DL2 CSPEC = 1.D0 RETURN C END of routine END SUBROUTINE CEKSPK C --------------------------------------------------------------------- C --------------------- Source from SL02F ----------------------------- C --------------------------------------------------------------------- SUBROUTINE sl02f(elam,a,b,k,ainfo,binfo,sym,tol,coeffn,setup,n,wk, & iwk,wksmal,ismal,knobs,ifail) C This routine finds the kth eigenvalue elam of a regular or singular Sturm- C Liouville problem C C -(p(x)y'(x))'+q(x)y(x) = elam.w(x).y(x) (a0) and (ifail.ne.12.OR.14) the calculation must be stopped: IF (ifail.EQ.12 .OR. ifail.EQ.14) GO TO 40 IF (ifail.NE.0) GO TO 100 C END OF ERROR TRAPPING. C This has generated a mesh which is appropriate for the highest index C eigenvalue. We now test the mesh on all the other eigenfunctions to make C sure that it is appropriate for the lower index eigenvalues. In the C process we generate coarse-mesh approximations to the lower index C eigenpairs. istart = 0 iend = no icfn = icofun C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN icfn = icofun + 1 END IF 40 IF (m.GT.1) THEN C IFAIL has one of the values 0, 12, 14. IF (ifail.NE.0) GO TO 60 DO 50 i = 1,m C Adapt the mesh appropriately for the K(i)th eigenfunction. C First compute K(i)th coarse-mesh eigenvalue. IF (i.EQ.1) THEN IF (elam(1,i).GT.elam(1,m)) THEN eps = max(eps,half* (elam(1,i)-elam(1,m))) elam(1,i) = elam(1,m) - two*eps END IF END IF IF (i.GT.1 .AND. i.LT.m) THEN IF (elam(1,i).LT.elam(1,i-1) .OR. & elam(1,i).GT.elam(1,m)) THEN elam(1,i) = dble((k(i)-k(i-1))/ (k(m)-k(i-1)))**2 elam(1,i) = elam(1,i-1) + & elam(1,i)* (elam(1,m)-elam(1,i-1)) eps = half* (elam(1,m)-elam(1,i-1)) END IF END IF iq = np/2 trans = .false. toloc = 0.D0 CALL solve(elam(1,i),eps,k(i),np,iq,maxit,setup, & wksmal(1,2),wksmal(1,3),wksmal(1,4), & wksmal(0,1),trans,toloc,iflag) C Error trap: IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C END of error trap. C Next compute coarse mesh eigenfunction: elam0 = elam(1,i) CALL norfun(wksmal(0,5),wksmal(0,6),wksmal(0,7),smatch, & elam0,zero,k(i),np,iq,wksmal(1,2),wksmal(1,3), & wksmal(1,4),wksmal(0,1),setup,trans,iflag) elam(1,i) = elam0 C Error trap (only possibility is IFLAG = 3) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C END of error trap. C Now use coarse mesh eigenfunction to adapt the mesh. shift = .true. IF (i.EQ.1) shift = .false. CALL admesh(elam(1,i),wksmal(1,2),wksmal(1,3),wksmal(1,4), & wksmal(0,1),wksmal(0,5),wksmal(0,6), & wksmal(0,7),wk(1,2),wk(1,3),wk(1,4),wk(0,1),n, & np,tol,iq,shift,istart,iend,params,iparam, & coeffn,icfn,iflag) IF (iflag.NE.0) THEN C Only possibilities are IFAIL = 10 and IFAIL = 11 ifail = iflag GO TO 100 END IF n = iend iend = no 50 CONTINUE C Put the correct function values back into the arrays pp,qp,wp: CALL initia(coeffn,wk(1,2),wk(1,3),wk(1,4),wk(0,1),n,params, & iparam,icfn) C We now have an adapted mesh, and it is stored in the places 0,1,..,iend C on the mesh. This is our fine mesh with which we continue the computation. CALL check(n,wk(1,2),iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF 60 DO 80 i = 1,m eps = elam(2,i)/10.D0 imatch = 1 dummy = (elam(1,i)*wk(imatch,4)-wk(imatch,3))/wk(imatch,2) DO 70 ii = 1,n compar = (elam(1,i)*wk(ii,4)-wk(ii,3))/wk(ii,2) IF (compar.GT.dummy) THEN imatch = ii dummy = compar END IF 70 CONTINUE IF (sym) imatch = n/2 IF (i.EQ.1) THEN IF (elam(1,i).GT.elam(1,m)) THEN eps = max(eps,half* (elam(1,i)-elam(1,m))) elam(1,i) = elam(1,m) - two*eps END IF END IF IF (i.GT.1 .AND. i.LT.m) THEN IF (elam(1,i).LT.elam(1,i-1) .OR. & elam(1,i).GT.elam(1,m)) THEN elam(1,i) = dble((k(i)-k(i-1))/ (k(m)-k(i-1)))**2 elam(1,i) = elam(1,i-1) + & elam(1,i)* (elam(1,m)-elam(1,i-1)) eps = half* (elam(1,m)-elam(1,i-1)) END IF END IF trans = .false. toloc = tol/10.D0 CALL solve(elam(1,i),eps,k(i),n,imatch,maxit,setup, & wk(1,2),wk(1,3),wk(1,4),wk(0,1),trans,toloc, & iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF 80 CONTINUE END IF C Now halve the mesh and compute improved approximations: newmsh = 2*n icfn = 2 CALL fillin(n,newmsh,wk(0,1),wk(1,2),wk(1,3),wk(1,4),coeffn, & params,iparam,icfn) imatch = 2*imatch IF (sym) imatch = newmsh/2 n = newmsh C Recompute the eigenvalues: DO 90 i = 1,m eps = elam(2,i)/20.D0 elam0 = elam(1,i) trans = .false. toloc = 0.D0 CALL solve(elam0,eps,k(i),n,imatch,maxit,setup,wk(1,2), & wk(1,3),wk(1,4),wk(0,1),trans,toloc,iflag) IF (iflag.NE.0) THEN ifail = iflag GO TO 100 END IF C Aitken extrapolation: elam(2,i) = (elam(1,i)-elam0)/3.D0 elam(1,i) = elam0 - elam(2,i) 90 CONTINUE a = wk(0,1) b = wk(n,1) wk(0,2) = imatch IF (ifail.NE.12 .AND. ifail.NE.14) ifail = 0 RETURN 100 IF (ifail.NE.0) THEN C Output error trapping nrec = 1 GO TO (110,120,130,140,150,160,170,180,190, & 200,210,220,230,240) ifail 110 WRITE (rec,FMT=9120) 9120 FORMAT ('** Parameter error') GO TO 250 120 WRITE (rec,FMT=9130) 9130 FORMAT ('** P(X) is not strictly positive') GO TO 250 130 WRITE (rec,FMT=9140) 9140 FORMAT ('** Invalid boundary conditions') GO TO 250 140 WRITE (rec,FMT=9150) k(m) 9150 FORMAT ('** Cannot find eigenvalue with index',I6) GO TO 250 150 WRITE (rec,FMT=9160) 9160 FORMAT ('** Danger of floating overflow near endpoints') GO TO 250 160 WRITE (rec,FMT=9170) maxit 9170 FORMAT ('**',i8, & ' iterations were not enough to locate an eigenvalue') GO TO 250 170 WRITE (rec,FMT=9180) maxit 9180 FORMAT ('** More than ',i8, & ' attempts to bracket an eigenvalue') GO TO 250 180 WRITE (rec,FMT=9190) knobs(1) 9190 FORMAT ('** More than ',i8,' attempts to truncate interval') GO TO 250 190 WRITE (rec,FMT=9200) 9200 FORMAT (' ** Miss-distance non-monotone over a wide range') GO TO 250 200 WRITE (rec,FMT=9210) 9210 FORMAT ('** Meshing routine could make no further progress') GO TO 250 210 WRITE (rec,FMT=9220) 9220 FORMAT ('** Meshing routine ran out of storage') GO TO 250 220 WRITE (rec,FMT=9230) 9230 FORMAT ( & '** Meshing routine ran out of storage and used ad-hoc mesh' & ) GO TO 250 230 WRITE (rec,FMT=9240) 9240 FORMAT ('** Serious internal error: try different TOL') GO TO 250 240 WRITE (rec,FMT=9250) 9250 FORMAT ('** Cannot obtain required accuracy ') GO TO 250 END IF 250 ifail = p01abf(ifo,ifail,srname,nrec,rec) RETURN END SUBROUTINE sl02fm C --------------------------------------------------------------------- SUBROUTINE admesh(elam,ptemp,qtemp,wtemp,xtemp,rlog,theta,scale, & pp,qp,wp,xmesh,n,ntemp,tol,imatch,shift,istart, & iend,params,iparam,coeffn,icofun,ifail) C The mesh is stored in the places xmesh(n),..,xmesh(istart) and the rest of C the array contains no useful information. RLOG(0:ntemp), SCALE(0:ntemp), C THETA(0:ntemp) and ELAM are available to represent the eigenfunction with C which the adaptation of the mesh will be carried out. C Initialising Stage: C Ifail: C .. Parameters .. DOUBLE PRECISION half,safe1,safe2,one,sixth,trd,twelf,zero,two, & tenth,fifth PARAMETER (half=5.D-1,safe1=9.D-1,safe2=8.D-1,one=1.D0, & sixth=one/6.D0,trd=one/3.D0,twelf=half*sixth,zero=0.D0, & two=2.D0,tenth=1.D-1,fifth=two*tenth) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,tol INTEGER icofun,iend,ifail,imatch,iparam,istart,n,ntemp LOGICAL shift C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(0:iend),ptemp(1:ntemp), & qp(1:iend),qtemp(1:ntemp),rlog(0:ntemp), & scale(0:ntemp),theta(0:ntemp),wp(1:iend), & wtemp(1:ntemp),xmesh(0:iend),xtemp(0:ntemp) C .. C .. Local Scalars .. DOUBLE PRECISION errest,errpm,errpp,errqm,errqp,errw1,errw2,errwm, & errwp,gamma,h,omega1,omega2,omega3,p1,p2,p3,q1, & q2,q3,toloc,tolow,w1,w2,w3,weight,x1,x2,x3 INTEGER i,idi,j,k,kntr LOGICAL phase1,repeat C .. C .. Local Arrays .. DOUBLE PRECISION pdyval(0:1),xvals(0:1),yvals(0:1) C .. C .. External Subroutines .. cc EXTERNAL coefun,efun C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min,sign,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION hloc cc EXTERNAL hloc C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. ifail = 0 IF (iend.EQ.istart) RETURN C Local Tolerance: toloc = tol tolow = toloc*safe2 phase1 = .true. repeat = .false. k = 0 kntr = 0 i = istart idi = 1 IF (iend.LT.istart) idi = -1 C We use the array PP as storage for the new mesh being formed. x1 = xmesh(i) x3 = xmesh(i+idi) pp(i) = x1 10 h = x3 - x1 x2 = half* (x1+x3) IF (repeat) THEN p1 = p3 q1 = q3 w1 = w3 ELSE CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icofun) END IF CALL coefun(x2,p2,q2,w2,coeffn,params,iparam,icofun) CALL coefun(x3,p3,q3,w3,coeffn,params,iparam,icofun) C Do error estimation: ****************************************** IF (x1.LE.x3) THEN errw1 = w1 - w2 errw2 = w3 - w2 errwm = elam*errw1 errwp = elam*errw2 errpp = (one/p3-one/p2) errpm = (one/p1-one/p2) errqp = (q3-q2) errqm = (q1-q2) xvals(0) = x1 xvals(1) = x3 ELSE errw1 = w3 - w2 errw2 = w1 - w2 errwp = elam*errw2 errwm = elam*errw1 errpm = (one/p3-one/p2) errpp = (one/p1-one/p2) errqm = (q3-q2) errqp = (q1-q2) xvals(0) = x3 xvals(1) = x1 END IF IF (phase1) THEN CALL efun(xvals,yvals,pdyval,elam,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,1,ntemp,imatch) ELSE IF (x1.LE.x3) THEN IF (.NOT.repeat) THEN yvals(0) = yvals(1) pdyval(0) = pdyval(1) END IF CALL efun(xvals(1),yvals(1),pdyval(1),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) ELSE IF (.NOT.repeat) THEN yvals(1) = yvals(0) pdyval(1) = pdyval(0) END IF CALL efun(xvals(0),yvals(0),pdyval(0),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) END IF END IF C END of eigenfunction evaluation. errest = twelf*abs(h* (errw1*min(one,yvals(0)**2)+errw2*min(one, & yvals(1)**2))) errwm = errwm - errqm errwp = errwp - errqp C There are a number of other different error monitors to be used, depending C on whether the behaviour of solutions of the differential equation. C Compute Prufer radius for use: weight = half*sqrt(yvals(0)**2+pdyval(0)**2+yvals(1)**2+ & pdyval(1)**2) C Measure rate of oscillation: omega2 = (elam*w2-q2)/p2 C WEIGHT may be quite small near the endpoints, where other eigenfunctions C do not decay just as fast. Since weight is supposed to take account of these C other eigenfunctions we adjust its value where appropriate: IF (omega2.LT.zero) THEN IF (q2.LT.two*max(one,abs(elam))*w2) THEN C It is not clear that there is any representative rate of decay for nearby C eigenfunctions: a small increase in elam could change everything. weight = max(weight,tenth) ELSE C We can be reasonably confident that the rate of decay of nearby C eigenfunctions will be at least half as fast as that of the present C eigenfunction. gamma = sqrt((two*max(one,elam)*w2-q2)/ (elam*w2-q2)) weight = max(weight,weight**gamma) END IF ELSE weight = max(weight,min(tenth,two*weight)) END IF C First error monitor, valid in regions which are not highly oscillatory. C This controls the components of the eigenfunction which are not linearly C dependent on the exact eigenfunction: errest = max(errest,sixth*weight* & abs(h* (abs(yvals(0)*errwm+yvals(1)*errwp)/sqrt(max(one, & omega2))+abs(errpm*pdyval(0)+errpp*pdyval(1))))) C Second error monitor, uses Simpson's rule to measure a local contribution C to the Green's formula for eigenvalue error: errest = max(errest,sixth*abs(h* ((yvals(0)**2)*errwm+ & (yvals(1)**2)*errwp+errpm* (pdyval(0)**2)+ & errpp* (pdyval(1)**2))))/max(one,abs(elam)) IF ((h**2)*omega2.GT.half) THEN C Safeguard in highly oscillatory regions: in such regions we can control C eigenvalue error by controlling error in Prufer theta: omega1 = sqrt(abs(elam*w1-q1)/p1) omega3 = sqrt(abs(elam*w3-q3)/p3) omega2 = sqrt(omega2) errest = max(errest,abs(two* (p2/w2)*omega2* (omega1- & two*omega2+omega3)*h)/max(one,elam)) END IF C All the error monitors here are O(h**3) for small h. C END of error estimation. ******************************************** C Decide what to do next, depending on size of error: IF (errest.LE.toloc) THEN C Check that the error is not TOO small IF (errest.LT.tolow .AND. k.EQ.0) THEN h = h/max(fifth, (errest/tolow)**trd) IF (phase1) THEN repeat = .true. kntr = kntr + 1 IF (kntr.LT.8) GO TO 10 END IF END IF C the error test has been passed; move to next step if there is one. repeat = .false. phase1 = .false. i = i + idi pp(i) = x3 IF ((xmesh(n)-x3)*idi.LE.zero) THEN C The end of the range has been reached GO TO 20 END IF C If we are here then it means that the meshing must continue. x1 = x3 x3 = x3 + sign(one,h)*min(abs(h),hloc(x3,xmesh,n)) IF ((xmesh(n)-x3)*idi.LE.zero) THEN x3 = xmesh(n) END IF k = 0 GO TO 10 ELSE repeat = .true. C the error test has been failed; reduce the stepsize and repeat step. C Error traps: IF ((iend-i)*idi.LE.zero) THEN C Run out of space ifail = 11 GO TO 40 END IF k = k + 1 IF (k.GE.8) THEN C Coefficients are too nasty ifail = 10 GO TO 40 END IF C END of error traps h = h*min(safe1, (toloc/errest)**trd) x3 = x1 + h GO TO 10 END IF 20 CONTINUE C We now have an adapted mesh, which is stored in the array spaces C pp(istart),..,pp(i). We copy it into the corresponding slots in the array C xmesh. iend = i DO 30 j = istart,iend,idi xmesh(j) = pp(j) 30 CONTINUE 40 RETURN END SUBROUTINE admesh C ------------------------------------------------------------------------ DOUBLE PRECISION FUNCTION HLOC(X,XMESH,N) C .. Parameters .. DOUBLE PRECISION HALF,ONE PARAMETER (HALF=5.D-1,ONE=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION X INTEGER N C .. C .. Array Arguments .. DOUBLE PRECISION XMESH(0:N) C .. C .. Local Scalars .. INTEGER J DOUBLE PRECISION XHI,XLO,HHI,HLO,S C .. IF (X.LE.HALF*(XMESH(0)+XMESH(1))) THEN HLOC = XMESH(1)-XMESH(0) ELSE IF (X.GE.HALF*(XMESH(N-1)+XMESH(N))) THEN HLOC = XMESH(N)-XMESH(N-1) ELSE DO 10 J = 1,N-1 XLO = HALF*(XMESH(J-1)+XMESH(J)) XHI = HALF*(XMESH(J)+XMESH(J+1)) IF (X.GE.XLO.AND.X.LT.XHI) THEN HHI = XMESH(J+1)-XMESH(J) HLO = XMESH(J)-XMESH(J-1) S = (X-XLO)/(XHI-XLO) HLOC = S*HHI + (ONE-S)*HLO RETURN END IF 10 CONTINUE END IF RETURN END FUNCTION HLOC C --------------------------------------------------------------------- C --------------------- Source from SNEW ----------------------------- C --------------------------------------------------------------------- SUBROUTINE eigen(elam0,elam,eps,a,b,k,n,ntemp,imatch,np,ising, & isymm,lknt,maxit,coeffn,setup,pp,qp,wp,xmesh, & ptemp,qtemp,wtemp,xtemp,rlog,theta,scale,tol, & noxtrp,params,iparam,icofun,ifail) C .. Parameters .. DOUBLE PRECISION three,six,smatch,one,zero,two,half,tqtr,p9 PARAMETER (three=3.D0,six=6.D0,smatch=1.D0,one=1.D0,zero=0.D0, & two=2.D0,half=5.D-1,tqtr=three/4.D0,p9=9.D-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION a,b,elam,elam0,eps,tol INTEGER icofun,ifail,imatch,iparam,ising,isymm,k,lknt,maxit,n,np, & ntemp LOGICAL noxtrp C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(1:n),ptemp(1:ntemp),qp(1:n), & qtemp(1:ntemp),rlog(0:ntemp),scale(0:ntemp), & theta(0:ntemp),wp(1:n),wtemp(1:ntemp),xmesh(0:n), & xtemp(0:ntemp) C .. C .. Subroutine Arguments .. EXTERNAL coeffn,setup C .. C .. Local Scalars .. DOUBLE PRECISION atrunc,btrunc,diff,dtha,dthb,elamo,epso,fynyt, & ovflow,pc,pi,qc,rat1,rat2,rat3,rmatch,sc,shift, & store,th,tolmsh,toloc,wc,xc INTEGER i,icfn,idmmy,ifc,ifo,imesh,iq,iref,isingo,itime,itw, & itwm1,knt,lknto,newmsh,nmesh,npo LOGICAL trans C .. C .. External Functions .. cc DOUBLE PRECISION dtheta,x01aaf,x02ahf,x02alf cc EXTERNAL dtheta,x01aaf,x02ahf,x02alf C .. C .. External Subroutines .. cc EXTERNAL check,coarse,coefun,fillin,initia,mmesh,norfun,solve C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,max,min,nint,sqrt C .. C Set a big number to approximate infinity: ovflow = sqrt(x02alf(1.D0)) C .. C Check input for errors (and change in certain cases) C IF (abs(ifail).GT.1) THEN ifail = -abs(ifail) GO TO 150 END IF C IF (n.LT.10 .OR. tol.LE.0.0D0 .OR. eps.LE.0.0D0 .OR. b.LE.a) THEN ifail = 1 GO TO 150 END IF C C End of input checks. C pi = x01aaf(pi) C C Store the input values of certain parameters which may be changed by the C code: C ifo = ifail lknto = lknt isingo = ising elamo = elam0 epso = eps ifail = 0 C trans determines when we are to perform transformation of independent C variables: C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. trans = icofun .EQ. 1 .OR. icofun .EQ. 3 C C Set default values on certain parameters: C IF (maxit.EQ.0) maxit = 100 IF (lknt.EQ.0) lknt = 60 IF (np.LE.5) np = 10 C np is stored so that it may be used to control the maximum mesh size: npo = np C The paramter itime is needed to count how many ends have been truncated if C the problem is singular: itime = 0 C The parameter iref is needed to count how many times we have tried to C find a mesh to give decent accuracy, without success: iref = 0 C C Set the match-point integer for the computation of the initial approximation C to the eigenvalue. C iq = np/2 C C Set up artificial end-points according to the value of the ISING parameter C IF (ising.EQ.0) THEN C The problem is regular atrunc = a btrunc = b ELSE IF (ising.EQ.1) THEN C Singular point at x=a; truncate: atrunc = a + (b-a)/six btrunc = b ELSE IF (ising.EQ.2) THEN C Singular point at x=b; truncate: atrunc = a btrunc = b - (b-a)/six ELSE C Both ends are singular; truncate: atrunc = a + (b-a)/six btrunc = b - (b-a)/six END IF C Set the initial step size for approaching a singular endpoint: shift = (btrunc-atrunc)/np C Compute initial approximation with truncated end-points: C 1: Set up an initial mesh of np points: CALL coarse(np,atrunc,btrunc,xmesh,0) C 2: Set up the arrays of coefficient function values at the mesh centres: CALL initia(coeffn,pp,qp,wp,xmesh,np,params,iparam,icofun) C 3: Check the array PP to see that p is an admissible coefficient function (>0) ifc = 0 CALL check(np,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C C 4: Solve the discrete S-L problem on the small mesh of np points to get C initial approximation to the eigenvalue: C toloc = tol/10.D0 CALL solve(elam0,eps,k,np,iq,maxit,setup,pp,qp,wp,xmesh,trans, & toloc,ifail) C Special treatment of regular problems: do not need to change the C end-points inview of the estimate obtained. Note also that no failures C are tolerated for regular problems. IF (ising.EQ.0) THEN nmesh = n/2 IF (ifail.NE.0) GO TO 150 C Go straight to the final two sweeps on adapted meshes, with C Richardson extrapolation. GO TO 50 END IF C ******************************************************************** C **Only singular problems from here until the statement labelled 50** C ******************************************************************** C IF (ifail.EQ.7) THEN C This can happen if we truncate too far in and so we reset the ifail and C elam0 to their old values and choose new truncated end-points. ifail = 0 elam0 = elamo END IF C Other types of failure are not to be tolerated! IF (ifail.NE.0) GO TO 150 C We now have an initial estimate of the eigenvalue, from which C we can decide how to truncate the interval. IF (ising.EQ.3) THEN C We pretend that the problem is only singular at x=a and deal with truncation C at that end first. We set itime=1 to denote the fact that we are dealing with C the first of two singular points in this case. itime = 1 ising = 1 END IF C We can now start the sequence of computations which leads to the C choice of the truncated endpoint(s). knt counts the number of attempts C to find each suitable endpoint, and must not exceed lknt. knt = 1 C Add an extra point closer to the singular point under consideration: 20 np = np + 1 iq = np/2 IF (ising.EQ.1) THEN C Add the point between atrunc and a: DO 30 i = np,2,-1 pp(i) = pp(i-1) qp(i) = qp(i-1) wp(i) = wp(i-1) xmesh(i) = xmesh(i-1) 30 CONTINUE xmesh(1) = xmesh(0) xmesh(0) = xmesh(0) - min(shift,tqtr* (xmesh(0)-a)) atrunc = xmesh(0) xc = xmesh(0) + half* (xmesh(1)-xmesh(0)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(1) = pc qp(1) = qc wp(1) = wc END IF IF (isymm.EQ.1) THEN C This is a special case: the interval has two singular endpoints and must be C truncated symmetrically, so we must add an extra point at the other end too: np = np + 1 iq = np/2 END IF IF (ising.EQ.2 .OR. isymm.EQ.1) THEN C Add in an extra mesh-point between btrunc and b. In the case isymm = 1 this C is done purely to preserve symmetry. xmesh(np) = xmesh(np-1) + min(shift,tqtr* (b-xmesh(np-1))) btrunc = xmesh(np) xc = xmesh(np-1) + half* (xmesh(np)-xmesh(np-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(np) = pc qp(np) = qc wp(np) = wc END IF C Check that p(x) never vanishes or becomes negative: ifc = 0 CALL check(np,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C Extra point or points have been added; compute the eigenvalue and see if C the the extra point(s) have made it change by much (store the old value in C elam0 for comparison) elam = elam0 CALL solve(elam,eps,k,np,iq,maxit,setup,pp,qp,wp,xmesh,trans, & toloc,ifail) C WRITE (6,FMT=9000) xmesh(0),xmesh(np),elam,ifail IF (ifail.EQ.7) THEN C This failure can be caused by truncating too much when certain asymptotic C forms are used for the boundary conditions. We must see at which end of the C interval the eigenfunction is oscillating most rapidly, and concentrate on C that end provided this will not risk overflow. rat1 = (elam*wp(1)-qp(1))/pp(1) rat2 = (elam*wp(np)-qp(np))/pp(np) C Check for danger of overflow: rat3 = max(rat1,rat2) IF ((rat3.GE.0.D0.AND.sqrt(abs(rat3)).GE.1.0D-2*x02ahf(0.D0)) & .OR.max(abs(rat1),abs(rat2)).GE.ovflow) THEN a = xmesh(0) b = xmesh(np) GO TO 150 END IF C End of overflow check. Now select the end of the interval with most rapid C oscillations. Note that if the problem has only one singular end then C itime = 0 so there is no danger of treating a regular end as singular. IF (itime.EQ.1 .AND. isymm.NE.1) THEN IF (rat2.GT.rat1) THEN ising = 2 ELSE ising = 1 END IF END IF ifail = 0 elam = elam0 diff = 10.0D0*tol GO TO 40 C End of special treatment for IFAIL = 7 failures. END IF C Other failures (ifail \neq 7) are not tolerated! IF (ifail.NE.0) GO TO 150 diff = abs(elam-elam0)/max(one,abs(elam)) C There is no danger in setting eps = diff; for if diff=0 then we will C not be calling SOLVE without resetting eps to its original value epso. eps = diff 40 knt = knt + 1 elam0 = elam IF (knt.GE.lknt) THEN C Cannot find a suitable end-point in lknt steps ifail = 8 a = xmesh(0) b = xmesh(np) GO TO 150 END IF C Less than lknt steps taken, but endpoints not yet satisfactory: IF (diff.GT.tol) THEN C Check to see if endpoint(s) can be moved without danger of overflow. fynyt = (elam*wp(1)-qp(1))/pp(1) IF ((fynyt.GE.0.D0.AND.sqrt(abs(fynyt)).GE. & 1.0D-2*x02ahf(0.D0)) .OR. abs(fynyt).GE.ovflow) THEN ifail = 5 a = xmesh(0) b = xmesh(np) GO TO 150 END IF fynyt = (elam*wp(np)-qp(np))/pp(np) IF ((fynyt.GE.0.D0.AND.sqrt(abs(fynyt)).GE. & 1.0D-2*x02ahf(0.D0)) .OR. abs(fynyt).GE.ovflow) THEN ifail = 5 a = xmesh(0) b = xmesh(np) GO TO 150 END IF C If we get through the last loop then we can indeed move an endpoint. Loop C back to 20 to do this. GO TO 20 END IF C C If we are doing a problem with TWO SINGULAR POINTS and itime=1 then only the C end of the interval where the eigenfunction oscillates most rapidly has been C dealt with so far. IF (itime.EQ.1 .AND. isymm.NE.1) THEN IF (ising.EQ.1) THEN ising = 2 ELSE ising = 1 END IF elam0 = elam C See, I told you we would reset eps! eps = epso knt = 1 itime = 2 C Loop back to start truncation procedure for the other end. GO TO 20 END IF C ******************************************************************* C **** End of interval truncation for singular problems *********** C ******************************************************************* C We now have some approximations to the eigenvalue, as well as C suitable truncated endpoints. atrunc = xmesh(0) btrunc = xmesh(np) C We are now ready to solve our problem on the truncated interval. We will C compute two approximations in order to get an error estimate. elam0 = elam eps = epso C Our first fine mesh will have only half as many points as our eventual mesh nmesh = n/2 C Find a suitable matching point (it is at this stage that regular problems C come back under consideration -- see the GO TO 50 above). 50 IF (isymm.EQ.1) THEN rmatch = half* (atrunc+btrunc) ELSE rmatch = xmesh(iq) store = elam0*wp(iq) - qp(iq) DO 60 idmmy = 1,np - 1 IF ((elam0*wp(idmmy)-qp(idmmy)).GT.store) THEN store = elam0*wp(idmmy) - qp(idmmy) rmatch = xmesh(idmmy) END IF 60 CONTINUE END IF C C In order to form the mesh for the final two sweeps, we need to know a C decent approximation to the eigenfunction, which we get by using a coarse C mesh of at most ntemp or 100 points. 70 IF (np.LT.min(n/2,ntemp/2,50)) THEN C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN icfn = icofun + 1 DO 80 i = np,1,-1 itw = 2*i itwm1 = itw - 1 xmesh(itw) = xmesh(i) xmesh(itwm1) = half* (xmesh(i)+xmesh(i-1)) 80 CONTINUE np = 2*np GO TO 70 ELSE CALL fillin(np,2*np,xmesh,pp,qp,wp,coeffn,params,iparam, & icofun) np = 2*np GO TO 70 END IF END IF C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) THEN xmesh(0) = xmesh(0)/ (one-abs(xmesh(0))) icfn = icofun + 1 C From now on we abandon transformed coordinates: trans = .false. DO 90 i = 1,np xmesh(i) = xmesh(i)/ (one-abs(xmesh(i))) CALL coefun(half* (xmesh(i-1)+xmesh(i)),pp(i),qp(i),wp(i), & coeffn,params,iparam,icfn) 90 CONTINUE END IF xtemp(0) = xmesh(0) DO 100 i = 1,np xtemp(i) = xmesh(i) ptemp(i) = pp(i) qtemp(i) = qp(i) wtemp(i) = wp(i) 100 CONTINUE ifc = 0 CALL check(np,ptemp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF ising = isingo eps = epso iq = np/2 toloc = 0.D0 CALL solve(elam0,eps,k,np,iq,maxit,setup,ptemp,qtemp,wtemp,xtemp, & trans,toloc,ifc) C WRITE (6,FMT=*) elam0,np,ifc IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF CALL norfun(rlog,theta,scale,smatch,elam0,zero,k,np,iq,ptemp, & qtemp,wtemp,xtemp,setup,trans,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C Check all singular problems to make sure we have not strayed into the C continuous spectrum. IF (isingo.NE.0) THEN dtha = zero dthb = zero IF (isingo.GT.1) THEN th = theta(np) sc = scale(np) dthb = dtheta(th,sc,elam0,btrunc,b,coeffn,params,iparam, & icofun) END IF IF (isingo.NE.2) THEN th = theta(0) sc = scale(0) dtha = dtheta(th,sc,elam0,atrunc,a,coeffn,params,iparam, & icofun) END IF IF ((dtha+dthb).GE.two*pi) THEN ifail = 4 ising = isingo lknt = lknto a = atrunc b = btrunc RETURN END IF END IF C End of check for continuous spectrum. C We can now choose the new mesh using an appropriate equidistribution C process. This is done by calling the routine MMESH. C Note the special status of the IFC parameter for this routine. On C entry, it equals the value which IFAIL had on entry to EIGEN, and C if that value was 1, then an emergency mesh will be used if the C routine runs out of space. If this happens then ifc will be set to C 12 on exit. C imesh = nmesh IF (isymm.EQ.1) imesh = (imesh-1)/2 ifc = ifo C Store the eigenvalue corresponding to the eigenfunction which is C used for meshing; this will be useful later. elamo = elam0 C tolmsh = tol 110 CALL mmesh(rmatch,atrunc,0,elam0,coeffn,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,np,iq,xmesh,pp,qp,wp,imesh,tolmsh,npo, & params,iparam,icofun,ifc) C C Error handling: C IF (ifc.NE.0) THEN C The routine cannot produce a mesh to meet the users tolerance C within the allocated storage, or has ground to a halt because the C coefficient functions are too pathological C ifail = ifc IF (ifail.NE.12) GO TO 150 END IF C C End of error handling; produce second half of mesh; C in symmetric case we just need to reflect the mesh through the midpoint: C IF (isymm.EQ.1) THEN C Just reflect the mesh through its right-hand endpoint if the problem C is symmetric. nmesh = 2*imesh xmesh(nmesh) = xmesh(0) DO 120 i = 1,imesh xmesh(imesh+i) = two*rmatch - xmesh(imesh-i) pp(imesh+i) = pp(imesh-i+1) qp(imesh+i) = qp(imesh-i+1) wp(imesh+i) = wp(imesh-i+1) 120 CONTINUE ELSE C End of symmetric case. C ifc = ifo CALL mmesh(rmatch,btrunc,imesh,elam0,coeffn,rlog,theta,scale, & xtemp,ptemp,qtemp,wtemp,np,iq,xmesh,pp,qp,wp,nmesh, & tolmsh,npo,params,iparam,icofun,ifc) C C Error handling: C IF (ifc.NE.0) THEN C The routine cannot produce a mesh to meet the users tolerance C within the allocated storage, or has ground to a halt because the C coefficient functions are too pathological C ifail = ifc IF (ifail.NE.12) GO TO 150 END IF C C End of error handling C if no error has occured then nmesh is now set to a new value which C is equal to the actual number of intervals in the computed mesh C and is less than or equal to its input value. C END IF C We now have a mesh which can be stored within the user-specified C storage, and which is adapted in a suitable manner to help achieve C the user-specified tolerance. we compute the first approxmation to C the eigenvalue by using this mesh. C C Check that the array pp has no zero or negative entries: ifc = 0 CALL check(nmesh,pp,ifc) IF (ifc.NE.0) THEN ifail = ifc GO TO 150 END IF C C We are now ready for the first of the two final computations. IFAIL now C has one of two values 0 or 12, the second (if it arises) coming from the C use of an emergency mesh. ifc = 0 toloc = tol/100.D0 CALL solve(elam0,eps,k,nmesh,imesh,maxit,setup,pp,qp,wp,xmesh, & trans,toloc,ifc) eps = epso/1.D2 C C Store the eigenvalue estimate for extrapolation later C elam = elam0 C C Error handling: IF (ifc.NE.0) THEN IF (ifail.EQ.12) GO TO 130 ifail = ifc GO TO 150 END IF IF (noxtrp) THEN a = atrunc b = btrunc n = nmesh imatch = imesh ising = isingo lknt = lknto RETURN END IF C Now we halve the mesh-size and repeat the process to obtain a C better eigenvalue approximation. the mesh-size is halved by C adding in all the midpoints of intervals in the current mesh. C the arrays pp,qp,wp also must be updated, and all this is done C by the routine fillin. storage is always adequate since, if it C were not, this would have been detected by the mesh routine above. 130 newmsh = 2*nmesh C Reset match-point index: imesh = 2*imesh icfn = icofun C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1) THEN icfn = 2 ELSE IF (icofun.EQ.3) THEN icfn = 4 END IF CALL fillin(nmesh,newmsh,xmesh,pp,qp,wp,coeffn,params,iparam,icfn) C eps = epso/100.d0 ifc = 0 toloc = 0.D0 CALL solve(elam0,eps,k,newmsh,imesh,maxit,setup,pp,qp,wp,xmesh, & trans,toloc,ifc) C C Error handling: IF (ifc.NE.0) THEN C ic = imesh n = newmsh a = atrunc b = btrunc IF (ifail.GT.1) THEN GO TO 150 ELSE ifail = ifc GO TO 150 END IF END IF C C Error estimate: eps = (elam-elam0)/three elam0 = elam0 - eps IF (abs(eps)/max(one,abs(elam0)).GT.tol** (two/three) .AND. & ifail.EQ.0) THEN C The accuracy achieved is unacceptable. Go back to the meshing stage with C a reduced minimum mesh size. IF (iref.GT.1) THEN C We have already done this too many times. The problem is simply C too nasty. Fail with appropriate error flag ifail = 14 GO TO 140 END IF iref = iref + 1 rat1 = sqrt(abs(max(one,abs(elam0))* (tol** (two/three))/eps)) npo = nint(dble(npo)/ (tqtr*rat1)) tolmsh = tolmsh*min(p9,rat1** (three/two)) elam0 = elamo nmesh = n/2 imesh = nmesh IF (isymm.EQ.1) imesh = (imesh-1)/2 GO TO 110 END IF C Use elam0 to store the eigenvalue corresponding to the coarse-mesh C eigenfunction which was used for automatic meshing: 140 elam = elamo C C Prepare to return to the user; make sure a and b have the same values C as on entry, not to mention ising. also we set n = newmesh so that the C user can see how many mesh-points were used. lknt = lknto ising = isingo n = newmsh imatch = imesh a = atrunc b = btrunc C write(6,*) 'np before exiting EIGEN: ',np C Either an emergency mesh has been used (IFAIL = 12), or else the accuracy C achieved is inadequate (IFAIL = 14), or else the routine has completed C its run successfully. IF (ifail.NE.12 .AND. ifail.NE.14) ifail = 0 150 RETURN C9000 FORMAT (' ALFA: ',G18.12,' BETA: ',G18.12,' ELAM: ',D10.4, C & ' IFAIL ',I2) END SUBROUTINE eigen C-------------------------------------------------------------------- DOUBLE PRECISION FUNCTION dtheta(theta,scale,elam,bt,b,coeffn, & params,iparam,icofun) C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=5.D-1) C .. C .. Scalar Arguments .. DOUBLE PRECISION b,bt,elam,scale,theta INTEGER icofun,iparam C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION di,ovflow,p,q,qbig,s,th,w,x,xend,xo INTEGER icount C .. C .. External Functions .. cc DOUBLE PRECISION x02alf cc EXTERNAL x02alf C .. C .. External Subroutines .. c EXTERNAL coefun,onestp C .. C .. Intrinsic Functions .. INTRINSIC abs,sign,sqrt C .. ovflow = sqrt(x02alf(1.D0)) th = theta s = scale xo = bt xend = half* (b+bt) dtheta = 0.D0 di = sign(1.D0,b-bt) icount = 0 10 x = half* (xo+xend) CALL coefun(x,p,q,w,coeffn,params,iparam,icofun) qbig = elam*w - q CALL onestp(xo,xend,di,s,th,p,qbig) dtheta = (th-theta)*di icount = icount + 1 IF (icount.GE.5) RETURN IF (abs(qbig).GE.ovflow*p) RETURN xo = xend xend = half* (xend+b) GO TO 10 END FUNCTION dtheta C ------------------------------------------------------------------------- SUBROUTINE solve(elam,eps,k,n,ic,maxit,setup,pp,qp,wp,xmesh,trans, & tol,ifail) C .. Parameters .. DOUBLE PRECISION ten PARAMETER (ten=1.D1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,eps,tol INTEGER ic,ifail,k,maxit,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Scalars in Common .. INTEGER icall,int,ip,ival C .. C .. Local Scalars .. DOUBLE PRECISION da,db,fx,pi,pik,rl1,rl2,tight,xs,ys INTEGER ifd,iflag,ind,ir,nevs C .. C .. Local Arrays .. DOUBLE PRECISION c(17) C .. C .. External Functions .. cc DOUBLE PRECISION d,x01aaf,x02ajf cc EXTERNAL d,x01aaf,x02ajf C .. C .. External Subroutines .. cc EXTERNAL c05azf,intval C .. C .. Common blocks .. COMMON icall,int,ip,ival C .. C .. Intrinsic Functions .. INTRINSIC max C .. pi = x01aaf(pi) pik = k*pi tight = max(x02ajf(0.D0)*ten,tol) ifail = 0 iflag = 0 C WE NOW SEEK TO FIND AN INTERVAL [RL1,RL2] CONTAINING THE C ZERO OF THE FUNCTION D(RL)-K*PI int = ip CALL intval(elam,rl1,rl2,eps,da,db,k,n,ic,pp,qp,wp,xmesh,setup, & trans,iflag) int = ip - int C CHECK THAT THE ERROR FLAG HAS NOT BEEN CHANGED IF (iflag.NE.0) THEN ifail = iflag RETURN END IF C WE NOW HAVE AN INTERVAL [A,B] WITH THE PROPERTY THAT C D(A) <= 0 AND D(B) >= 0 xs = rl1 ys = rl2 ind = -1 ir = 0 nevs = 0 fx = da c(1) = db iflag = 1 20 CALL c05azf(xs,ys,fx,tight,ir,c,ind,iflag) IF (ind.EQ.0) THEN IF (iflag.NE.0 .AND. iflag.NE.5) ifail = 13 GO TO 40 END IF IF (ind.LT.2 .OR. ind.GT.4) THEN ifail = 13 RETURN END IF ifd = 0 fx = d(xs,n,ic,pp,qp,wp,xmesh,setup,trans,ifd) - pik IF (ifd.NE.0) THEN ifail = ifd RETURN END IF nevs = nevs + 1 IF (nevs.GT.maxit) GO TO 30 GO TO 20 30 ifail = 6 RETURN 40 elam = xs RETURN END SUBROUTINE solve C--------------------------------------------------------------------- SUBROUTINE fillin(nmesh,newmsh,xmesh,pp,qp,wp,coeffn,params, & iparam,icofun) C HALVES THE SIZE OF A MESH. C .. Scalar Arguments .. INTEGER icofun,iparam,newmsh,nmesh C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(newmsh),qp(newmsh), & wp(newmsh),xmesh(0:newmsh) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION pc,qc,wc,xc INTEGER i,itw,itwm1 C .. C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=5.D-1) C .. C .. External Subroutines .. cc EXTERNAL coefun C .. DO 10 i = nmesh,1,-1 itw = 2*i itwm1 = itw - 1 xmesh(itw) = xmesh(i) xmesh(itwm1) = half* (xmesh(itw)+xmesh(i-1)) xc = half* (xmesh(itw)+xmesh(itwm1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(itw) = pc qp(itw) = qc wp(itw) = wc xc = half* (xmesh(itwm1)+xmesh(i-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(itwm1) = pc qp(itwm1) = qc wp(itwm1) = wc 10 CONTINUE RETURN END SUBROUTINE fillin C--------------------------------------------------------------------- SUBROUTINE coarse(n,a,b,xmesh,ising) C .. Scalar Arguments .. DOUBLE PRECISION a,b INTEGER ising,n C .. C .. Array Arguments .. DOUBLE PRECISION xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION h INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC dble C .. xmesh(0) = a xmesh(n) = b IF (ising.EQ.0) THEN C THE PROBLEM IS REGULAR, USE A UNIFORM MESH h = (b-a)/dble(n) DO 10 i = 1,n - 1 xmesh(i) = xmesh(i-1) + h 10 CONTINUE ELSE IF (ising.EQ.1) THEN C X = A IS SINGULAR BUT X = B IS NOT h = (b-a)/dble(n-4) xmesh(1) = xmesh(0) + h/16.0D0 xmesh(2) = xmesh(1) + h/16.0D0 xmesh(3) = xmesh(2) + h/8.0D0 xmesh(4) = xmesh(3) + h/4.0D0 xmesh(5) = xmesh(4) + h/2.0D0 DO 20 i = 6,n - 1 xmesh(i) = xmesh(i-1) + h 20 CONTINUE ELSE IF (ising.EQ.2) THEN C X=A IS REGULAR BUT X = B IS SINGULAR h = (b-a)/dble(n-4) xmesh(n-1) = xmesh(n) - h/16.0D0 xmesh(n-2) = xmesh(n-1) - h/16.0D0 xmesh(n-3) = xmesh(n-2) - h/8.0D0 xmesh(n-4) = xmesh(n-3) - h/4.0D0 xmesh(n-5) = xmesh(n-4) - h/2.0D0 DO 30 i = n - 6,1,-1 xmesh(i) = xmesh(i+1) - h 30 CONTINUE ELSE IF (ising.EQ.3) THEN C BOTH ENDS OF THE INTERVAL ARE SINGULAR POINTS. h = (b-a)/dble(n-8) xmesh(1) = xmesh(0) + h/16.0D0 xmesh(2) = xmesh(1) + h/16.0D0 xmesh(3) = xmesh(2) + h/8.0D0 xmesh(4) = xmesh(3) + h/4.0D0 xmesh(5) = xmesh(4) + h/2.0D0 xmesh(n-1) = xmesh(n) - h/16.0D0 xmesh(n-2) = xmesh(n-1) - h/16.0D0 xmesh(n-3) = xmesh(n-2) - h/8.0D0 xmesh(n-4) = xmesh(n-3) - h/4.0D0 xmesh(n-5) = xmesh(n-4) - h/2.0D0 DO 40 i = 6,n - 6 xmesh(i) = xmesh(i-1) + h 40 CONTINUE ELSE C THERE IS AN ERROR IN THE VALUE OF ISING END IF RETURN END SUBROUTINE coarse C--------------------------------------------------------------------- SUBROUTINE initia(coeffn,pp,qp,wp,xmesh,n,params,iparam,icofun) C .. Scalar Arguments .. INTEGER icofun,iparam,n C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Scalars in Common .. INTEGER icall,int,ip,ival C .. C .. Local Scalars .. DOUBLE PRECISION pc,qc,wc,xc INTEGER i C .. C .. Common blocks .. COMMON icall,int,ip,ival C .. C .. External Subroutines .. cc EXTERNAL coefun C .. DO 10 i = 1,n xc = 0.5D0* (xmesh(i)+xmesh(i-1)) CALL coefun(xc,pc,qc,wc,coeffn,params,iparam,icofun) pp(i) = pc qp(i) = qc wp(i) = wc 10 CONTINUE RETURN END SUBROUTINE initia C--------------------------------------------------------------------- SUBROUTINE intval(elc,ela,elb,eps,fa,fb,k,n,ic,pp,qp,wp,xmesh, & setup,trans,iflag) C .. Scalar Arguments .. DOUBLE PRECISION ela,elb,elc,eps,fa,fb INTEGER ic,iflag,k,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),wp(n),xmesh(0:n) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. DOUBLE PRECISION h,pi,sub INTEGER ifail,inits,nits C .. C .. External Functions .. cc DOUBLE PRECISION d,x01aaf cc EXTERNAL d,x01aaf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. pi = x01aaf(pi) sub = k*pi ela = elc - abs(eps) elb = elc + abs(eps) nits = 0 inits = 0 ifail = 0 iflag = 0 fa = d(ela,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 10 h = elb - ela IF (nits.GT.50) THEN GO TO 40 END IF IF (fa.GT.0.0D0 .AND. fb.LT.0.0D0) THEN ela = elb elb = ela + 2.D0*h fa = fb fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 inits = inits + 1 IF (inits.GT.4) GO TO 30 nits = nits + 1 GO TO 10 END IF IF (fa*fb.LE.0.0D0) GO TO 20 IF (fb.LT.0.0D0) THEN ela = elb fa = fb elb = elb + 2.0D0*h fb = d(elb,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 nits = nits + 1 GO TO 10 END IF IF (fa.GT.0.0D0) THEN elb = ela fb = fa ela = ela - 2.0D0*h fa = d(ela,n,ic,pp,qp,wp,xmesh,setup,trans,ifail) - sub IF (ifail.NE.0) GO TO 50 nits = nits + 1 GO TO 10 END IF 20 iflag = 0 RETURN 30 iflag = 9 RETURN 40 iflag = 7 RETURN 50 iflag = ifail RETURN END SUBROUTINE intval C--------------------------------------------------------------- SUBROUTINE nrmlse(yl,pdyl,ifail) C .. Scalar Arguments .. DOUBLE PRECISION pdyl,yl INTEGER ifail C .. C .. Local Scalars .. DOUBLE PRECISION s C .. s = yl**2 + pdyl**2 IF (s.EQ.0.0D0) THEN ifail = 3 RETURN END IF IF (yl.LT.0.0D0) THEN yl = -yl pdyl = -pdyl END IF IF (yl.EQ.0.0D0 .AND. pdyl.LT.0.0D0) THEN pdyl = -pdyl END IF ifail = 0 RETURN END SUBROUTINE nrmlse C--------------------------------------------------------------- SUBROUTINE check(n,pp,ifail) C THIS ROUTINE CHECKS THE INPUT TO ROUTINE D TO ENSURE THAT IT MAKES SENSE. C .. Scalar Arguments .. INTEGER ifail,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(n) C .. C .. Local Scalars .. DOUBLE PRECISION rmini INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC min C .. ifail = 0 rmini = 1.0D0 DO 10 i = 1,n rmini = min(rmini,pp(i)) 10 CONTINUE IF (rmini.LE.0.D0) ifail = 2 RETURN END SUBROUTINE check C ----------------------------------------------------------- SUBROUTINE coefun(x,p,q,w,coeffn,params,iparam,icofun) C .. Scalar Arguments .. DOUBLE PRECISION p,q,w,x INTEGER icofun,iparam C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION ex,fac C .. C .. Intrinsic Functions .. INTRINSIC abs C .. C Params is an unused array introduced to enable the code to be C easily adapted to handle problems with parameter-dependent C coefficients. IF (icofun.EQ.1) THEN fac = 1.D0 - abs(x) ex = x/fac fac = fac**2 CALL coeffn(ex,p,q,w) p = p*fac q = q/fac w = w/fac RETURN ELSE CALL coeffn(x,p,q,w) RETURN END IF END SUBROUTINE coefun C --------------------------------------------------------------------- C --------------------- Source from NEWCOMP --------------------------- C --------------------------------------------------------------------- C Routine for single eigenvalue case: SUBROUTINE sl04f(xval,yvals,pdyval,ival,elam,eigfns,wk,iwk,nval,n, & ifail) C Brief Specification: C This routine takes in appropriate information about the normalised C eigenfunction from the routine SL03F and returns the value of the C normalised eigenfunction at the points xval(i),i=1,nval. C VARIABLES: C XVAL: REAL ARRAY of DIMENSION (0:IVAL). A set of points supplied C by the user. The eigenfunction will be evaluated at the C points XVAL(i) for 0 <= i <= NVAL. (n.b. IVAL is the C DIMENSION of XVAL as declared in the calling (sub)program, C NVAL the number of these points at which the eigenfunction C is to be evaluated). The points in XVAL MUST BE ARRANGED C in ASCENDING ORDER, C XVAL(0) <= XVAL(1) <= XVAL(2) <= ... <= XVAL(NVALS). C otherwise SL04F will rearrange them in this order. C YVALS: REAL ARRAY of DIMENSION (0:IVAL). On exit, YVALS(i) is, for each C 0 <= i <= NVALS, the value of the approximate eigenfunction at C the point XVAL(i). C PDYVAL: REAL ARRAY of DIMENSION (0:IVAL). On exit, PDYVAL(i) is, for each C 0 <= i <= NVALS, the value of the approximation to p(x)y'(x) at C x = XVAL(i). Here p(x) is the coefficient from the defining C equation of the Sturm-Liouville problem, C C -(p(x)y')' + q(x)y = Lambda.w(x)y C ELAM: REAL ARRAY of DIMENSION (1:2). Supplied by the preceding call C to the routine SL02F. Unchanged on exit. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4). Supplied by the preceding C call to the routine SL02F. The preceding call to SL02F need C not occur in the same subprogram, but if it does not then the C array wk must be declared to have the same dimensions in the C subprogram from which SL02F is called as in the subprogrm from C which SL04F is called. C Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3). Supplied by the preceding C call to the routine SL03F. C Unchanged on exit. C IWK: The first dimension of wk as declared in the calling C subprogram. Unchanged on exit. C NVALS: One less than the number of points at which the eigenfunction C is required. Unchanged on exit. C N: The number of mesh intervals used by SL02F in computing the C eigenvalue approximation. Supplied by the preceding call to C SL02F. Unchanged on exit. C END of brief specification. C C Additional Information (for me): C eigfns(i,1) = rlog(i) for i=0,1 C eigfns(i,2) = theta(i) for i=0,1 C eigfns(i,3) = scale(i) for i=0,1. C wk: *real* ARRAY of DIMENSION (0:iwk,1:4). The entries in wk are as C follows: C wk(i,1) = xmesh(i) for i=0,n C wk(i,2) = pp(i) for i=1,n C wk(i,3) = qp(i) for i=1,n C wk(i,4) = wp(i) for i=1,n. C C .. Scalar Arguments .. INTEGER ifail,ival,iwk,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(1:2),pdyval(0:ival), & wk(0:iwk,1:4),xval(0:ival),yvals(0:ival) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER ic C .. C .. External Subroutines .. cc EXTERNAL efn1 C .. C Retrieve matchpoint index from sneaky storage: ic = wk(0,2) C Un-do the Richardson extrapolation: elam0 = elam(1) + elam(2) C Compute the eigenfunction and store in arrays: CALL efn1(xval,yvals,pdyval,elam0,eigfns(0,1),eigfns(0,2), & eigfns(0,3),wk(0,1),wk(1,2),wk(1,3),wk(1,4),nval,n,ic) C IFAIL is included just for compatibility. ifail = 0 END SUBROUTINE sl04f C ---------------------------------------------------------------------------- SUBROUTINE sl03f(elam,k,eigfns,wk,iwk,n,setup,ifail) C This routine computes information required by the routine SL04F in order C to evaluate the normalised eigenfunction. C C Brief Specification: C VARIABLES C ELAM: REAL ARRAY of DIMENSION (1:2). Supplied by the preceding call to C SL02F. Unchanged on exit. C K: The index of the eigenvalue and eigenfunction in question. As C supplied to SL02F for the computation of ELAM. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3) This array must be supplied C by the user and will be used to store the information about the C normalised eigenfunction required by SL03F. C WK: REAL ARRAY of DIMENSION (0:IWK,1:4). Supplied by the preceding C call to the routine SL02F. The preceding call to SL02F need C not occur in the same subprogram, but if it does not then the C array WK must be declared to have the same dimensions in the C subprogram from which SL02F is called as in the subprogrm from C N: INTEGER. The number of mesh intervals used by the routine SL02F C in the computation of the eigenvalue approximation. Supplied by C the preceding call to SL02F and unchanged on exit. C SETUP: User-supplied SUBROUTINE. The same as supplied to SL02F at the C preceding call to SL02F. C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C END of brief specification C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. INTEGER ifail,iwk,k,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(1:2),wk(0:iwk,1:4) C .. C .. Local Scalars .. INTEGER ic,iflag,nrec CHARACTER srname*6 C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. External Functions C .. External Subroutines .. cc EXTERNAL norfn1 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = ' SL03F' nrec = 1 iflag = 0 IF (abs(ifail).GT.1) THEN WRITE (rec,FMT=9000) ifail = -1 iflag = 1 ELSE C Retrive matchpoint index from sneaky storage: ic = wk(0,2) C This routine just acts as an interface for NORFUN CALL norfn1(eigfns(0,1),eigfns(0,2),eigfns(0,3),smatch, & elam(1),elam(2),k,n,ic,wk(1,2),wk(1,3),wk(1,4), & wk(0,1),setup,iflag) IF (iflag.NE.0) THEN WRITE (rec,FMT=9010) ELSE C IF iflag is nonzero iflag will have the value 3 C Eigenfunction has been normalised as required ifail = 0 RETURN END IF END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Parameter error: ifail out of range') 9010 FORMAT (' ** Invalid boundary conditions') C$st$ Unreachable comments ... END SUBROUTINE sl03f C------------------------------------------------------------------------------ C Routine for many eigenvalue case: SUBROUTINE sl04fm(xval,yvals,pdyval,ival,elam,k,kvals,m,mvals, & eigfns,wk,iwk,nval,n,ifail) C Brief Specification: C This routine takes in appropriate information about the normalised C eigenfunctions from the routine NRMANY and returns the values of the C normalised eigenfunctions at the points xval(i),i=1,nval. C VARIABLES: C XVAL: REAL ARRAY of DIMENSION (0:IVAL). A set of points supplied C by the user. The eigenfunctions with indices KVALS(i), C i = 1,..,MVALS, will be evaluated at the C points XVAL(i) for 0 <= i <= NVAL. (n.b. IVAL is the C DIMENSION of XVAL as declared in the calling (sub)program, C NVAL the number of these points at which the eigenfunction C is to be evaluated). The points in XVAL MUST BE ARRANGED C in ASCENDING ORDER, C XVAL(0) <= XVAL(1) <= XVAL(2) <= ... <= XVAL(NVALS). C Unchanged on exit. C K: INTEGER array of DIMENSION at least (1:M). This array must C contain the same values as the array by the same name supplied to C the routine NRMANY to generate the eigenfunction information C array EIGFNS. Unchanged on exit. C MVALS: INTEGER. There are M eigenfunctions stored in the array EIGFNS. C MVALS specifies how many of these are to be evaluated at each point C in the array XVALS. MVALS <= M. Unchanged on exit. C KVALS: INTEGER array of DIMENSION at least (1:MVALS). On entry, KVALS C must be set by the user to specify the indices KVALS(i), i = C 1,..,MVALS, of the eigenfunctions to be evaluated. Unchanged C on exit. C YVALS: REAL ARRAY of DIMENSION (0:IVAL,1:p) where p>= MVALS. C On exit, YVALS(i,j) is, for each 0 <= i <= NVALS, 1<=j<=MVALS, C the value of the approximate KVALS(j)th eigenfunction at the C point XVAL(i). C PDYVAL: REAL ARRAY of DIMENSION (0:IVAL,1:p) where p>=MVALS C On exit, PDYVAL(i,j) is, for each 0 <= i <= NVALS, 1<=j<=MVALS C the value of the approximation to p(x)y_{KVALS(j)}'(x) at C x = XVAL(i). Here p(x) is the coefficient from the defining C equation of the Sturm-Liouville problem, C C -(p(x)y')' + q(x)y = Lambda.w(x)y C and y_{KVALS(j)} is the KVALS(j)th eigenfunction of this problem. C ELAM: REAL ARRAY of DIMENSION (1:2,1:p) where p >= m. C Supplied by the preceding call to the routine SL02FM. Unchanged C on exit. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine SL02FM. The C preceding call to SL02FM need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which SL02FM is called as C in the subprogrm from which SL04F is called. C Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p>=m. C Supplied by the preceding call to the routine NRMANY. Note that C IWK is the dimension of this routine as declared in the calling C (sub)program, and must be the same as first dimension of wk as C declared in the calling subprogram. The preceding call to NRMANY C need not occur in the same subprogram, but if it does not then the C array EIGFNS must be declared to have the same dimensions in the C subprogram from which NRMANY is called as in the subprogrm from C which SL04FM is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of wk as declared in the C calling subprogram. Unchanged on exit. C NVALS: INTEGER. The number of points in XVAL at which the eigenfunction C approximation is to be computed. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by SL02FM in computing C the eigenvalue approximation. Supplied by the preceding call to C SL02FM. Unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to SL02FM by the user. Unchanged on exit. C END of brief spec. C C Additional Information (for me): C eigfns(i,1,k) = rlog_{k}(i) for i=0,1,k=1,m, C eigfns(i,2,k) = theta_{k}(i) for i=0,1,k=1,m, C eigfns(i,3,k) = scale_{k}(i) for i=0,1,k=1,m. C wk: *real* ARRAY of DIMENSION (0:n,1:4). The entries in wk are as C follows: C wk(i,1) = xmesh(i) for i=0,n C wk(i,2) = pp(i) for i=1,n C wk(i,3) = qp(i) for i=1,n C wk(i,4) = wp(i) for i=1,n. C C .. Scalar Arguments .. INTEGER ifail,ival,iwk,m,mvals,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m), & pdyval(0:ival,1:m),wk(0:iwk,1:4),xval(0:ival), & yvals(0:ival,1:m) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,iflag,j,jc,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. External Subroutines .. cc EXTERNAL efn1 C .. C Retrieve matchpoint index from sneaky storage: C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. ic = wk(0,2) iflag = 0 nrec = 2 IF (mvals.GT.m .OR. mvals.LE.0 .OR. abs(ifail).GT.1) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) ELSE DO 30 i = 1,mvals DO 10 j = 1,m IF (kvals(i).EQ.k(j)) GO TO 20 10 CONTINUE GO TO 40 20 jc = j C Undo each Richarson extrapolation before computing the eigenfunctions: elam0 = elam(1,jc) + elam(2,jc) CALL efn1(xval,yvals(0,i),pdyval(0,i),elam0, & eigfns(0,1,jc),eigfns(0,2,jc),eigfns(0,3,jc), & wk(0,1),wk(1,2),wk(1,3),wk(1,4),nval,n,ic) 30 CONTINUE ifail = 0 RETURN 40 CONTINUE iflag = 2 WRITE (rec,FMT=9010) END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Parameter error: MVALS or IFAIL out of range') 9010 FORMAT (' ** Requested eigenfunctions not all available') END SUBROUTINE sl04fm C ------------------------------------------------------------------------ SUBROUTINE sl03fm(elam,k,m,eigfns,wk,iwk,n,setup,ifail) C This routine computes information required by the routine SL04FM in order C to evaluate the normalised eigenfunction. C C Brief Specification: C VARIABLES C ELAM: REAL ARRAY of DIMENSION (1:2,1:p) where p >= m. Supplied by the C preceding call to SL02FM. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions in question. As supplied to C SL02FM for the computation of ELAM. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL04FM. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine SL02FM. The C preceding call to SL02FM need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which SL02FM is called as C in the subprogrm from which SL04F is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine SL02FM C in the computation of the eigenvalue approximation. Supplied by C the preceding call to SL02FM and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to SL02FM by the user. Unchanged on exit. C SETUP: User-supplied SUBROUTINE. The same as supplied to SL02FM at the C preceding call to SL02FM. C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C END of brief specification C C Additional information (for me): C This routine interfaces to NORFN1 and allows the normalisation of many C eigenfunctions at once. C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. INTEGER ifail,iwk,m,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m),wk(0:iwk,1:4) INTEGER k(1:m) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. INTEGER i,ic,iflag,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. External Subroutines .. cc EXTERNAL norfn1 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = 'SL03FM' nrec = 2 IF (abs(ifail).GT.1) THEN WRITE (rec,FMT=9000) ifail = -1 iflag = 1 ELSE C Retrieve matchpoint index from sneaky storage: ic = wk(0,2) C This routine is just an interface for NORFUN DO 10 i = 1,m CALL norfn1(eigfns(0,1,i),eigfns(0,2,i),eigfns(0,3,i), & smatch,elam(1,i),elam(2,i),k(i),n,ic,wk(1,2), & wk(1,3),wk(1,4),wk(0,1),setup,iflag) IF (iflag.NE.0) GO TO 20 10 CONTINUE C If ifail is nonzero ifail will have the value 3. C Eigenfunctions have been normalised as required ifail = 0 RETURN 20 WRITE (rec,FMT=9010) iflag = 2 END IF ifail = p01abf(ifail,iflag,srname,nrec,rec) 9000 FORMAT (' ** Invalid input value of IFAIL') 9010 FORMAT (' ** Invalid boundary conditions') C$st$ Unreachable comments ... END SUBROUTINE sl03fm C------------------------------------------------------------------------------ SUBROUTINE efun(xval,yvals,pdyval,elam,rlog,theta,scale,xmesh,pp, & qp,wp,nval,n,ic) C .. Parameters .. DOUBLE PRECISION zero,one PARAMETER (zero=0.0D0,one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER ic,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION pdyval(0:nval),pp(1:n),qp(1:n),rlog(0:n), & scale(0:n),theta(0:n),wp(1:n),xmesh(0:n), & xval(0:nval),yvals(0:nval) C .. C .. Local Scalars .. DOUBLE PRECISION di,dummy,erl,rlgtmp,sqrts,stemp,thtmp,xend, & xo INTEGER i,j,jtemp,kdummy C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC cos,sin,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. C rnorm = zero i = 0 j = 0 di = one 10 CONTINUE IF (xval(i).LT.xmesh(0)) di = -one jtemp = j DO 20 kdummy = j,n - 1 IF (xval(i).GT.xmesh(kdummy)) THEN jtemp = kdummy ELSE GO TO 30 END IF 20 CONTINUE GO TO 40 30 CONTINUE 40 j = jtemp xend = xval(i) IF (xend.GT.xmesh(ic)) THEN xo = xmesh(j+1) rlgtmp = rlog(j+1) thtmp = theta(j+1) stemp = scale(j+1) di = -one ELSE rlgtmp = rlog(j) thtmp = theta(j) stemp = scale(j) xo = xmesh(j) END IF CALL fulstp(xo,xend,di,stemp,thtmp,rlgtmp,pp(j+1), & elam*wp(j+1)-qp(j+1),wp(j+1),dummy,1) erl = spexp(rlgtmp) sqrts = sqrt(stemp) yvals(i) = sin(thtmp)*erl/sqrts pdyval(i) = cos(thtmp)*erl*sqrts i = i + 1 IF (i.LE.nval) GO TO 10 END SUBROUTINE efun C------------------------------------------------------------------------------ SUBROUTINE efn1(xval,yvals,pdyval,elam,rlog,theta,scale,xmesh,pp, & qp,wp,nval,n,ic) C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER ic,n,nval C .. C .. Array Arguments .. DOUBLE PRECISION pdyval(0:nval),pp(1:n),qp(1:n),rlog(0:1), & scale(0:1),theta(0:1),wp(1:n),xmesh(0:n), & xval(0:nval),yvals(0:nval) C .. C .. Local Scalars .. DOUBLE PRECISION di,dummy,p,q,rlgloc,scloc,sgnh,thtloc,w,xend,xo INTEGER i,idi,ifail,ii,j,jsplit C .. C .. External Subroutines .. cc EXTERNAL fulstp,m01caf C .. C .. Intrinsic Functions .. INTRINSIC cos,dble,max,min,sign,sin,sqrt C .. C First order points in ascending order C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. CALL m01caf(xval(0),1,nval+1,'A',ifail) C Next find which points lie to the right of the match-point and which to C the left. jsplit = -1 DO 10 i = 0,nval C Modify a point if it lies outwith the permitted range: xval(i) = min(xmesh(n),max(xmesh(0),xval(i))) IF (xval(i).LE.xmesh(ic)) jsplit = i 10 CONTINUE i = 1 j = 0 IF (jsplit.EQ.-1) THEN jsplit = 0 GO TO 30 END IF idi = 1 ii = i C Initial conditions rlgloc = rlog(0) thtloc = theta(0) scloc = scale(0) xo = xmesh(0) di = dble(idi) sgnh = sign(one,di) 20 p = pp(ii) q = qp(ii) w = wp(ii) IF (xmesh(i)*sgnh.LT.xval(j)*sgnh) THEN xend = xmesh(i) CALL fulstp(xo,xend,sign(one,xend-xo),scloc,thtloc,rlgloc,p, & elam*w-q,w,dummy,1) i = i + idi ii = ii + idi ELSE xend = xval(j) CALL fulstp(xo,xend,sign(one,xend-xo),scloc,thtloc,rlgloc,p, & elam*w-q,w,dummy,1) dummy = spexp(rlgloc) yvals(j) = sin(thtloc)*dummy/sqrt(scloc) pdyval(j) = cos(thtloc)*dummy*sqrt(scloc) IF (xmesh(i).EQ.xval(j)) THEN i = i + idi ii = ii + idi i = min(i,n) i = max(i,0) ii = min(ii,n) ii = max(ii,0) END IF j = j + idi END IF C If we have evaluated at all required points then bail out: IF (idi.GT.0 .AND. j.GT.jsplit) GO TO 30 IF (idi.LT.0 .AND. j.LT.jsplit) GO TO 40 xo = xend GO TO 20 30 IF (j.LE.nval) THEN C We still have more points to do. rlgloc = rlog(1) thtloc = theta(1) scloc = scale(1) xo = xmesh(n) i = n - 1 idi = -1 ii = i + 1 j = nval di = dble(idi) sgnh = sign(one,di) GO TO 20 END IF 40 RETURN C If we are here then all the required values have been computed. END SUBROUTINE efn1 C------------------------------------------------------------------------------ SUBROUTINE norfun(rlog,theta,scale,smatch,elam0,ep,k,n,ic,pp,qp, & wp,xmesh,setup,trans,ifail) C C This routine computes arrays containing nodal values of the scale-factor, C Prufer radius and Prufer angle, all normalised to agree with each other and C yield an eigenfunction with L2(w)-norm equal to unity. The mesh may be in C the user's coordinates (trans = .false.) or transformed coordinates C (trans = .true.) C VARIABLES: C rlog: *real* ARRAY of DIMENSION at least (0:n) On exit, this contain C the required nodal values of log(r). C theta: *real* ARRAY of DIMENSION at least (0:n). On exit, this contains C the required nodal values of theta. C scale: *real* ARRAY of DIMENSION at least (0:n). On exit, this contains C the required nodal values of the scale-factor. C ELAM0: *real*. The eigenvalue corresponding to the required eigenfunction. C Unchanged on exit. C N,IC: INTEGERs. N is the number of mesh-intervals used by EIGEN in its C computation of the eigenfunction. IC is the integer such that the C point XMESH(IC) was used as the matching point for the computation C of the Prufer miss-distance function. C PP,QP,WP: *real* ARRAYs of DIMENSIONs at least N. These store the values C of the coefficient functions at the midpoints XMESH(i+1/2). C XMESH: *real* ARRAY of DIMENSION at least N. Stores the mesh-points used C by EIGEN in the computation of the eigenfunction. C smatch: the value of the scale-factor at the matching point xmesh(ic). C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C .. Parameters .. C Set up left boundary conditions: DOUBLE PRECISION zero,one,two,half PARAMETER (zero=0.0D0,one=1.0D0,two=2.0D0,half=one/two) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam0,ep,smatch INTEGER ic,ifail,k,n LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),rlog(0:n),scale(0:n),theta(0:n), & wp(n),xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION elam,eps,facl,facr,pdy,pi,rgtlog,rlftlg,rnorml, & rnormr,y INTEGER i C .. C .. External Subroutines .. cc EXTERNAL bcons,fulprf C .. C .. Intrinsic Functions .. INTRINSIC atan2,log C .. C .. External Functions .. cc DOUBLE PRECISION spexp,x01aaf cc EXTERNAL spexp,x01aaf C .. C .. Subroutine Arguments .. EXTERNAL setup C .. ifail = 0 pi = x01aaf(0.0D0) elam = elam0 + ep CALL bcons(setup,y,pdy,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = atan2(y,pdy) rlog(0) = zero C Shoot from left-hand end to matching point: rnorml = zero scale(0) = one i = 0 CALL fulprf(i,theta,rlog,scale,rnorml,ic,smatch,elam,pp,qp,wp, & xmesh,n,n,-1) rlftlg = rlog(ic) C Set up right boundary conditions: CALL bcons(setup,y,pdy,elam,xmesh(n),pp(n),qp(n),wp(n),1, & trans,ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(n) = (k+1)*pi - atan2(y,pdy) rlog(n) = zero C Shoot from right-hand end to matching point: rnormr = zero scale(n) = one i = n CALL fulprf(i,theta,rlog,scale,rnormr,ic,smatch,elam,pp, & qp,wp,xmesh,n,n,-1) rgtlog = rlog(ic) C Choose the normalising factors facl and facr to match up the two halves C of the solution; actually facl and facr here denote the logarithms of the C normalising factors. C To reduce the probability of overflow we consider two cases. C IF (rgtlog.GT.rlftlg) THEN eps = spexp(rlftlg-rgtlog) facl = -log((rnormr*eps)**2+ (rnorml**2))*half facr = facl + rlftlg - rgtlog ELSE eps = spexp(rgtlog-rlftlg) facr = -log((rnorml*eps)**2+ (rnormr**2))*half facl = facr + rgtlog - rlftlg END IF C C The normalising factors have now been computed. C DO 10 i = 0,ic - 1 rlog(i) = rlog(i) + facl 10 CONTINUE DO 20 i = ic,n rlog(i) = rlog(i) + facr 20 CONTINUE C C We now have the following information: C C The scale factors scale(i), the values of rlog(i), and the values of C theta(i), for i=1,..,n, with the theta values scaled in a manner which is C appropriate for the scale factors and the rlog values scaled to agree with C scale-factors and yield an eigenfunction witth L2(w)-norm equal to unity. C END IF END IF END SUBROUTINE norfun C------------------------------------------------------------------------------- SUBROUTINE norfn1(rlog,theta,scale,smatch,elam0,ep,k,n,ic,pp,qp, & wp,xmesh,setup,ifail) C C This routine computes arrays containing end-point values of the scale-factor, C Prufer radius and Prufer angle, all normalised to agree with each other and C yield an eigenfunction with L2(w)-norm equal to unity. C The mesh is assumed to be supplied in the user's original coordinates C and not in transformed coordinates. C VARIABLES: C rlog: *real* ARRAY of DIMENSION at least (0:1) On exit, this contains C the required end-point values of log(r). C theta: *real* ARRAY of DIMENSION at least (0:1). On exit, this contains C the required end-point values of theta. C scale: *real* ARRAY of DIMENSION at least (0:1). On exit, this contains C the required end-point values of the scale-factor. C ELAM0: *real*. The eigenvalue corresponding to the required eigenfunction. C Unchanged on exit. C N,IC: INTEGERs. N is the number of mesh-intervals used by EIGEN in its C computation of the eigenfunction. IC is the integer such that the C point XMESH(IC) was used as the matching point for the computation C of the Prufer miss-distance function. CPP,QP,WP: *real* ARRAYs of DIMENSIONs at least N. These store the values C of the coefficient functions at the midpoints XMESH(i+1/2). C XMESH: *real* ARRAY of DIMENSION at least N. Stores the mesh-points used C by EIGEN in the computation of the eigenfunction. C smatch: the value of the scale-factor at the matching point xmesh(ic). C IFAIL: INTEGER. This parameter should be zero on exit. If it is not then C it will have the value 3 indicating an error in the routine SETUP. C .. Parameters .. C Set up left boundary conditions: DOUBLE PRECISION zero,one,two,half PARAMETER (zero=0.0D0,one=1.0D0,two=2.0D0,half=one/two) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam0,ep,smatch INTEGER ic,ifail,k,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(n),qp(n),rlog(0:1),scale(0:1),theta(0:1), & wp(n),xmesh(0:n) C .. C .. Local Scalars .. DOUBLE PRECISION elam,eps,facl,facr,pdy,pi,rgtlog,rlftlg,rlo, & rnorml,rnormr,rro,sclo,scro,thlo,thro,y INTEGER i LOGICAL trans C .. C .. External Subroutines .. cc EXTERNAL bcons,fulprf C .. C .. Intrinsic Functions .. INTRINSIC atan2,log C .. C .. External Functions .. cc DOUBLE PRECISION spexp,x01aaf cc EXTERNAL spexp,x01aaf C .. C .. Subroutine Arguments .. EXTERNAL setup C .. ifail = 0 pi = x01aaf(0.0D0) elam = elam0 + ep C This routine never works with transformed coordinates. trans = .false. CALL bcons(setup,y,pdy,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = atan2(y,pdy) rlog(0) = zero C Shoot from left-hand end to matching point: rnorml = zero scale(0) = one i = 0 CALL fulprf(i,theta,rlog,scale,rnorml,ic,smatch,elam,pp,qp,wp, & xmesh,1,n,-2) rlftlg = rlog(1) rlo = rlog(0) thlo = theta(0) sclo = scale(0) C Set up right boundary conditions: CALL bcons(setup,y,pdy,elam,xmesh(n),pp(n),qp(n),wp(n),1, & trans,ifail) IF (ifail.EQ.0) THEN C If ifail is nonzero ifail = 3 theta(0) = (k+1)*pi - atan2(y,pdy) rlog(0) = zero C Shoot from right-hand end to matching point: rnormr = zero scale(0) = one i = n CALL fulprf(i,theta,rlog,scale,rnormr,ic,smatch,elam,pp, & qp,wp,xmesh,1,n,-2) rgtlog = rlog(1) rro = rlog(0) thro = theta(0) scro = scale(0) C Choose the normalising factors facl and facr to match up the two halves C of the solution; actually facl and facr here denote the logarithms of the C normalising factors. C To reduce the probability of overflow we consider two cases. C IF (rgtlog.GT.rlftlg) THEN eps = spexp(rlftlg-rgtlog) facl = -log((rnormr*eps)**2+ (rnorml**2))*half facr = facl + rlftlg - rgtlog ELSE eps = spexp(rgtlog-rlftlg) facr = -log((rnorml*eps)**2+ (rnormr**2))*half facl = facr + rgtlog - rlftlg END IF C C The normalising factors have now been computed. C rlog(0) = rlo + facl rlog(1) = rro + facr theta(0) = thlo theta(1) = thro scale(0) = sclo scale(1) = scro C END IF END IF END SUBROUTINE norfn1 C------------------------------------------------------------------------------- SUBROUTINE fulprf(i,thetrr,rlogrr,scale,rnorm,iend,send,elam,pp, & qp,wp,xmesh,idim,ndim,iswtch) C C Integrates the Prufer phase and radius (forward or backward depending on C whether iend islarger or smaller than i) advancing the values of i,theta and s C and accumulating an approximation to the L2(w) integral of the eigenfunction C at each step. C iswtch is a switch parameter. It works as follows: C C iswtch = 1 or 2: both the Prufer radius and the Prufer angle are advanced from C i to iend. C iswtch= -1 or -2: all the information returned by iswtch = 1 is returned, C and in addition the norm of the corresponding eigenfunction is returned. C The arrays thetrr and rlogrr serve as follows: C IF iswtch=(+/-)1, then on entry rlogrr(i), thetrr(i) and scale(i) must C contain the initial values of the log of Prufer radius, C the Prufer angle and scale-factor. On exit, rlogrr(j), C thetrr(j) and scale(j) will contain these Prufer C quantities at each of the points xmesh(j) for j=i,iend. C (n.b.we refer here to the input i; i is changed on exit). C If a rescaling has been necessary, then the initial C log Prufer radius rlog(i) will have been changed to C correspond to the new scaling. C IF iswtch=(+/-)2, then on entry rlogrr(0), thetrr(0) and scale(0) must C contain the initial values of the log of the Prufer radius, C the Prufer angle and the scale-factor. On exit, they C will be unchanged unless rlog(0) has been changed to C correspond to a new scaling of the eigenfunction. The C elements rlogrr(1), thetrr(1) and scale(1) contain the C appropriate Prufer quantities at xmesh(iend). C C In both cases, the scale-factor s at the final point will be send, specified C by the user. C C .. Scalar Arguments .. DOUBLE PRECISION elam,rnorm,send INTEGER i,idim,iend,iswtch,ndim C .. C .. Array Arguments .. DOUBLE PRECISION pp(ndim),qp(ndim),rlogrr(0:idim),scale(0:idim), & thetrr(0:idim),wp(ndim),xmesh(0:ndim) C .. C .. Local Scalars .. DOUBLE PRECISION delta,di,hlfsub,p,q,rlog,s,safe,sbtrct,theta, & twosaf,w INTEGER idi,idummy,ii,iold,ioldo LOGICAL ltf C .. C .. External Functions .. cc DOUBLE PRECISION rescal,scl,spexp,x02amf cc EXTERNAL rescal,scl,spexp,x02amf C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,log,max,sign,sqrt C .. C .. External Functions .. C .. C Set a parameter which can be safely exponentiated: C .. Parameters .. DOUBLE PRECISION one,zero,half PARAMETER (one=1.0D0,zero=0.0D0,half=5.0D-1) C .. twosaf = -log(x02amf(one))*half safe = half*twosaf ltf = abs(iswtch) .EQ. 1 C Store input values of certain parameters: ioldo = i C Set the L2(w) norm to zero before starting the integration rnorm = zero C Start stepping idi = sign(1,iend-i) di = dble(idi) ii = i IF (idi.LT.0) ii = i + 1 IF (ltf) THEN s = scale(i) theta = thetrr(i) rlog = rlogrr(i) ELSE s = scale(0) theta = thetrr(0) rlog = rlogrr(0) C Set scale(1), thetrr(1) and rlogrr(1) in case the range of integration C is null: scale(1) = scale(0) thetrr(1) = thetrr(0) rlogrr(1) = rlogrr(0) END IF 10 CONTINUE C IF (i.NE.iend) THEN iold = i i = i + idi ii = ii + idi p = pp(ii) w = wp(ii) C Q here has same sign as in writeup of 12/1/89 q = wp(ii)*elam - qp(ii) C Integrate over the interval [xmesh(iold),xmesh(i)] C h = xmesh(i) - xmesh(iold) CALL fulstp(xmesh(iold),xmesh(i),di,s,theta,rlog,p,q,w,delta, & sign(1,iswtch)) C Update the logr and theta arrays, and the scale-factor array: IF (ltf) THEN rlogrr(i) = rlog scale(i) = s thetrr(i) = theta ELSE rlogrr(1) = rlog scale(1) = s thetrr(1) = theta END IF C Do some scaling to avoid overflow problems: IF (rlog.GT.safe) THEN C Subtract a suitable amount from every value of logr, and divide the C norm accordingly: IF (sign(1,iswtch).EQ.-1) THEN C The contribution to the norm from a single step cannot exceed 1 for the C normalised eigenfunction: sbtrct = max(delta,twosaf) hlfsub = half*sbtrct rnorm = spexp(-sbtrct)*rnorm delta = delta - sbtrct rlog = rlog - hlfsub IF (ltf) THEN DO 20 idummy = ioldo,i,idi rlogrr(idummy) = rlogrr(idummy) - hlfsub 20 CONTINUE ELSE rlogrr(0) = rlogrr(0) - hlfsub rlogrr(1) = rlogrr(1) - hlfsub END IF ELSE rlog = rlog - safe IF (ltf) THEN DO 30 idummy = ioldo,i,idi rlogrr(idummy) = rlogrr(idummy) - safe 30 CONTINUE ELSE rlogrr(0) = rlogrr(0) - safe rlogrr(1) = rlogrr(1) - safe END IF END IF END IF IF (sign(1,iswtch).EQ.-1) rnorm = rnorm + spexp(delta) GO TO 10 END IF C Integration of the Prufer equations is now complete rnorm = sqrt(rnorm) IF (ltf) THEN thetrr(i) = scl(thetrr(i),send/s) scale(i) = send rlog = rlogrr(i) rlogrr(i) = rescal(s,send,thetrr(i),rlog) ELSE thetrr(1) = scl(thetrr(1),send/s) scale(1) = send rlog = rlogrr(1) rlogrr(1) = rescal(s,send,thetrr(1),rlog) END IF END SUBROUTINE fulprf C------------------------------------------------------------------------------- SUBROUTINE fulstp(xo,xend,di,s,theta,rlog,p,qbig,w,sqrnrm,iswtch) C This routine advances the solutions of both the Prufer r and theta equations C over an interval [xo,xend] on which the coefficient functions are constant. C It also stores in sqrnrm the logarithm of the contribution to the square of C the eigenfunction norm arising from integration across the interval (xo,xend). C VARIABLES: C C xo, xend: the endpoints of the interval over which integration must proceed; C unchanged on exit. C s: the scale-factor in use when the routine is called; this is the C scale-factor appropriate to the input value of theta. On exit, C s will be reset to the output value of the scale-factor if C this is different from the input value C theta: the Prufer angle. On entry, theta must specify the value of the C Prufer angle at the point xo, normalised according to the input C value of the scale-factor s. On exit, theta contains the value of C the Prufer angle at the point xend, normalised according to the C output value of the scale-factor s. C rlog: the logarithm of the Prufer radius, normalised to be appropriate C to the scale-factor s. On input, rlog contains the logarithm of the C Prufer radius at the point xo. On output, rlog contains the C logarithm of the Prufer radius at the point xend. C p,w,qbig: the values of the coefficient functions p and w, and of C elam*w-q = qbig on the interval [xo,xend]. Unchanged on exit. C di: indicates whether xo is greater than or less than xend; C di = 1.0 if xoxend. C iswtch: a switch parameter. With iswtch = 1 the Prufer theta-equation C and the Prufer r-equation are integrated, and with iswtch = -1 C the norm is also accumulated. C C .. Scalar Arguments .. DOUBLE PRECISION di,p,qbig,rlog,s,sqrnrm,theta,w,xend,xo INTEGER iswtch C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION alfa,alfah,c2th,c2thn,cth,h,hlog,oldtrm,pdy, & pdynew,phi2t,phit,pi,pi4,psit,rlgnew,rmess,snew, & spth,sqrts,sth,t,tah,term,thtnew,y,ynew C .. C .. External Functions .. cc DOUBLE PRECISION chi,phi,psi,rescal,scl,spexp,sptanh,x01aaf,x02amf cc EXTERNAL chi,phi,psi,rescal,scl,spexp,sptanh,x01aaf,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,log,sign,sin,sqrt,tan C .. C .. External Functions .. C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. C C .. Parameters .. DOUBLE PRECISION one,two,half,four,qtr,smal,zero PARAMETER (one=1.0D0,two=2.0D0,half=one/two,four=4.0D0, & qtr=one/four,smal=1.0D-1,zero=0.0D0) C .. pi = x01aaf(zero) pi4 = pi*qtr h = xend - xo IF (h.NE.zero) THEN hlog = log(abs(h)) t = h*h*qbig/p C IF (abs(t).GT.smal) THEN snew = sqrt(abs(qbig*p)) alfa = snew/p alfah = h*snew/p thtnew = scl(theta,snew/s) rlgnew = rescal(s,snew,thtnew,rlog) s = snew IF (t.GT.zero) THEN igt0 = igt0 + 1 IF (iswtch.EQ.-1) THEN C Compute the contribution to the square of the L2-norm also. Note the C special precaution which has to be taken to deal with indefinite C problems where w may be zero. rmess = half*w*abs(one- (sin((thtnew+alfah)*two)- & sin(two*thtnew))* (half/alfah))/s IF (rmess.GT.0.0D0) THEN sqrnrm = log(rmess) + two*rlgnew + hlog ELSE C (n.b. x02amf(*) is a very small number, O(1e-39)). sqrnrm = log(x02amf(one)) END IF END IF C Update theta and rlog: theta = thtnew + alfah rlog = rlgnew ELSE ilt0 = ilt0 + 1 c2thn = cos(two*thtnew) theta = scl(thtnew-pi4*di,spexp(-abs(alfah)*two)) + & pi4*di c2th = cos(two*theta) C Update rlog: tah = cos(thtnew-pi4*di) IF (abs(tah).GT.smal) THEN tah = (tan(thtnew-pi4*di))**2 tah = (one+tah)/ (spexp(-abs(alfah)*four)*tah+one) rlog = abs(alfah) + rlgnew - log(tah)*half ELSE oldtrm = log(abs(c2thn)) term = log(abs(c2th)) rlog = (oldtrm-term)*half + rlgnew END IF IF (iswtch.EQ.-1) THEN cth = spexp(-abs(alfah)) cth = two*cth/ (one-cth**2) spth = spexp(-two*abs(alfah)) sth = (sign(one,alfah)/alfa)* (one+spth)/ & (one-spth) - cth**2*h IF (rlgnew.LE.rlog) THEN sth = half*sth* (spexp((rlgnew-rlog)*two)* & sin(thtnew)**2+sin(theta)**2)/s sth = spexp(rlgnew-rlog)*sign(one,alfah)* & sin(theta)* (sin(thtnew)/s)*abs(cth)* & (h/sptanh(alfah)-one/alfa) + sth ELSE sth = half*sth* (sin(thtnew)**2+ & spexp((rlog-rlgnew)*two)*sin(theta)**2)/ & s sth = spexp(rlog-rlgnew)*sign(one,alfah)* & sin(theta)* (sin(thtnew)/s)*abs(cth)* & (h/sptanh(alfah)-one/alfa) + sth END IF IF (abs(w*sth).GT.zero) THEN sqrnrm = log(abs(w*sth)) + two*rlog IF (rlgnew.GT.rlog) sqrnrm = sqrnrm + & two* (rlgnew-rlog) ELSE sqrnrm = log(x02amf(one)) END IF END IF END IF ELSE ismall = ismall + 1 sth = sin(theta) cth = cos(theta) phit = phi(-t) psit = psi(-t) sqrts = sqrt(s) IF (iswtch.EQ.-1) THEN C Compute the contribution to the square of the L2-norm also. phi2t = phit*psit y = sth/sqrts pdy = cth*sqrts rmess = half*w*abs((pdy**2)* (one-phi2t)/ (p*qbig)+ & (y**2)* (one+phi2t)+two*y*pdy* (phit**2)*h/p) IF (rmess.GT.0.0D0) THEN sqrnrm = log(rmess) + rlog*two + hlog ELSE sqrnrm = log(x02amf(one)) END IF END IF theta = atan2((s/p*cth**2+qbig/s*sth**2)*h, & (s/p-qbig/s)*h*sth*cth+chi(-t)) + theta C Update rlog: pdy = sqrts*cth y = sth/sqrts pdynew = pdy*psit - y*h*qbig*phit ynew = h*phit*pdy/p + y*psit rlog = log((pdynew**2)/s+ (ynew**2)*s)*half + rlog END IF END IF END SUBROUTINE fulstp C---------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION rescal(s,snew,thtnew,rlog) C .. Scalar Arguments .. DOUBLE PRECISION rlog,s,snew,thtnew C .. C .. Local Scalars .. DOUBLE PRECISION sinsq C .. C .. Intrinsic Functions .. INTRINSIC abs,log,sin C .. sinsq = sin(thtnew)**2 rescal = rlog - log(abs(1.0D0-sinsq)*snew/s+sinsq*s/snew)*0.5D0 END FUNCTION rescal C---------------------------------------------------------------------------- SUBROUTINE onestp(xo,xend,di,s,theta,p,qbig) C This routine advances the solution of the scaled Prufer equation C across an interval [xo,xend] on which the coefficient functions p, q, C and w are constants. It will be called from the meshing routine, from the C prufer routine below, and also from the routine which computes the C eigenfunction. C C VARIABLES: C C xo, xend: the endpoints of the interval over which integration must proceed; C unchanged on exit. C s: the scale-factor in use when the routine is called; this is the C scale-factor appropriate to the input value of theta. On exit, C s will be reset to the output value of the scale-factor if C this is different from the input value C theta: the Prufer angle. On entry, theta must specify the value of the C Prufer angle at the point xo, normalised according to the input C value of the scale-factor s. On exit, theta contains the value of C the Prufer angle at the point xend, normalised according to the C output value of the scale-factor s. C p,Q: the values of the coefficient function p and of elam*w-q = Q C on the interval [xo,xend]. Unchanged on exit. C di: indicates whether xo is greater than or less than xend; C di = 1.0 if xoxend. C .. Scalar Arguments .. DOUBLE PRECISION di,p,qbig,s,theta,xend,xo C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION alfah,cth,h,pi,pi4,snew,sqrtp,sqrtq,sth,t C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,sin,sqrt C .. C .. External Functions .. cc DOUBLE PRECISION chi,scl,spexp,x01aaf cc EXTERNAL chi,scl,spexp,x01aaf C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. pi = x01aaf(0.0D0) pi4 = pi/4.0D0 h = xend - xo t = h*h*qbig/p C IF (abs(t).GT.0.1D0) THEN sqrtq = sqrt(abs(qbig)) sqrtp = sqrt(p) snew = sqrtq*sqrtp alfah = (h*sqrtq)/sqrtp theta = scl(theta,snew/s) s = snew IF (t.GT.0.0D0) THEN igt0 = igt0 + 1 theta = theta + alfah ELSE ilt0 = ilt0 + 1 theta = scl(theta-pi4*di,spexp(-abs(alfah)*2.D0)) + pi4*di END IF ELSE ismall = ismall + 1 sth = sin(theta) cth = cos(theta) theta = atan2((s/p*cth**2+qbig/s*sth**2)*h, & (s/p-qbig/s)*h*sth*cth+chi(-t)) + theta END IF END SUBROUTINE onestp C----------------------------------------------------------------------- SUBROUTINE prufer(i,theta,s,iend,send,elam,pp,qp,wp,xmesh) C C Integrates the Prufer phase (forward or backward depending on whether iend is C larger or smaller than i) advancing the values of i,theta and s C .. Scalar Arguments .. DOUBLE PRECISION elam,s,send,theta INTEGER i,iend C .. C .. Array Arguments .. DOUBLE PRECISION pp(*),qp(*),wp(*),xmesh(0:*) C .. C .. Local Scalars .. DOUBLE PRECISION di,p,q INTEGER ii,iold C .. C .. External Subroutines .. cc EXTERNAL onestp C .. C .. External Functions .. cc DOUBLE PRECISION scl cc EXTERNAL scl C .. C .. Intrinsic Functions .. INTRINSIC sign C .. di = sign(1,iend-i) ii = i IF (di.LT.0.0D0) ii = i + 1 10 CONTINUE C IF (i.NE.iend) THEN iold = i i = i + di ii = ii + di p = pp(ii) C Q here has same sign as in writeup of 12/1/89 q = wp(ii)*elam - qp(ii) CALL onestp(xmesh(iold),xmesh(i),di,s,theta,p,q) GO TO 10 END IF theta = scl(theta,send/s) s = send END SUBROUTINE prufer C----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION d(elam,nmesh,imatch,pp,qp,wp,xmesh, & setup,trans,iflag) C DOUBLE PRECISION FUNCTION d(elam,pp,qp,wp,xmesh,nmesh, C * imatch,smatch) C C Computes the miss-distance with xmesh(imatch) taken as the matching point C and smatch as the scale-factor there C C .. Parameters .. DOUBLE PRECISION smatch PARAMETER (smatch=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam INTEGER iflag,imatch,nmesh LOGICAL trans C .. C .. Array Arguments .. DOUBLE PRECISION pp(nmesh),qp(nmesh),wp(nmesh),xmesh(0:nmesh) C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Scalars in Common .. INTEGER icall,igt0,ilt0,int,ip,ismall,ival C .. C .. Local Scalars .. DOUBLE PRECISION pdyl,pdyr,pi,s,thetal,thetar,yl,yr INTEGER i,ifail C .. C .. External Subroutines .. cc EXTERNAL bcons,prufer C .. C .. Intrinsic Functions .. INTRINSIC atan2 C .. C .. External Functions .. cc DOUBLE PRECISION x01aaf cc EXTERNAL x01aaf C .. C .. Common blocks .. COMMON icall,int,ip,ival,igt0,ilt0,ismall C .. pi = x01aaf(0.0D0) IF (nmesh.GT.99) ip = ip + 1 iflag = 0 ifail = 0 C Left leg: CALL bcons(setup,yl,pdyl,elam,xmesh(0),pp(1),qp(1),wp(1),0,trans, & ifail) IF (ifail.NE.3) THEN i = 0 thetal = atan2(yl,pdyl) s = 1.0D0 CALL prufer(i,thetal,s,imatch,smatch,elam,pp,qp,wp,xmesh) C Right leg: CALL bcons(setup,yr,pdyr,elam,xmesh(nmesh),pp(nmesh), & qp(nmesh),wp(nmesh),1,trans,ifail) IF (ifail.NE.3) THEN i = nmesh thetar = pi - atan2(yr,pdyr) s = 1.0D0 CALL prufer(i,thetar,s,imatch,smatch,elam,pp,qp,wp,xmesh) C d = thetal - thetar END IF END IF IF (ifail.NE.0) iflag = ifail END FUNCTION d C ------------------------------------------------------------------- SUBROUTINE bcons(setup,y,pdy,elam,x,p,q,w,iend,trans,ifail) C .. Scalar Arguments .. DOUBLE PRECISION elam,p,pdy,q,w,x,y INTEGER iend,ifail LOGICAL trans C .. C .. Subroutine Arguments .. EXTERNAL setup C .. C .. Local Scalars .. DOUBLE PRECISION qbig,s,xend LOGICAL ising C .. C .. Intrinsic Functions .. INTRINSIC abs,sqrt C .. C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. IF (trans) THEN xend = x/ (one-abs(x)) ELSE xend = x END IF CALL setup(y,pdy,elam,xend,iend,ising) IF (ising) THEN C This end of the interval is singular from the point of view of C boundary conditions. ifail = 0 qbig = elam*w - q IF (qbig.LT.0.0D0) THEN y = 1.0D0 s = -p*qbig pdy = sqrt(s) s = sqrt(y**2+s) y = y/s pdy = pdy/s ELSE s = 1.0D0/p IF (s.GT.qbig) THEN y = 1.0D0 pdy = 0.0D0 ELSE y = 0.0D0 pdy = 1.0D0 END IF END IF ELSE C The end is regular. s = sqrt(y**2+pdy**2) IF (s.EQ.0.0D0) THEN ifail = 3 ELSE y = y/s pdy = pdy/s IF (iend.EQ.1) pdy = -pdy IF (y.LT.0.0D0) THEN y = -y pdy = -pdy END IF IF (y.EQ.0.0D0 .AND. pdy.LT.0.0D0) pdy = -pdy ifail = 0 END IF END IF END SUBROUTINE bcons SUBROUTINE mmesh(xo,xend,ic,elam,coeffn,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,ntemp,imatch,xmesh,pp,qp,wp,n, & tol,npo,params,iparam,icofun,ifail) C .. Scalar Arguments .. DOUBLE PRECISION elam,tol,xend,xo INTEGER ic,icofun,ifail,imatch,iparam,n,npo,ntemp C .. C .. Array Arguments .. DOUBLE PRECISION params(1:iparam),pp(1:n),ptemp(1:ntemp),qp(1:n), & qtemp(1:ntemp),rlog(0:ntemp),scale(0:ntemp), & theta(0:ntemp),wp(1:n),wtemp(1:ntemp),xmesh(0:n), & xtemp(0:ntemp) C .. C .. Subroutine Arguments .. EXTERNAL coeffn C .. C .. Local Scalars .. DOUBLE PRECISION big,di,errest,errpm,errpp,errqm,errqp,errw1, & errw2,errwm,errwp,gamma,h,hmax,omega1,omega2, & omega3,p1,p2,p3,q1,q2,q3,ratio,toloc,tolow,w1,w2, & w3,weight,x1,x2,x3,xende,xoo INTEGER i,icfn,icnt,idi,idmy,ifin,ii,irf,kntr,npts LOGICAL infty,phase1,repeat C .. C .. Local Arrays .. DOUBLE PRECISION pdyval(0:1),xvals(0:1),yvals(0:1) C .. C .. External Subroutines .. cc EXTERNAL coarse,coefun,efun,initia C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf,x02amf cc EXTERNAL x02ajf,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,exp,int,log,max,min,sin,sqrt C .. C .. Parameters .. DOUBLE PRECISION hlf,two,one,safe,trd,five,ten,safe3,p008,sixth, & zero,tenth,twelf PARAMETER (hlf=5.d-1,two=2.d0,one=1.d0,safe=0.8D0,trd=one/3.d0, & five=5.d0,ten=10.d0,safe3=7.29d-1,p008=8.d-3, & sixth=one/6.d0,zero=0.d0,tenth=one/ten,twelf=hlf*sixth) C .. C This subroutine covers [xo,xend] with a suitable mesh for eigenvalue C computation. toloc = tol tolow = safe*toloc ifin = ifail ifail = 0 i = ic ii = ic + 1 di = one idi = 1 icfn = icofun IF (icofun.EQ.1) THEN icfn = 2 C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. ELSE IF (icofun.EQ.3) THEN icfn = 4 END IF infty = .false. C REMARK:RWB: In the NAG version of the code icofun NEVER has the value 3. IF (icofun.EQ.1 .OR. icofun.EQ.3) infty = .true. IF (xo.EQ.xend) RETURN xoo = xo xende = xend IF (infty) THEN xoo = xoo/ (one-abs(xoo)) xende = xende/ (one-abs(xende)) END IF IF (xoo.GT.xende) THEN i = n ii = n di = -one idi = -1 END IF icnt = 0 xmesh(i) = xoo C Set the initial mesh-size; first setting: IF (imatch.GE.1) THEN h = abs(xtemp(imatch)-xtemp(imatch-1)) ELSE h = abs(xtemp(imatch)-xtemp(imatch+1)) END IF C Second setting: big = abs((elam*wtemp(imatch)-qtemp(imatch))* & (sin(theta(imatch))**2)/scale(imatch)+ & (one/ptemp(imatch))* (cos(theta(imatch))**2)*scale(imatch))* & exp(two*rlog(imatch)) hmax = abs(xend-xo)/npo h = min(hmax,h,tol/max(x02amf(one),big)) C Initial mesh-size has now been set. C maximum no. of attempts to get right stepsize (set to avoid stepsize C becoming less than machine precision x02ajf(*) in one step): irf = int(log(x02ajf(one))*hlf/log(safe)) kntr = 0 phase1 = .true. repeat = .false. C C This purpose of this routine is to provide a suitably adapted mesh for C the solution of the Sturm-Liouville eigenvalue problem. Mesh adaptation C is based on keeping an estimate of the error per interval below a specified C tolerance. C C General Step (from i to i+idi): 10 x3 = xmesh(i) + h*di x1 = xmesh(i) IF ((x3-xende)*di.GT.zero) x3 = xende xmesh(i+idi) = x3 x2 = hlf* (xmesh(i)+xmesh(i+idi)) IF (.NOT.repeat .AND. .NOT.phase1) THEN C If the step is a repeat after a failure then we dont update at the end C from which we are shooting, otherwise we do. p1 = p3 q1 = q3 w1 = w3 END IF C We only need to evaluate the coefficients at the end from which we are C shooting on the first step, otherwise they are available from the C previous step and have been set above. IF (phase1) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) CALL coefun(x2,p2,q2,w2,coeffn,params,iparam,icfn) CALL coefun(x3,p3,q3,w3,coeffn,params,iparam,icfn) IF (x1.LE.x3) THEN errw1 = w1 - w2 errw2 = w3 - w2 errwm = elam*errw1 errwp = elam*errw2 errpp = (one/p3-one/p2) errpm = (one/p1-one/p2) errqp = (q3-q2) errqm = (q1-q2) xvals(0) = x1 xvals(1) = x3 ELSE errw2 = w1 - w2 errw1 = w3 - w2 errwp = elam*errw1 errwm = elam*errw2 errpm = (one/p3-one/p2) errpp = (one/p1-one/p2) errqm = (q3-q2) errqp = (q1-q2) xvals(0) = x3 xvals(1) = x1 END IF C We only need to evaluate the eigenfunction at the end from which we are C shooting on the first step, otherwise it is available from the C previous step: IF (phase1) THEN CALL efun(xvals,yvals,pdyval,elam,rlog,theta,scale,xtemp, & ptemp,qtemp,wtemp,1,ntemp,imatch) ELSE C Two cases to consider depending on stepping direction: IF (idi.GT.0) THEN C Case of repeated step is special; the eigenfunction is not updated. IF (.NOT.repeat) THEN yvals(0) = yvals(1) pdyval(0) = pdyval(1) END IF CALL efun(xvals(1),yvals(1),pdyval(1),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) ELSE C Case of repeated step is special; the eigenfunction is not updated. IF (.NOT.repeat) THEN yvals(1) = yvals(0) pdyval(1) = pdyval(0) END IF CALL efun(xvals(0),yvals(0),pdyval(0),elam,rlog,theta, & scale,xtemp,ptemp,qtemp,wtemp,0,ntemp,imatch) END IF END IF C END of eigenfunction evaluation. C The most basic error monitor ensures that we get the right normalisation: errest = twelf*abs(h* (errw1*min(one,yvals(0)**2)+errw2*min(one, & yvals(1)**2))) errwm = errwm - errqm errwp = errwp - errqp C There are a number of other different error monitors to be used, depending C on whether the behaviour of solutions of the differential equation. C Compute Prufer radius for use: weight = hlf*sqrt(yvals(0)**2+pdyval(0)**2+yvals(1)**2+ & pdyval(1)**2) C Measure rate of oscillation: omega2 = (elam*w2-q2)/p2 C WEIGHT may be quite small near the endpoints, where other eigenfunctions C do not decay just as fast. Since weight is supposed to take account of these C other eigenfunctions we adjust its value where appropriate: IF (omega2.LT.zero) THEN IF (q2.LT.two*max(one,abs(elam))*w2) THEN C It is not clear that there is any representative rate of decay for nearby C eigenfunctions: a small increase in elam could change everything. weight = max(weight,tenth) ELSE C We can be reasonably confident that the rate of decay of nearby C eigenfunctions will be at least half as fast as that of the present C eigenfunction. gamma = sqrt((two*max(one,elam)*w2-q2)/ (elam*w2-q2)) weight = max(weight,weight**gamma) END IF ELSE weight = max(weight,min(tenth,two*weight)) END IF C First error monitor, valid in regions which are not highly oscillatory. C This controls the components of the eigenfunction which are not linearly C dependent on the exact eigenfunction: errest = max(errest,sixth*weight* & abs(h* (abs(yvals(0)*errwm+yvals(1)*errwp)/sqrt(max(one, & omega2))+abs(errpm*pdyval(0)+errpp*pdyval(1))))) C Second error monitor, uses Simpson's rule to measure a local contribution C to the Green's formula for eigenvalue error: errest = max(errest,sixth*abs(h* ((yvals(0)**2)*errwm+ & (yvals(1)**2)*errwp+errpm* (pdyval(0)**2)+ & errpp* (pdyval(1)**2))))/max(one,abs(elam)) IF ((h**2)*omega2.GT.hlf) THEN C Safeguard in highly oscillatory regions: in such regions we can control C eigenvalue error by controlling error in Prufer theta: omega1 = sqrt(abs(elam*w1-q1)/p1) omega3 = sqrt(abs(elam*w3-q3)/p3) omega2 = sqrt(omega2) errest = max(errest,abs(two* (p2/w2)*omega2* (omega1- & two*omega2+omega3)*h)/max(one,elam)) END IF C All the error monitors here are O(h**3) for small h. repeat = .false. IF (errest.GT.toloc) THEN repeat = .true. ratio = safe IF (toloc.LT.errest*safe3) ratio = (toloc/errest)**trd h = h*ratio icnt = icnt + 1 IF (icnt.LT.irf) GO TO 10 ifail = 10 RETURN END IF IF (errest.LT.tolow .AND. icnt.EQ.0) THEN ratio = five IF (errest.GT.tolow*p008) ratio = (tolow/errest)**trd h = h*ratio IF (infty) THEN h = min(h,hmax* (one+x2**2)) ELSE h = min(h,hmax) END IF C The next piece of code gets the meshing routine 'on-scale' at the first step. IF (phase1) THEN repeat = .true. kntr = kntr + 1 IF (kntr.LT.5) GO TO 10 END IF END IF C General step has been completed successfully, prepare for next step. phase1 = .false. icnt = 0 pp(ii) = p2 qp(ii) = q2 wp(ii) = w2 i = i + idi ii = ii + idi C CHECK THAT we have not reached the end: IF (xmesh(i)*di.GE.xende*di) GO TO 20 C If we have not reached the end then we must make sure that there is at least C one more space in each array for us to continue. IF (ii.GE.n .OR. i.LE.ic) THEN ifail = 11 IF (ifin.EQ.1) GO TO 50 GO TO 40 END IF C Everything checked. GO TO 10 C We have now successfully completed the meshing. If we were meshing backwards C then we must ensure that the mesh nodes obtained are indexed correctly. 20 IF (idi.LT.0) THEN xmesh(ic) = xende DO 30 idmy = 1,n - i xmesh(ic+idmy) = xmesh(i+idmy) pp(ic+idmy) = pp(i+idmy) qp(ic+idmy) = qp(i+idmy) wp(ic+idmy) = wp(i+idmy) 30 CONTINUE x1 = hlf* (xende+xmesh(ic+1)) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) pp(ic+1) = p1 qp(ic+1) = q1 wp(ic+1) = w1 n = ic + n - i ELSE n = i xmesh(n) = xende x1 = hlf* (xende+xmesh(n-1)) CALL coefun(x1,p1,q1,w1,coeffn,params,iparam,icfn) pp(n) = p1 qp(n) = q1 wp(n) = w1 END IF 40 RETURN C Eventually we hope to have an emergency mesh installed here 50 IF (ic.EQ.0) THEN npts = min(n/2,400) IF (npts.LT.5) RETURN CALL coarse(npts,xende,xoo,xmesh,1) n = npts CALL initia(coeffn,pp,qp,wp,xmesh,n,params,iparam,icfn) ELSE IF (ic.GT.0) THEN npts = min((n-ic)/2,400) IF (npts.LT.5) RETURN CALL coarse(npts,xoo,xende,xmesh(ic),2) CALL initia(coeffn,pp(ic+1),qp(ic+1),wp(ic+1),xmesh(ic),npts, & params,iparam,icfn) n = npts + ic ELSE RETURN END IF ifail = 12 RETURN END SUBROUTINE mmesh C --------------------------------------------------------------------- C --------------------- Source from EXPECT ---------------------------- C --------------------------------------------------------------------- SUBROUTINE eigint(fun,tol,iopt,k,kvals,elam,expval,m,mvals,wk, & eigfns,iwk,n,ifail) C August 1990: This routine has been superceded by SL05FM C Brief specification: C This routine computes mvals integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{Kvals(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximations C to the integrals which are obtained are within TOL of the actual C value of the integral when the exact eigenfunctions are replaced C by the approximate eigenfunctions. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunctions C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integrals to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL ARRAY of DIMENSION at least (0:1,1:m). On exit, EXPVAL(0,j) C (1 <= j <= m) contains an approximation to the integral in C (*) where the eigenfunction concerned is the K(j)th eigenfunction. C EXPVAL(1,j) contains an estimate of the error due to numerical C integration, to allow the user to assess whether or not TOL C was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1,1:p) where p >= m. Supplied by the C preceding call to sl02fm. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions stored in the arrays EIGFNS C and ELAM. As supplied to sl02fm for the computation of ELAM. C Unchanged on exit. C MVALS: INTEGER. The number of integrals to be computed. Unchanged on C exit. C KVALS: INTEGER ARRAY of DIMENSION at least (1:MVALS). The indices of the C eigenfunctions for which the integrals are to be computed. Every C integer which appears as an element of this array must also C appear as an element of the array K. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:IWK,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by EIGINT. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4,1:p) where p >= m. C Supplied by the preceding call to the routine sl02fm. The C preceding call to sl02fm need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02fm is called as C in the subprogrm from which EIGINT is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02fm C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02fm and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to sl02fm. As supplied to sl02fm by the user. Unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. The only failure C possible is that the routine may not be able to achieve the C accuracy TOL requested by the user, and then IFAIL will have the C value 1 on exit. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,m,mvals,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:iwk,1:3,1:m),elam(0:1,1:m), & expval(0:1,1:m),wk(0:iwk,1:4) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,j,jc C .. C .. External Subroutines .. cc EXTERNAL entgrl C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. ifail = 0 IF (iopt.LT.1 .OR. iopt.GT.2) THEN ifail = 1 RETURN END IF C Retrieve the matchpoint index from the sneaky storage: ic = wk(0,2) DO 30 i = 1,mvals C Search for KVALS(i) in the array K DO 10 j = 1,m IF (kvals(i).EQ.k(j)) THEN jc = j GO TO 20 END IF 10 CONTINUE ifail = 2 RETURN 20 elam0 = elam(0,jc) + elam(1,jc) CALL entgrl(expval(0,i),expval(1,i),elam0,fun,tol,wk(0,1), & wk(1,2),wk(1,3),wk(1,4),eigfns(0,1,jc), & eigfns(0,2,jc),eigfns(0,3,jc),n,ic,iopt,ifail) C ifail is only non-zero on exit if an error has been detected. IF (ifail.NE.0) RETURN 30 CONTINUE C C All the required integrals have now been computed RETURN END SUBROUTINE eigint C -------------------------------------------------------------------- SUBROUTINE sl05fm(fun,tol,iopt,k,kvals,elam,expval,m,mvals,wk, & eigfns,iwk,n,ifail) C Brief specification: C This routine computes mvals integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{Kvals(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximations C to the integrals which are obtained are within TOL of the actual C value of the integral when the exact eigenfunctions are replaced C by the approximate eigenfunctions. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunctions C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integrals to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL ARRAY of DIMENSION at least (0:1,1:m). On exit, EXPVAL(0,j) C (1 <= j <= m) contains an approximation to the integral in C (*) where the eigenfunction concerned is the K(j)th C eigenfunction, while EXPVAL(1,j) contains an estimate of the C error in EXPVAL(0,j) due to numerical integration, allowing C the user to decide whether or not TOL was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1,1:p) where p >= m. Supplied by the C preceding call to sl02fm. Unchanged on exit. C K: INTEGER ARRAY of DIMENSION at least (1:M). The array of indices C of the eigenvalues and eigenfunctions stored in the arrays EIGFNS C and ELAM. As supplied to sl02fm for the computation of ELAM. C Unchanged on exit. C MVALS: INTEGER. The number of integrals to be computed. Unchanged on C exit. C KVALS: INTEGER ARRAY of DIMENSION at least (1:MVALS). The indices of the C eigenfunctions for which the integrals are to be computed. Every C integer which appears as an element of this array must also C appear as an element of the array K. Unchanged on exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3,1:p) where p >= m. This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL05FM. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4) C Supplied by the preceding call to the routine sl02fm. The C preceding call to sl02fm need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02fm is called as C in the subprogrm from which EIGINT is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02fm C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02fm and unchanged on exit. C M: INTEGER. The number of eigenvalues computed at the preceding call C to SL02FM. As supplied to sl02fm by the user. Unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,m,mvals,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(0:1,1:m), & expval(0:1,1:m),wk(0:iwk,1:4) INTEGER k(1:m),kvals(1:mvals) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER i,ic,iflag,j,jc,nrec CHARACTER srname*6 C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Subroutines .. cc EXTERNAL nntgrl C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = 'SL05FM' IF (iopt.LT.1 .OR. iopt.GT.2 .OR. abs(ifail).GT.1 .OR. & tol.LE.0.0D0 .OR. mvals.GT.m .OR. mvals.LT.0) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) 9000 FORMAT ( & '** Parameter error: IOPT or IFAIL or TOL or MVALS out of range' & ) nrec = 1 GO TO 40 END IF C Retrieve the matchpoint index from the sneaky storage: ic = wk(0,2) DO 30 i = 1,mvals C Search for KVALS(i) in the array K DO 10 j = 1,m IF (kvals(i).EQ.k(j)) THEN jc = j GO TO 20 END IF 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Required eigenfunctions not available') nrec = 1 GO TO 40 20 elam0 = elam(0,jc) + elam(1,jc) CALL nntgrl(expval(0,i),expval(1,i),elam0,fun,tol,wk(0,1), & wk(1,2),wk(1,3),wk(1,4),eigfns(0,1,jc), & eigfns(0,2,jc),eigfns(0,3,jc),n,ic,iopt,iflag) C ifail is only non-zero on exit if an error has been detected. IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9020) 9020 FORMAT ('** Automatic step-size control has failed',/, & '** Try increasing TOL') nrec = 2 GO TO 40 END IF 30 CONTINUE C C All the required integrals have now been computed ifail = 0 RETURN 40 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl05fm C -------------------------------------------------------------------- SUBROUTINE sl05f(fun,tol,iopt,k,elam,expval,wk,eigfns,iwk,n,ifail) C Brief specification: C This routine computes m integrals of Fourier type if IOPT = 1, C of expectation type if IOPT = 2; that is, we compute the integrals C \int_{a}^{b}fun(x)(y_{K(j)}(x))^{IOPT}dx (*) C VARIABLES: C FUN: REAL FUNCTION supplied by the user. Its specification is C FUNCTION FUN(x) C REAL x C C and it must define FUN for all a <= x <=b, where [a,b] is the C interval on which the Sturm-Liouville problem is posed. C TOL: REAL. The routine will attempt to ensure that the approximation C to the integral which is obtained is within TOL of the actual C value of the integral when the exact eigenfunction is replaced C by the approximate eigenfunction. However it is impossible to C guarantee that the answer will be within TOL of the actual C integral with the exact eigenfunction because the eigenfunction C may be very ill-conditioned. C Unchanged on exit. C IOPT: INTEGER. The value of IOPT decides the type of integral to be C computed (see (*) above). Unchanged on exit. C EXPVAL: REAL. On exit, EXPVAL(0) contains an approximation to the C integral in (*) where the eigenfunction concerned is the Kth C eigenfunction. EXPVAL(1) contains an estimate of the error in C EXPVAL(0) due to numerical integration, allowing the user to C decide whether or not TOL was sufficiently small. C ELAM: REAL ARRAY of DIMENSION (0:1). Supplied by the C preceding call to sl02f. Unchanged on exit. C K: INTEGER. The index of the eigenvalue and eigenfunction in question. C As supplied to sl02f for the computation of ELAM. Unchanged on C exit. C EIGFNS: REAL ARRAY of DIMENSION (0:1,1:3). This array C must be supplied by the user and will be used to store the C information about the normalised eigenfunctions required by SL05F. C wk: REAL ARRAY of DIMENSION (0:IWK,1:4). C Supplied by the preceding call to the routine sl02f. The C preceding call to sl02f need not occur in the same subprogram, C but if it does not then the array wk must be declared to have the C same dimensions in the subprogram from which sl02f is called as C in the subprogram from which SL05F is called. C Unchanged on exit. C IWK: INTEGER. The first dimension of WK as declared in the calling C (sub)program. Unchanged on exit. C N: INTEGER. The number of mesh intervals used by the routine sl02f C in the computation of the eigenvalue approximation. Supplied by C the preceding call to sl02f and unchanged on exit. C IFAIL: INTEGER. On entry, IFAIL should be assigned the value 0 or 1. On C successful exit, IFAIL will have the value 0. C END of brief specification. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iopt,iwk,k,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3),elam(0:1),expval(0:1), & wk(0:iwk,1:4) C .. C .. Local Scalars .. DOUBLE PRECISION elam0 INTEGER ic,iflag,nrec CHARACTER srname*6 C .. C .. External Subroutines .. cc EXTERNAL nntgrl C .. C .. External Functions .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs C .. srname = ' SL05F' IF (iopt.LT.1 .OR. iopt.GT.2 .OR. abs(ifail).GT.1 .OR. & tol.LE.0.0D0) THEN iflag = 1 IF (abs(ifail).GT.1) ifail = -1 WRITE (rec,FMT=9000) 9000 FORMAT ( & '** Parameter error: IOPT or IFAIL or TOL out of range' & ) nrec = 1 GO TO 10 END IF C Retrieve the matchpoint index from the sneaky storage ic = wk(0,2) elam0 = elam(0) + elam(1) CALL nntgrl(expval(0),expval(1),elam0,fun,tol,wk(0,1),wk(1,2), & wk(1,3),wk(1,4),eigfns(0,1),eigfns(0,2),eigfns(0,3),n, & ic,iopt,iflag) C ifail is only non-zero on exit if an error has been detected. IF (iflag.NE.0) THEN iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Automatic step-size control has failed',/, & '** Try increasing TOL') nrec = 2 GO TO 10 END IF ifail = 0 C C All the required integrals have now been computed RETURN 10 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl05f C -------------------------------------------------------------------- SUBROUTINE entgrl(expval,errest,elam,fun,tol,xmesh,pp,qp,wp,rlog, & theta,scale,n,ic,iopt,ifail) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,safe,tosafe,bound,zero, & ffteen INTEGER nvec PARAMETER (one=1.D0,two=2.D0,half=one/two, & qtr=half*half,safe=0.95D0,tosafe=0.8D0,bound=2.D-1, & zero=0.D0,ffteen=1.5D1,nvec=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,errest,expval,tol INTEGER ic,ifail,iopt,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(1:n),qp(1:n),rlog(0:n),scale(0:n),theta(0:n), & wp(1:n),xmesh(0:n) C .. C .. Subroutine Arguments .. C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans4,di,epsilo,err,floc,h,hmax,p,q,ratio, & rl,rln,sc,scn,tend,th,thn,tmid,to,toloc,value,w, & xend,xfin,xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. Local Arrays .. DOUBLE PRECISION ans1(1:nvec),ans2(1:nvec),ans3(1:nvec), & fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. External Subroutines .. cc EXTERNAL quad C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. epsilo = x02ajf(1.D0) toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) rl = rlog(i) th = theta(i) sc = scale(i) 20 rln = rl thn = th scn = sc C Do one step xmid = half* (xo+xend) to = xo tmid = xmid tend = xend fo(1) = fun(to) fmid(1) = fun(tmid) fend(1) = fun(tend) CALL quad(xo,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans1) C Do two half-steps rl = rln th = thn sc = scn floc = fend(1) fend(1) = fmid(1) to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xo,xmid,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans2) fo(1) = fend(1) fend(1) = floc to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xmid,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec, & iopt,ans3) ans4 = ans2(1) + ans3(1) C Estimate the error err = (ans4-ans1(1))/ffteen errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**qtr) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) \neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most ten attempts to get the stepsize right: IF (icount.LT.10) THEN rl = rln th = thn sc = scn GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF (((xend-xfin)*di+epsilo).GE.zero) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h IF (((xend-xfin)*di+epsilo).GE.zero) xend = xfin GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) GO TO 10 END IF C Successful completion: ifail = 0 expval = value C PRINT *,'ENTGRL error estimate:',errest RETURN C Unsuccessful completion: 50 expval = zero RETURN END SUBROUTINE entgrl C --------------------------------------------------------------------- SUBROUTINE nntgrl(expval,errest,elam,fun,tol,xmesh,pp,qp,wp,rlog, & theta,scale,n,ic,iopt,ifail) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,safe,tosafe,bound,zero, & ffteen INTEGER nvec PARAMETER (one=1.D0,two=2.D0,half=one/two, & qtr=half*half,safe=0.95D0,tosafe=0.8D0,bound=2.D-1, & zero=0.D0,ffteen=1.5D1,nvec=1) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,errest,expval,tol INTEGER ic,ifail,iopt,n C .. C .. Array Arguments .. DOUBLE PRECISION pp(1:n),qp(1:n),rlog(0:1),scale(0:1),theta(0:1), & wp(1:n),xmesh(0:n) C .. C .. Subroutine Arguments .. C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans4,di,epsilo,err,floc,h,hmax,p,q,ratio, & rl,rln,sc,scn,tend,th,thn,tmid,to,toloc,value,w, & xend,xfin,xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. Local Arrays .. DOUBLE PRECISION ans1(1:nvec),ans2(1:nvec),ans3(1:nvec), & fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. External Subroutines .. cc EXTERNAL quad C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. epsilo = x02ajf(1.D0) toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) rl = rlog(0) th = theta(0) sc = scale(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) C These three lines removed to comply with reduced storage requirements C rl = rlog(i) C th = theta(i) C sc = scale(i) C 20 rln = rl thn = th scn = sc C Do one step xmid = half* (xo+xend) to = xo tmid = xmid tend = xend fo(1) = fun(to) fmid(1) = fun(tmid) fend(1) = fun(tend) CALL quad(xo,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans1) C Do two half-steps rl = rln th = thn sc = scn floc = fend(1) fend(1) = fmid(1) to = half* (xo+xmid) fmid(1) = fun(to) CALL quad(xo,xmid,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec,iopt, & ans2) fo(1) = fend(1) fend(1) = floc to = half* (xend+xmid) fmid(1) = fun(to) CALL quad(xmid,xend,p,q,w,elam,rl,th,sc,fo,fmid,fend,nvec, & iopt,ans3) ans4 = ans2(1) + ans3(1) C Estimate the error err = (ans4-ans1(1))/ffteen errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**qtr) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) \neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most ten attempts to get the stepsize right: IF (icount.LT.10) THEN rl = rln th = thn sc = scn GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF (((xend-xfin)*di+epsilo).GE.zero) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h IF (((xend-xfin)*di+epsilo).GE.zero) xend = xfin GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) rl = rlog(1) th = theta(1) sc = scale(1) GO TO 10 END IF C Successful completion: ifail = 0 expval = value C PRINT *,'ENTGRL error estimate:',errest RETURN C Unsuccessful completion: 50 expval = zero RETURN END SUBROUTINE nntgrl C ------------------------------------------------------------------- SUBROUTINE quad(xo,xend,p,q,w,elam,rlog,theta,scale,fo,fmid,fend, & nvec,iopt,ans) C .. Parameters .. DOUBLE PRECISION one,two,half,qtr,three,twtrds,trd,sxteen PARAMETER (one=1.D0,two=2.D0,half=one/two,qtr=half*half, & three=3.D0,twtrds=two/three,trd=one/three,sxteen=16.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam,p,q,rlog,scale,theta,w,xend,xo INTEGER iopt,nvec C .. C .. Array Arguments .. DOUBLE PRECISION ans(1:nvec),fend(1:nvec),fmid(1:nvec),fo(1:nvec) C .. C .. Local Scalars .. DOUBLE PRECISION alfa,alfa2,alfa3,alfah,calfah,chqtrt,cntrb1, & cntrb2,cntrb3,cth,cthn,cthnp1,dummy,erl,f0,f1,f2, & gqtrt,h,onovsh,pdy,pdynew,phit,psit,qbig, & qtrt,rln,s2thn,s2thp1,salfah,snew,sqrts,sth,sthn, & sthnp1,t,talfah,term,thn,thnp1,x1,x2,xit,y, & yend,ynew,yo INTEGER i C .. C .. External Functions .. cc DOUBLE PRECISION chi,g,phi,psi,rescal,scl,x02ajf,xi cc EXTERNAL chi,g,phi,psi,rescal,scl,x02ajf,xi C .. C .. External Subroutines .. cc EXTERNAL fulstp C .. C .. Intrinsic Functions .. INTRINSIC abs,atan2,cos,exp,log,sign,sin,sqrt,tanh C .. DO 10 i = 1,nvec ans(i) = 0.D0 10 CONTINUE h = xend - xo IF (abs(h).LE.x02ajf(1.D0)) RETURN C xmid = half* (xo+xend) qbig = elam*w - q t = (h**2)*qbig/p qtrt = t*qtr C Interpolate to f using a quadratic expression C f(x) = f0 + f1*(x-xmid) + f2*(x-xmid)**2 C where the coefficients are given by C END of interpolation to f. IF (iopt.EQ.2) THEN C We require an expectation integral. There are three terms in the integral C arising from the three parts which approximate to f, and there are three C cases depending on the size of the parameter t. IF (abs(t).GT.0.1D0) THEN alfa2 = abs(qbig/p) alfa = sqrt(alfa2) alfah = alfa*h IF (t.GT.0.1D0) THEN snew = sqrt(abs(qbig*p)) thn = scl(theta,snew/scale) rln = rescal(scale,snew,thn,rlog) C In this case the eigenfunction has a very simple expression and all C three terms in the integral can be computed without divide by zero problems. C 1: The constant contribution thnp1 = thn + alfah s2thn = sin(two*thn) s2thp1 = sin(two*thnp1) cntrb1 = half*h - qtr* (s2thp1-s2thn)/alfa C 2: The linear contribution salfah = sin(alfah) calfah = cos(alfah) cntrb2 = h*sin(two*thn+alfah)* (salfah/alfah-calfah)* & qtr/alfa C 3: The quadratic contribution cntrb3 = ((h**3)/sxteen)* (twtrds- & two*cos(two+thn+alfah)* & (salfah/alfah+two*calfah/abs(t)- & two*salfah/ (alfah**3))) C 4: The entire contribution DO 20 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w*exp(two*rln)* & (f0*cntrb1+f1*cntrb2+f2*cntrb3)/snew 20 CONTINUE theta = thnp1 scale = snew rlog = rln ELSE IF (t.LT. (-0.1D0)) THEN C In this case the integral is a pain to calculate because if it is not done C properly then there is the danger of floating overflow problems. C We need to know the value of the eigenfunction at each end of the interval yo = exp(rlog)*sin(theta)/sqrt(scale) x1 = xo x2 = xend C This call also does the updating of rlog, theta and scale: CALL fulstp(x1,x2,sign(one,h),scale,theta,rlog,p,qbig, & w,dummy,-1) yend = exp(rlog)*sin(theta)/sqrt(scale) C We can now proceed to compute each contribution in turn. C 1: The constant contribution C cntrb1 = sign(one,h)*exp(dummy) C 2: The linear contribution talfah = tanh(alfah) cntrb2 = qtr* (h**2)* (yend-yo)* (yend+yo)* & (one/talfah-one/alfah)/alfah C 3: The quadratic contribution onovsh = sign(one,alfah)*sqrt((one/talfah**2)-one) term = one/alfah - two/ ((alfah**2)*talfah) + & two/ (alfah**3) cntrb3 = ((half*h)**3)* ((yo**2+yend**2)* & (-trd* (onovsh**2)+ (one/talfah)*term)+ & two*yo*yend* (trd/ (talfah)-term)*onovsh) C 4: The full contribution DO 30 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = f0*cntrb1 + w* (f1*cntrb2+f2*cntrb3) 30 CONTINUE C END of case t < -0.1 END IF C END of case ABS(t) > 0.1 ELSE C Case ABS(t) <=0.1. This is by far the worst case since series expansions C of various terms are required for small alfah. Compute the contributions C from each of the terms involved. yo = exp(rlog)*sin(theta)/sqrt(scale) x1 = xo x2 = xend CALL fulstp(x1,x2,sign(one,h),scale,theta,rlog,p,qbig,w, & dummy,-1) yend = exp(rlog)*sin(theta)/sqrt(scale) C 1: The constant term. We do this, and compute the values at the ends of the C interval at the same time, by calling the fulstp routine. cntrb1 = sign(one,h)*exp(dummy) C 2: The linear contribution cntrb2 = ((half*h)**2)* (yend-yo)* (yend+yo)*g(-t) C 3: The quadratic contribution (Uugh!) xit = xi(t) cntrb3 = ((half*h)**3)* (((yend-yo)**2)*xit/ (phi(-t)**2)+ & ((yend+yo)**2)/ (three* (one+psi(-t)))- & half* (yo**2+yend**2)*t*xit) C 4: The full contribution: DO 40 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = f0*cntrb1 + w* (f1*cntrb2+f2*cntrb3) 40 CONTINUE C END of cases for iopt = 2 END IF ELSE IF (iopt.EQ.1) THEN C This case is not so easy -- we require a Fourier integral. IF (abs(t).GT.0.1D0) THEN snew = sqrt(abs(qbig*p)) thn = scl(theta,snew/scale) rln = rescal(scale,snew,thn,rlog) alfa2 = abs(qbig/p) alfa = sqrt(alfa2) alfa3 = alfa*alfa2 alfah = sqrt(abs(t)) IF (t.GT.0.1D0) THEN thnp1 = thn + alfah C Compute the contributions from each of the terms approximating f cthn = cos(thn) cthnp1 = cos(thnp1) sthn = sin(thn) sthnp1 = sin(thnp1) C 1: The constant term cntrb1 = (cthn-cthnp1)/alfa C 2: The linear term cntrb2 = h* (cthnp1+cthn)*half/alfa - & (sthnp1-sthn)/ (alfa2) C 3: The quadratic term cntrb3 = (h**2)*qtr* (cthn-cthnp1)/alfa + & h* (sthnp1+sthn)/ (alfa2) - & two* (cthn-cthnp1)/ (alfa3) C 4: The full contribution DO 50 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w*exp(rln)* (f0*cntrb1+f1*cntrb2+ & f2*cntrb3)/sqrt(snew) 50 CONTINUE thn = thnp1 ELSE C ** t < -0.1 ** C First compute the values of the eigenfunction at x = xo and xend. yo = exp(rln)*sin(thn)/sqrt(snew) x1 = xo x2 = xend C Advance the values of rln,thn, and the scalefactor snew. CALL fulstp(x1,x2,sign(one,h),snew,thn,rln,p,qbig,w, & dummy,1) C Compute the eigenfunction at the point xend yend = exp(rln)*sin(thn)/sqrt(snew) C Compute the contribution from each of these approximating terms C 1: The Constant Term talfah = tanh(half*alfa*h) cntrb1 = (yend+yo)*talfah/alfa C 2: The Linear Term cntrb2 = (yend-yo)* (half*h/talfah-one/alfa)/alfa C 3: The Quadratic Term cntrb3 = two* (yo+yend)* ((((half*h)**2)+two/alfa2)* & talfah-h/alfa)/alfa C 4: The full contribution DO 60 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w* (f0*cntrb1+f1*cntrb2+f2*cntrb3) 60 CONTINUE END IF rlog = rln scale = snew theta = thn C END of case where ABS(t) > 0.1 ELSE C The case where ABS(t) <= 0.1 C hlog = log(abs(h)) sth = sin(theta) cth = cos(theta) sqrts = sqrt(scale) phit = phi(-t) psit = psi(-t) erl = exp(rlog) y = sth/sqrts pdy = cth*sqrts C Update rlog and theta: theta = theta + atan2(h* (scale/p*cth**2+ & qbig/scale*sth**2),chi(-t)+ & (scale/p-qbig/scale)*h*sth*cth) ynew = h*phit*pdy/p + y*psit pdynew = pdy*psit - y*h*qbig*phit rlog = rlog + half*log((pdynew**2)/scale+ (ynew**2)*scale) C C Compute the contribution from each of these approximating terms C 1: The Constant Term chqtrt = chi(-qtrt) cntrb1 = half*h*erl* (y+ynew)/chqtrt C 2: The Linear Term gqtrt = g(-qtrt) cntrb2 = (h**2)*qtr*erl* (ynew-y)*gqtrt C 3: The Quadratic Term ??? cntrb3 = ((h*half)**3)*erl* ((ynew+y)/chqtrt)* & (one-two*gqtrt) C 4: The whole contribution: DO 70 i = 1,nvec f0 = fmid(i) f1 = (fend(i)-fo(i))/h f2 = two* (fo(i)+fend(i)-two*fmid(i))/ (h**2) ans(i) = w* (f0*cntrb1+f1*cntrb2+f2*cntrb3) 70 CONTINUE END IF END IF C If we were integrating backwards then the next line will get the correct C sign for the integral which we actually want. DO 80 i = 1,nvec ans(i) = ans(i)*sign(one,h) 80 CONTINUE RETURN END SUBROUTINE quad C ----------------------------------------------------------------------- DOUBLE PRECISION FUNCTION g(t) C .. Parameters .. DOUBLE PRECISION fac2,fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10, & fac11,fac12,fac13,fac14,fac15 PARAMETER (fac2=5.D-1,fac3=fac2/3.D0,fac4=fac3/4.D0, & fac5=fac4/5.D0,fac6=fac5/6.D0,fac7=fac6/7.D0, & fac8=fac7/8.D0,fac9=fac8/9.D0,fac10=fac9/10.D0, & fac11=fac10/11.D0,fac12=fac11/12.D0,fac13=fac12/13.D0, & fac14=fac13/14.D0,fac15=fac14/15.D0) DOUBLE PRECISION c0,c1,c2,c3,c4,c5,c6 PARAMETER (c0=fac2-fac3,c1=fac4-fac5,c2=fac6-fac7,c3=fac8-fac9, & c4=fac10-fac11,c5=fac12-fac13,c6=fac14-fac15) C .. C .. Scalar Arguments .. DOUBLE PRECISION t C .. C .. External Functions .. cc DOUBLE PRECISION phi c EXTERNAL phi C .. g = c0 + t* (c1+t* (c2+t* (c3+t* (c4+t* (c5+t*c6)))))/phi(t) RETURN END FUNCTION g C -------------------------------------------------------------------------- DOUBLE PRECISION FUNCTION xi(t) C .. Parameters .. DOUBLE PRECISION fac2,fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10, & fac11,fac12,fac13,fac14 PARAMETER (fac2=5.D-1,fac3=fac2/3.D0,fac4=fac3/4.D0, & fac5=fac4/5.D0,fac6=fac5/6.D0,fac7=fac6/7.D0, & fac8=fac7/8.D0,fac9=fac8/9.D0,fac10=fac9/10.D0, & fac11=fac10/11.D0,fac12=fac11/12.D0,fac13=fac12/13.D0, & fac14=fac13/14.D0) DOUBLE PRECISION c1,c2,c3,c4,c5,c6,c7 PARAMETER (c1=fac2/5.D0,c2=-fac4/7.D0,c3=fac6/9.D0,c4=-fac8/11.D0, & c5=fac10/13.D0,c6=-fac12/15.D0,c7=fac14/17.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION t C .. xi = c1 + t* (c2+t* (c3+t* (c4+t* (c5+t* (c6+t*c7))))) RETURN END FUNCTION xi C --------------------------------------------------------------------- C --------------------- Source from EXTRA ----------------------------- C --------------------------------------------------------------------- SUBROUTINE sl07fm(elam1,elam2,wk1,wk2,iwk1,iwk2,m1,m2,k1,k2, & eigfn1,eigfn2,n1,n2,i1,i2,fun,tol,ans,ifail) C This routine provides an interface for the routine FCF for computing C Franck-Condon factors. It is designed primarily for the multiple C eigenvalue case where the eigenvalues of each problem have all been C computed on a single mesh, but may also be used for the case where the C eigenvalues have been computed singly. A single Franck-Condon factor, C specified by the integers i1 and i2, is computed at each call. C Failure flags: C IFAIL = 1: Parameter out of range on entry. C IFAIL = 3: An error in SUBROUTINE fcf. Cannot achieve required accuracy. C IFAIL = 2: A parameter error. We do not have the eigenfunctions for the C integrals requested. C C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER i1,i2,ifail,iwk1,iwk2,m1,m2,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),eigfn1(0:1,1:3,1:m1), & eigfn2(0:1,1:3,1:m2),elam1(0:1,1:m1), & elam2(0:1,1:m2),wk1(0:iwk1,1:4),wk2(0:iwk2,1:4) INTEGER k1(1:m1),k2(1:m2) C .. C .. Local Scalars .. DOUBLE PRECISION eig1,eig2 INTEGER i,ic1,ic2,iflag,j1,j2,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. External Subroutines .. cc EXTERNAL nfcf C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = 'SL07FM' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') IF (abs(ifail).GT.1) ifail = -1 iflag = 1 nrec = 1 GO TO 50 END IF C Check to make sure we have available the eigenfunctions for the integral C requested: DO 10 i = 1,m1 IF (k1(i).EQ.i1) THEN j1 = i GO TO 20 END IF 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Necessary eigenfunctions not both available') nrec = 1 GO TO 50 20 DO 30 i = 1,m2 IF (k2(i).EQ.i2) THEN j2 = i GO TO 40 END IF 30 CONTINUE iflag = 2 WRITE (rec,FMT=9020) 9020 FORMAT ('** Necessary eigenfunctions not both available') nrec = 1 GO TO 50 40 ic1 = wk1(0,2) ic2 = wk2(0,2) iflag = 0 eig1 = elam1(0,j1) + elam1(1,j1) eig2 = elam2(0,j2) + elam2(1,j2) CALL nfcf(eig1,wk1(0,1),wk1(1,2),wk1(1,3),wk1(1,4),eigfn1(0,1,j1), & eigfn1(0,2,j1),eigfn1(0,3,j1),eig2,wk2(0,1),wk2(1,2), & wk2(1,3),wk2(1,4),eigfn2(0,1,j2),eigfn2(0,2,j2), & eigfn2(0,3,j2),n1,n2,ic1,ic2,fun,tol,ans(0),ans(1), & iflag) IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9030) 9030 FORMAT ('** Automatic step-size control has failed',/, & '** Try a larger value of TOL') nrec = 2 GO TO 50 END IF ifail = 0 RETURN 50 ifail = p01abf(ifail,iflag,srname,nrec,rec) END SUBROUTINE sl07fm C --------------------------------------------------------------------- SUBROUTINE sl07f(elam1,elam2,wk1,wk2,iwk1,iwk2,eigfn1,eigfn2,n1, & n2,fun,tol,ans,ifail) C This routine provides an interface for the routine FCF for computing C Franck-Condon factors. It is designed for the single C eigenvalue case. A single Franck-Condon factor, is computed at each call. C Failure flags: C IFAIL = 1: Parameter out of range on entry. C IFAIL = 2: An error in SUBROUTINE fcf. Cannot achieve required accuracy. C C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER ifail,iwk1,iwk2,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),eigfn1(0:1,1:3),eigfn2(0:1,1:3), & elam1(0:1),elam2(0:1),wk1(0:iwk1,1:4), & wk2(0:iwk2,1:4) C .. C .. Local Scalars .. DOUBLE PRECISION eig1,eig2 INTEGER ic1,ic2,iflag,nrec CHARACTER srname*6 C .. C .. External Functions .. cc INTEGER p01abf c EXTERNAL p01abf C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. External Subroutines .. cc EXTERNAL nfcf C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. C .. Intrinsic Functions .. INTRINSIC abs C .. iflag = 0 srname = ' SL07F' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') IF (abs(ifail).GT.1) ifail = -1 iflag = 1 nrec = 1 GO TO 10 END IF ic1 = wk1(0,2) ic2 = wk2(0,2) iflag = 0 eig1 = elam1(0) + elam1(1) eig2 = elam2(0) + elam2(1) CALL nfcf(eig1,wk1(0,1),wk1(1,2),wk1(1,3),wk1(1,4),eigfn1(0,1), & eigfn1(0,2),eigfn1(0,3),eig2,wk2(0,1),wk2(1,2),wk2(1,3), & wk2(1,4),eigfn2(0,1),eigfn2(0,2),eigfn2(0,3),n1,n2,ic1, & ic2,fun,tol,ans(0),ans(1),iflag) IF (iflag.NE.0) THEN iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Automatic step-size control has failed',/, & '** Try a larger value of TOL') nrec = 2 GO TO 10 END IF ifail = 0 RETURN 10 ifail = p01abf(ifail,iflag,srname,nrec,rec) END SUBROUTINE sl07f C --------------------------------------------------------------------- SUBROUTINE nfcf(elam1,xmesh1,pp1,qp1,wp1,rlog1,theta1,scale1, & elam2,xmesh2,pp2,qp2,wp2,rlog2,theta2,scale2,n1, & n2,ic1,ic2,fun,tol,ans,errest,ifail) C Declarations C .. Parameters .. DOUBLE PRECISION one,two,three,half,trd,qtr,safe,tosafe,bound,zero PARAMETER (one=1.D0,two=2.D0,three=3.D0,half=one/two, & trd=one/three,qtr=half*half,safe=0.95D0,tosafe=0.8D0, & bound=2.D-1,zero=0.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION ans,elam1,elam2,errest,tol INTEGER ic1,ic2,ifail,n1,n2 C .. C .. Array Arguments .. DOUBLE PRECISION pp1(1:n1),pp2(1:n2),qp1(1:n1),qp2(1:n2), & rlog1(0:1),rlog2(0:1),scale1(0:1),scale2(0:1), & theta1(0:1),theta2(0:1),wp1(1:n1),wp2(1:n2), & xmesh1(0:n1),xmesh2(0:n2) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans1,ans2,ans3,ans4,di,diff,dummy,err,h, & hmax,p1,p2,q1,q2,ratio,rl1,rl2,rln1, & rln2,sc1,sc2,scn1,scn2,th1,th2, & thn1,thn2,toloc,value,w1,w2,x1,x2,x3,xend, & xfin,xhigh,xlow,xmid,xo,xsplit,xstart,xstop INTEGER i,i1,i1high,i1low,i1m1,i2,i2high,i2low,i2m1,icount,idi, & ii1,ii2,ipp,isplit,isplt1,isplt2,itest,iupdat,nstep LOGICAL frstme C .. C .. Local Arrays .. DOUBLE PRECISION rloc(0:1),scloc(0:1),thloc(0:1) C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. External Subroutines .. cc EXTERNAL fulprf,fulstp,inrprd C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. C This subroutine computes Franck-Condon factors, given the appropriate C eigenfunctions. errest = zero nstep = 0 C Very first bit: locate a suitable splitting point for the integration. C Locate this point on the mesh XMESH1 (well it has to be somewhere!) toloc = tol*safe icount = 0 i1low = ic1 i1high = ic1 i2low = ic2 i2high = ic2 DO 10 i = ic1,1,-1 IF ((elam1*wp1(i)-qp1(i)).LT.zero) GO TO 20 i1low = i - 1 10 CONTINUE 20 DO 30 i = ic1,n1 IF ((elam1*wp1(i)-qp1(i)).LT.zero) GO TO 40 i1high = i 30 CONTINUE 40 DO 50 i = ic2,1,-1 IF ((elam2*wp2(i)-qp2(i)).LT.zero) GO TO 60 i2low = i - 1 50 CONTINUE 60 DO 70 i = ic2,n2 IF ((elam2*wp2(i)-qp2(i)).LT.zero) GO TO 80 i2high = i 70 CONTINUE 80 IF ((xmesh1(i1high)-xmesh2(i2low))* & (xmesh2(i2high)-xmesh1(i1low)).GE.zero) THEN C There is an overlap of the classically allowed regions. We choose a C matchpoint in this region. xhigh = min(xmesh2(i2high),xmesh1(i1high)) xlow = max(xmesh2(i2low),xmesh1(i1low)) xsplit = half* (xhigh+xlow) diff = abs(xsplit-xmesh1(i1high)) isplt1 = i1high DO 90 i = i1low,i1high - 1 IF (xmesh1(i).GE.xlow .AND. xmesh1(i).LE.xhigh) THEN IF (abs(xmesh1(i)-xsplit).LE.diff) THEN isplt1 = i diff = abs(xmesh1(i)-xsplit) END IF END IF 90 CONTINUE diff = abs(xsplit-xmesh2(i2high)) isplt2 = i2high DO 100 i = i2low,i2high - 1 IF (xmesh2(i).GE.xlow .AND. xmesh2(i).LE.xhigh) THEN IF (abs(xmesh2(i)-xsplit).LE.diff) THEN isplt2 = i diff = abs(xmesh2(i)-xsplit) END IF END IF 100 CONTINUE ELSE C There is no overlap in the classically allowed regions. Use a C heuristic. xsplit = half* (xmesh1(ic1)+xmesh2(ic2)) diff = abs(xsplit-xmesh1(1)) isplt1 = 1 DO 110 i = 2,n1 - 1 IF (abs(xmesh1(i)-xsplit).LE.diff) THEN isplt1 = i diff = abs(xmesh1(i)-xsplit) END IF 110 CONTINUE diff = abs(xsplit-xmesh2(i)) isplt2 = 1 DO 120 i = 2,n2 - 1 IF (abs(xmesh2(i)-xsplit).LE.diff) THEN isplt2 = i diff = abs(xmesh2(i)-xsplit) END IF 120 CONTINUE END IF IF (abs(xmesh1(isplt1)-xsplit).LT.abs(xmesh2(isplt2)-xsplit)) THEN itest = 1 isplit = isplt1 ELSE IF (abs(xmesh1(isplt1)-xsplit).GT. & abs(xmesh2(isplt2)-xsplit)) THEN itest = 2 isplit = isplt2 ELSE IF (xmesh1(isplt1).LE.xmesh2(isplt2)) THEN itest = 1 isplit = isplt1 ELSE itest = 2 isplit = isplt2 END IF C What we just did is by no means foolproof. It is always possible that C there is a part of the range of integration where shooting in one C direction is unstable for one eigenfunction while shooting in a different C direction is unstable for the other eigenfunction. This subroutine assumes C that such an interval does not exist. rl1 = rlog1(0) th1 = theta1(0) sc1 = scale1(0) rl2 = rlog2(0) th2 = theta2(0) sc2 = scale2(0) idi = 1 di = one i1 = 1 i2 = 1 i1m1 = i1 - idi i2m1 = i2 - idi IF (xmesh1(0).EQ.xmesh2(0)) THEN xstart = xmesh1(0) iupdat = 0 ELSE IF (xmesh1(0).LT.xmesh2(0)) THEN xstart = xmesh2(0) iupdat = 1 ELSE xstart = xmesh1(0) iupdat = 2 END IF IF (iupdat.EQ.1) THEN 130 IF ((xmesh1(i1)-xstart)*di.LE.zero) THEN rloc(0) = rl1 thloc(0) = th1 scloc(0) = sc1 C WARNING: this changes i1m1 CALL fulprf(i1m1,thloc,rloc,scloc,dummy,i1,one,elam1,pp1, & qp1,wp1,xmesh1,1,n1,2) rl1 = rloc(1) th1 = thloc(1) sc1 = scloc(1) i1m1 = i1 i1 = i1 + idi GO TO 130 END IF C Integrate RL1, TH1 and SC1 from XMESH1(I1M1) to XSTART. ii1 = max(i1,i1m1) CALL fulstp(xmesh1(i1m1),xstart,di,sc1,th1,rl1,pp1(ii1), & elam1*wp1(ii1)-qp1(ii1),wp1(ii1),dummy,1) ELSE IF (iupdat.EQ.2) THEN 140 IF ((xmesh2(i2)-xstart)*di.LE.zero) THEN rloc(0) = rl2 thloc(0) = th2 scloc(0) = sc2 C WARNING: this changes i2m1 CALL fulprf(i2m1,thloc,rloc,scloc,dummy,i2,one,elam2,pp2, & qp2,wp2,xmesh2,1,n2,2) rl2 = rloc(1) th2 = thloc(1) sc2 = scloc(1) i2m1 = i2 i2 = i2 + idi GO TO 140 END IF C Integrate RL2, TH2 and SC2 from XMESH2(I2M1) to XSTART. ii2 = max(i2,i2m1) CALL fulstp(xmesh2(i2m1),xstart,di,sc2,th2,rl2,pp2(ii2), & elam2*wp2(ii2)-qp2(ii2),wp2(ii2),dummy,1) END IF frstme = .true. value = zero h = min(xmesh1(i1)-xstart,xmesh2(i2)-xstart) C We have now located a suitable starting point and initial conditions. C Integrate forward by a suitable step. C Select correct coefficient function values: 150 ipp = max(i1,i1m1) p1 = pp1(ipp) q1 = qp1(ipp) w1 = wp1(ipp) ipp = max(i2,i2m1) p2 = pp2(ipp) q2 = qp2(ipp) w2 = wp2(ipp) IF ((xmesh1(i1)-xmesh2(i2))*di.LT.zero) THEN xstop = xmesh1(i1) i1m1 = i1 i1 = i1 + idi ELSE xstop = xmesh2(i2) IF (xmesh1(i1).EQ.xmesh2(i2)) THEN i1m1 = i1 i1 = i1 + idi END IF i2m1 = i2 i2 = i2 + idi END IF hmax = min(abs(xmesh1(i1)-xmesh1(i1m1)), & abs(xmesh2(i2)-xmesh2(i2m1))) C Now perform integration from xtart to xstop: xo = xstart xfin = xstop IF (abs(xfin-xo).LT.x02ajf(one)) THEN C This interval is trivial. Do the next one. xstart = xstop GO TO 150 END IF xend = xstart + di*min(abs(xstop-xstart),abs(h),hmax) 160 rln1 = rl1 thn1 = th1 scn1 = sc1 rln2 = rl2 thn2 = th2 scn2 = sc2 xmid = half* (xo+xend) x1 = xo x2 = xmid CALL inrprd(x1,x2,p1,q1,w1,rl1,th1,sc1,elam1,p2,q2,w2,rl2,th2,sc2, & elam2,one,ans2) ans1 = ans2 ans2 = ans2*fun(half* (xo+xmid)) x2 = xmid x3 = xend CALL inrprd(x2,x3,p1,q1,w1,rl1,th1,sc1,elam1,p2,q2,w2,rl2,th2,sc2, & elam2,one,ans3) ans1 = (ans1+ans3)*fun(half* (xo+xend)) ans4 = ans2 + ans3*fun(half* (xmid+xend)) C Estimate the error err = (ans4-ans1)/three errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**trd) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. xend = xo + ratio* (xend-xo) xend = di*min(di* (xend),di*xfin) icount = icount + 1 C At most three attempts to get the stepsize right: IF (icount.LT.4) THEN rl1 = rln1 th1 = thn1 sc1 = scn1 rl2 = rln2 th2 = thn2 sc2 = scn2 GO TO 160 END IF ifail = 1 GO TO 200 ELSE value = value + (ans4+err) IF (xend*di.GE. (xfin-di*x02ajf(1.D0))*di) GO TO 170 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = di*min(ratio*abs(h),hmax) END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h C Step exactly to the end of the interval if xend >= xfin - x02ajf. In C this eventuality we do not set h = xend-xo since this might result in C excessively small stepsizes for some time thereafter. IF (xend*di.GE. (xfin-di*x02ajf(1.D0))*di) THEN xend = xfin END IF GO TO 160 END IF C Have successfully completed the integration from xo to xfin. 170 nstep = nstep + 1 icount = 0 C Integration from xstart to xstop has now been performed. What next? IF ((itest.EQ.1.AND.idi* (i1-isplit).LE.0) .OR. & (itest.EQ.2.AND.idi* (i2-isplit).LE.0)) THEN C Still another step to do (n.b. itest always has one of the values 1,2) xstart = xstop GO TO 150 END IF IF (frstme) THEN C We have only done one half of the integration. Let us do the other. rl1 = rlog1(1) th1 = theta1(1) sc1 = scale1(1) rl2 = rlog2(1) th2 = theta2(1) sc2 = scale2(1) idi = -1 di = -one i1 = n1 - 1 i2 = n2 - 1 i1m1 = i1 - idi i2m1 = i2 - idi xstart = min(xmesh1(n1),xmesh2(n2)) IF (xmesh1(n1).EQ.xmesh2(n2)) THEN xstart = xmesh1(n1) iupdat = 0 ELSE IF (xmesh1(n1).GT.xmesh2(n2)) THEN xstart = xmesh2(n2) iupdat = 1 ELSE xstart = xmesh1(n1) iupdat = 2 END IF IF (iupdat.EQ.1) THEN 180 IF ((xmesh1(i1)-xstart)*di.LT.zero) THEN rloc(0) = rl1 thloc(0) = th1 scloc(0) = sc1 C WARNING: this changes i1m1 CALL fulprf(i1m1,thloc,rloc,scloc,dummy,i1,one,elam1, & pp1,qp1,wp1,xmesh1,1,n1,2) rl1 = rloc(1) th1 = thloc(1) sc1 = scloc(1) i1m1 = i1 i1 = i1 + idi GO TO 180 END IF C Integrate RL1, TH1 and SC1 from XMESH1(I1M1) to XSTART. ii1 = max(i1,i1m1) CALL fulstp(xmesh1(i1m1),xstart,di,sc1,th1,rl1,pp1(ii1), & elam1*wp1(ii1)-qp1(ii1),wp1(ii1),dummy,1) ELSE IF (iupdat.EQ.2) THEN 190 IF ((xmesh2(i2)-xstart)*di.LT.zero) THEN rloc(0) = rl2 thloc(0) = th2 scloc(0) = sc2 C WARNING: this changes i2m1 CALL fulprf(i2m1,thloc,rloc,scloc,dummy,i2,one,elam2, & pp2,qp2,wp2,xmesh2,1,n2,2) rl2 = rloc(1) th2 = thloc(1) sc2 = scloc(1) i2m1 = i2 i2 = i2 + idi GO TO 190 END IF C Integrate RL2, TH2 and SC2 from XMESH2(I2M1) to XSTART. ii2 = max(i2,i2m1) CALL fulstp(xmesh2(i2m1),xstart,di,sc2,th2,rl2,pp2(ii2), & elam2*wp2(ii2)-qp2(ii2),wp2(ii2),dummy,1) END IF frstme = .false. h = max(xmesh1(i1),xmesh2(i2)) - xstart GO TO 150 END IF C We have now completed the integration. ans = value 200 RETURN END SUBROUTINE nfcf C -------------------------------------------------------------------- SUBROUTINE sl06fm(elam,eigfns,wk,iwk,n,k,m,i1,i2,fun,tol,elem, & ifail) C This routine computes the so-called matrix elements which are of interest C in problems arising in quantum mechanics. It acts as an interface for the C routine matel. C .. Scalar Arguments .. DOUBLE PRECISION tol INTEGER i1,i2,ifail,iwk,m,n C .. C .. Array Arguments .. DOUBLE PRECISION eigfns(0:1,1:3,1:m),elam(1:2,1:m),elem(0:1), & wk(0:iwk,1:4) INTEGER k(1:m) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION elam1,elam2 INTEGER i,ic,iflag,j1,j2,nrec LOGICAL check1,check2 CHARACTER srname*6 C .. C .. External Subroutines .. cc EXTERNAL nmatel C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs,nint C .. C .. Local Arrays .. CHARACTER rec(2)*80 C .. srname = 'SL06FM' IF (abs(ifail).GT.1 .OR. tol.LE.0.D0) THEN IF (abs(ifail).GT.1) ifail = -1 iflag = 1 WRITE (rec,FMT=9000) 9000 FORMAT ('** Parameter error: IFAIL or TOL out of range') nrec = 1 GO TO 30 END IF ic = nint(wk(0,2)) C Check that the requested eigenfunctions are available: check1 = .false. check2 = .false. DO 10 i = 1,m IF (k(i).EQ.i1) THEN j1 = i check1 = .true. END IF IF (k(i).EQ.i2) THEN j2 = i check2 = .true. END IF IF (check1 .AND. check2) GO TO 20 10 CONTINUE iflag = 2 WRITE (rec,FMT=9010) 9010 FORMAT ('** Necessary eigenfunctions not all available') nrec = 1 GO TO 30 C End of check for eigenfunction availability 20 elam1 = elam(1,j1) + elam(2,j1) elam2 = elam(1,j2) + elam(2,j2) iflag = 0 CALL nmatel(elam1,elam2,eigfns(0,1,j1),eigfns(0,1,j2), & eigfns(0,2,j1),eigfns(0,2,j2),eigfns(0,3,j1), & eigfns(0,3,j2),wk(1,2),wk(1,3),wk(1,4),wk(0,1),n,ic, & tol,fun,elem,iflag) IF (iflag.NE.0) THEN iflag = 3 WRITE (rec,FMT=9020) 9020 FORMAT ('** Autmatic step-size control has failed',/, & '** Try using a larger value of TOL') nrec = 2 GO TO 30 END IF ifail = 0 RETURN 30 ifail = p01abf(ifail,iflag,srname,nrec,rec) RETURN END SUBROUTINE sl06fm C -------------------------------------------------------------------------- SUBROUTINE nmatel(elam1,elam2,rlog1,rlog2,theta1,theta2,scale1, & scale2,pp,qp,wp,xmesh,n,ic,tol,fun,ans,ifail) C This routine computes the value of the matrix element C C Integral(a,b)w(x)Y(1)(x)fun(x)Y(2)(x)dx C C .. Parameters .. DOUBLE PRECISION one,two,three,half,trd,qtr,safe,tosafe,bound,zero PARAMETER (one=1.D0,two=2.D0,three=3.D0,half=one/two, & trd=one/three,qtr=half*half,safe=0.95D0,tosafe=0.8D0, & bound=2.D-1,zero=0.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION elam1,elam2,tol INTEGER ic,ifail,n C .. C .. Array Arguments .. DOUBLE PRECISION ans(0:1),pp(1:n),qp(1:n),rlog1(0:1),rlog2(0:1), & scale1(0:1),scale2(0:1),theta1(0:1),theta2(0:1), & wp(1:n),xmesh(0:n) C .. C .. Function Arguments .. DOUBLE PRECISION fun EXTERNAL fun C .. C .. Local Scalars .. DOUBLE PRECISION abserr,ans1,ans2,ans3,ans4,di,epsilo,err,errest, & h,hmax,p,q,ratio,rl1,rl2,rln1,rln2,sc1,sc2,scn1, & scn2,th1,th2,thn1,thn2,toloc,value,w,xend,xfin, & xmid,xo INTEGER i,icount,idi,ifin,ii,init,ip1,itime,nstep C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf cc EXTERNAL x02ajf C .. C .. External Subroutines .. cc EXTERNAL inrprd C .. C .. Intrinsic Functions .. INTRINSIC abs,max,min C .. toloc = safe*tol value = zero errest = zero nstep = 0 itime = 1 init = 0 ifin = ic - 1 idi = 1 di = one icount = 0 h = xmesh(1) - xmesh(0) rl1 = rlog1(0) th1 = theta1(0) sc1 = scale1(0) rl2 = rlog2(0) th2 = theta2(0) sc2 = scale2(0) 10 DO 40 i = init,ifin,idi xo = xmesh(i) ip1 = i + idi hmax = xmesh(ip1) - xmesh(i) h = di*min(abs(h),abs(hmax)) xfin = xmesh(ip1) C write(9,*) xo,xfin xend = xo + h ii = i IF (idi.GT.0) ii = ip1 p = pp(ii) q = qp(ii) w = wp(ii) 20 rln1 = rl1 thn1 = th1 scn1 = sc1 rln2 = rl2 thn2 = th2 scn2 = sc2 xmid = half* (xo+xend) CALL inrprd(xo,xmid,p,q,w,rl1,th1,sc1,elam1,p,q,w,rl2,th2,sc2, & elam2,one,ans2) ans1 = ans2 ans2 = ans2*fun(half* (xo+xmid)) CALL inrprd(xmid,xend,p,q,w,rl1,th1,sc1,elam1,p,q,w,rl2,th2, & sc2,elam2,one,ans3) ans1 = (ans1+ans3)*fun(half* (xo+xend)) ans4 = ans2 + ans3*fun(half* (xmid+xend)) C Estimate the error err = (ans4-ans1)/three errest = errest + err abserr = abs(err) IF (abserr.GT.toloc) THEN ratio = min(half, (toloc/abserr)**trd) C It is conceivable that a failed step may occur when we are stepping exactly C to the end xfin, in which case (xend-xo) neq h. In such a case we must C set h = ratio*(xend-xo) for the repeat step, rather than h = ratio*h. C In other cases xend-xo=h and there is nothing to worry about. h = ratio* (xend-xo) xend = xo + h icount = icount + 1 C At most three attempts to get the stepsize right: IF (icount.LT.4) THEN rl1 = rln1 th1 = thn1 sc1 = scn1 rl2 = rln2 th2 = thn2 sc2 = scn2 GO TO 20 END IF ifail = 1 GO TO 50 ELSE value = value + ans4 + err IF ((xend-xfin)*di.GE.0.0D0) GO TO 30 IF (abserr.LT.toloc*tosafe .AND. icount.EQ.0) THEN C The error is very small and the step before last was not a failure so C we may increase the stepsize. ratio = one/max(bound, (abserr/toloc)**qtr) h = ratio*h END IF C We have completed the last step successfully, and provided the step before C was not a failure we may have increased the step length. icount = 0 xo = xend xend = xo + h C Step exactly to the end of the interval if xend >= xfin - x02ajf. In C this eventuality we do not set h = xend-xo since this might result in C excessively small stepsizes for some time thereafter. IF (xend*di.GE. (xfin*di-x02ajf(epsilo))) THEN xend = xfin END IF GO TO 20 END IF C Have successfully completed the integration from xmesh(i) to xmesh(i+idi) 30 nstep = nstep + 1 icount = 0 40 CONTINUE C If itime = 1 then we have only done the shooting from xmesh(0) to C xmesh(ic), and we must therefore do the shooting from xmesh(n) to C xmesh(ic). IF (itime.EQ.1) THEN itime = 2 idi = -1 di = -one init = n ifin = ic + 1 h = xmesh(n) - xmesh(n-1) rl1 = rlog1(1) th1 = theta1(1) sc1 = scale1(1) rl2 = rlog2(1) th2 = theta2(1) sc2 = scale2(1) GO TO 10 END IF C Successful completion: ifail = 0 ans(0) = value ans(1) = errest C WRITE (6,FMT=*) 'MATEL error estimate:',errest RETURN C Unsuccessful completion: 50 ans(0) = zero ans(1) = errest RETURN END SUBROUTINE nmatel C -------------------------------------------------------------------------- SUBROUTINE inrprd(xo,xend,p1,q1,w1,rlog1,theta1,scale1,elam1,p2, & q2,w2,rlog2,theta2,scale2,elam2,f,ans) C This routine computes the inner product of two eigenfunctions over C an interval (xo,xend), advancing the Prufer radius, angle and scalefactor C for each eigenfunction as the integration proceeds. C C .. Parameters .. DOUBLE PRECISION half,qtr,two PARAMETER (half=5.D-1,qtr=half*half,two=2.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION ans,elam1,elam2,f,p1,p2,q1,q2,rlog1,rlog2,scale1, & scale2,theta1,theta2,w1,w2,xend,xo C .. C .. Local Scalars .. DOUBLE PRECISION alfa1h,alfa2h,cth1,cth2,dalfa,dalfa2,diff1,diff2, & dtheta,erl1,erl2,h,h2,pdy1nd,pdy1o,pdy2nd,pdy2o, & r01,r11,salfa,signum,snew,sqrnrm,sqrt1,sqrt2, & sth1,sth2,stheta,t1,t1o,t2,t2o,tdiff,y1end,y1o, & y2end,y2o C .. C .. External Functions .. cc DOUBLE PRECISION phi,rescal,scl,x02ajf cc EXTERNAL phi,rescal,scl,x02ajf C .. C .. External Subroutines .. cc EXTERNAL chidif,fulstp,phidif C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,exp,sign,sin,sqrt C .. h = xend - xo h2 = h**2 signum = sign(1.D0,h) t1o = (elam1*w1-q1)/p1 t2o = (elam2*w2-q2)/p2 tdiff = t1o - t2o t1 = t1o*h2 t2 = t2o*h2 IF (abs(tdiff).GT.sqrt(x02ajf(1.D0))) THEN C In this case there is a very simple formula for the integral involving C only the values of the eigenfunctions and their derivatives at each end. C STEP ONE: Compute the values of each eigenfunction and its derivative C at xo and xend. C At xo: erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1o = erl1*sth1/sqrt1 y2o = erl2*sth2/sqrt2 pdy1o = erl1*cth1*sqrt1 pdy2o = erl2*cth2*sqrt2 C At xend: first need to advance the eigenfunctions using the FULSTP routine. CALL fulstp(xo,xend,signum,scale1,theta1,rlog1,p1,elam1*w1-q1, & w1,sqrnrm,1) CALL fulstp(xo,xend,signum,scale2,theta2,rlog2,p2,elam2*w2-q2, & w2,sqrnrm,1) erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1end = erl1*sth1/sqrt1 y2end = erl2*sth2/sqrt2 pdy1nd = erl1*cth1*sqrt1 pdy2nd = erl2*cth2*sqrt2 C We can now write down the required formula for the integral: ans = - ((pdy1nd*y2end-pdy1o*y2o)/p1- & (pdy2nd*y1end-pdy2o*y1o)/p2)*f*w1/tdiff ELSE C (if (ABS(tdiff).LT.0.0001) THEN C This is the case where t1 and t2 are close, and we must use the routines C designed earlier for this case. There are two cases to consider: the first C occurs when both t1 and t2 lie in (-infty,0.1), the second when one of C these quantities lies in (0.1,infty). C The case where t1 and t2 are both less than 0.1 is what the C routines phidif and chidif were designed to handle. IF (t1.LE.0.1D0 .AND. t2.LE.0.1D0) THEN CALL chidif(-t2,-t1,diff1) r11 = diff1*h CALL phidif(-t2,-t1,diff2) r01 = -diff2*h erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1o = erl1*sth1/sqrt1 y2o = erl2*sth2/sqrt2 pdy1o = erl1*cth1*sqrt1 pdy2o = erl2*cth2*sqrt2 C At xend: first need to advance the eigenfunctions using the FULSTP routine. CALL fulstp(xo,xend,signum,scale1,theta1,rlog1,p1, & elam1*w1-q1,w1,sqrnrm,1) CALL fulstp(xo,xend,signum,scale2,theta2,rlog2,p2, & elam2*w2-q2,w2,sqrnrm,1) erl1 = exp(rlog1) erl2 = exp(rlog2) sth1 = sin(theta1) sth2 = sin(theta2) cth1 = cos(theta1) cth2 = cos(theta2) sqrt1 = sqrt(scale1) sqrt2 = sqrt(scale2) y1end = erl1*sth1/sqrt1 y2end = erl2*sth2/sqrt2 pdy1nd = erl1*cth1*sqrt1 pdy2nd = erl2*cth2*sqrt2 ans = ((y1o*y2o+y1end*y2end)*r11+ & (y1o*y2end+y1end*y2o)*r01)*w1*f ELSE C In this case we use a completely different formula, which requires the C updating of the scalefactor. Because in this case at least one of C t1, t2 is greater than 0.1 and the other is at most 0.0001*h**2 different, C it follows that both are positive. snew = sqrt((elam1*w1-q1)*p1) theta1 = scl(theta1,snew/scale1) rlog1 = rescal(scale1,snew,theta1,rlog1) scale1 = snew alfa1h = sqrt(t1) snew = sqrt((elam2*w2-q2)*p2) diff1 = sqrt(t2o) - sqrt(t1o) theta2 = scl(theta2,snew/scale2) rlog2 = rescal(scale2,snew,theta2,rlog2) scale2 = snew alfa2h = sqrt(t2) dtheta = theta1 - theta2 stheta = theta1 + theta2 dalfa = alfa1h - alfa2h dalfa2 = dalfa**2 salfa = alfa1h + alfa2h r11 = half*h* (cos(dtheta)*phi(-dalfa2)- & sin(dtheta)*half*diff1* (phi(-qtr*dalfa2)**2)- & cos(stheta)*sin(salfa)/salfa+ & signum*two*sin(stheta)* (sin(salfa*half)**2)/salfa) ans = w1*f*exp(rlog1+rlog2)*r11/sqrt(scale1*scale2) C Rlog1, rlog2, scale1 and scale2 do not need updating, but theta1 and theta2 C require updating: theta1 = theta1 + h*sqrt(t1o) theta2 = theta2 + h*sqrt(t2o) C C END of case where ABS(tdiff).LT.sqrt(x02ajf(1.d0)) END IF C END of all cases END IF C Compensate for the possible effect of backwards integration: ans = ans*sign(1.D0,xend-xo) RETURN END SUBROUTINE inrprd C ------------------------------------------------------------------------- SUBROUTINE phidrv(t,phi0,phi1,phi2,phi3,phi4,phi5) C .. Parameters .. DOUBLE PRECISION p15,p3,p6 PARAMETER (p15=15.D0,p3=3.D0,p6=6.D0) DOUBLE PRECISION half,qtr,eighth PARAMETER (half=5.D-1,qtr=half*half, C & sxtnth=qtr*qtr, & eighth=half*qtr) DOUBLE PRECISION fac3,fac4,fac5,fac6,fac7,fac8,fac9,fac10,fac11, & fac12,fac13,fac14,fac15,fac16,fac17,fac18,fac19 PARAMETER (fac3=1.D0/6.D0,fac4=fac3/4.D0,fac5=fac4/5.D0, & fac6=fac5/6.D0,fac7=fac6/7.D0,fac8=fac7/8.D0, & fac9=fac8/9.D0,fac10=fac9/1.D1,fac11=fac10/11.D0, & fac12=fac11/12.D0,fac13=fac12/13.D0,fac14=fac13/14.D0, & fac15=fac14/15.D0,fac16=fac15/16.D0,fac17=fac16/17.D0, & fac18=fac17/18.D0,fac19=fac18/19.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION phi0,phi1,phi2,phi3,phi4,phi5,t C .. C .. Local Scalars .. DOUBLE PRECISION epos,psi0,sqrto,to,to2,to3 C .. C .. External Functions .. cc DOUBLE PRECISION phi,psi,x02amf cc EXTERNAL phi,psi,x02amf C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,cosh,log,min,sin,sinh,sqrt C .. epos = (log(x02amf(half))**2)*half to = t IF (abs(t).GT.0.1D0) THEN IF (t.GT.0.1D0) THEN to = min(t,epos) sqrto = sqrt(to) phi0 = sinh(sqrto)/sqrto psi0 = cosh(sqrto) ELSE IF (t.LT. (-0.1D0)) THEN sqrto = sqrt(-to) phi0 = sin(sqrto)/sqrto psi0 = cos(sqrto) ELSE phi0 = phi(to) psi0 = psi(to) END IF to2 = to**2 to3 = to2*to C to4 = to3*to C to5 = to4*to phi1 = (psi0-phi0)*half/to phi2 = ((p3+to)*phi0-p3*psi0)*qtr/to2 phi3 = ((p15+t)*psi0- (p6*t+p15)*phi0)*eighth/to3 C phi4 = ((to2+p45*to+p105)*phi0- (p10*to+p105)*psi0)*sxtnth/to4 C phi5 = ((to2+p105*to+p945)*psi0- (p15*to2+p420*to+p945)*phi0) C & *trtsnd/to5 ELSE C IF (ABS(t).LE.0.1) THEN use Taylor expansions phi0 = phi(t) C Compute the higher derivatives phi1 = fac3 + t* (2.D0*fac5+t* & (3.D0*fac7+t* (4.D0*fac9+t* (5.D0*fac11+ & t*6.D0*fac13)))) phi2 = 2.D0*fac5 + t* (6.D0*fac7+ & t* (12.D0*fac9+t* (20.D0*fac11+t* (30.D0*fac13+ & t*42.D0*fac15)))) phi3 = 6.D0*fac7 + t* (24.D0*fac9+ & t* (60.D0*fac11+t* (120.D0*fac13+t* (210.D0*fac15+ & t*336.D0*fac17)))) C phi4 = 24.*fac9 + t* (120.*fac11+ C & t* (360.*fac13+t* (840.*fac15+t* (1680.*fac17+ C & t*3024.*fac19)))) C phi5 = 120.*fac11 + t* (720.*fac13+ C & t* (2520.*fac15+t* (6720.*fac17+t* (15120.*fac19+ C & t*30240.*fac21)))) END IF RETURN END SUBROUTINE phidrv C ---------------------------------------------------------------------------- SUBROUTINE chidrv(t,chi0,chi1,chi2,chi3,chi4,chi5) C .. Parameters .. DOUBLE PRECISION half PARAMETER (half=0.5D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION chi0,chi1,chi2,chi3,chi4,chi5,t C .. C .. Local Scalars .. DOUBLE PRECISION phi0,phi1,phi2,phi3,phi4,phi5,psi0,psi1,psi2, & psi3,rat0,rat1,rat2,rat3,rat4,rat5,rat6,sqrtt,to C .. C .. External Functions .. cc DOUBLE PRECISION chi,psi,x02amf cc EXTERNAL chi,psi,x02amf C .. C .. External Subroutines .. cc EXTERNAL phidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,cos,cosh,log,min,sqrt,tan,tanh C .. CALL phidrv(t,phi0,phi1,phi2,phi3,phi4,phi5) sqrtt = sqrt(abs(t)) to = min(t, (log(x02amf(half))**2)*half) IF (t.GT.0.1D0) THEN chi0 = sqrtt/tanh(sqrtt) psi0 = cosh(sqrt(to)) ELSE IF (t.LT. (-0.1D0)) THEN chi0 = sqrtt/tan(sqrtt) psi0 = cos(sqrtt) ELSE chi0 = chi(t) psi0 = psi(t) END IF psi1 = half*phi0 psi2 = half*phi1 psi3 = half*phi2 C psi4 = half*phi3 C psi5 = half*phi4 C We now simply type in the expressions which were obtained by MAPLE when C working out the derivative. We must be careful to do this in such a way C that overflow is avoided. This is achieved by defining the following ratios: rat0 = psi1/phi0 rat1 = psi0/phi0 rat2 = phi1/phi0 rat3 = psi2/phi0 rat4 = phi2/phi0 rat5 = psi3/phi0 rat6 = phi3/phi0 C rat7 = psi4/phi0 C rat8 = phi4/phi0 C rat9 = psi5/phi0 C rat10 = phi5/phi0 chi1 = rat0 - rat1*rat2 chi2 = rat3 - rat1*rat4 - 2.D0* (rat0-rat1*rat2)*rat2 chi3 = rat5 - 3.D0*rat3*rat2 + 6.D0*rat0* (rat2**2) - & 3.D0*rat0*rat4 - 6.D0*rat1* (rat2**3) + & 6.D0*rat1*rat2*rat4 - rat1*rat6 C chi4 = rat7 - 4.d0*rat6*rat2 + 12.d0*rat3* (rat2**2) - C & 6.d0*rat3*rat4 - 24.d0*rat0* (rat2**3) + C & 24.d0*rat0*rat2*rat4 - 4.d0*rat0*rat6 + C & 24.d0*rat1* (rat2**4) - 36.d0*rat1* (rat2**2)*rat4 + C & 6.d0*rat1* (rat4**2) + 8.d0*rat1*rat2*rat6 - rat1*rat8 C chi5 = rat9 - 5.d0*rat8*rat2 + 20.d0* (rat2**2)*rat6 - C & 60.d0* (rat2**3)*rat3 - 10.d0*rat3*rat6 - 5.d0*rat0*rat8 - C & rat1*rat10 + 60.d0*rat3*rat0*rat4 + C & 120.d0*rat0* (rat2**4) - 18.d1*rat0* (rat2**2)*rat4 + C & 30.d0*rat0* (rat4**2) + 40.d0*rat0*rat2*rat6 - C & 12.d1*rat1* (rat2**5) + 24.d1*rat1* (rat2**3)*rat4 - C & 90.d0*rat1*rat2* (rat4**2) - 60.d0*rat1* (rat2**2)*rat6 + C & 20.d0*rat1*rat4*rat6 + 10.d0*rat1*rat2*rat8 RETURN END SUBROUTINE chidrv C -------------------------------------------------------------------------- SUBROUTINE chidif(t1,t2,diff) C This routine computes the ratio C C chi(t2)-chi(t1) C --------------- C t2 - t1 C C .. Scalar Arguments .. DOUBLE PRECISION diff,t1,t2 C .. C .. Local Scalars .. DOUBLE PRECISION chi0,chi01,chi02,chi1,chi2,chi3,chi4,chi5,sqrt1, & sqrt2,tdiff,tmid C .. C .. External Functions .. cc DOUBLE PRECISION chi cc EXTERNAL chi C .. C .. External Subroutines .. cc EXTERNAL chidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,sqrt,tan,tanh C .. sqrt1 = sqrt(abs(t1)) sqrt2 = sqrt(abs(t2)) IF (t1.GT.0.1D0) THEN chi01 = sqrt1/tanh(sqrt1) ELSE IF (t1.LT. (-0.1D0)) THEN chi01 = sqrt1/tan(sqrt1) ELSE chi01 = chi(t1) END IF IF (t2.GT.0.1D0) THEN chi02 = sqrt1/tanh(sqrt2) ELSE IF (t2.LT. (-0.1D0)) THEN chi02 = sqrt2/tan(sqrt2) ELSE chi02 = chi(t2) END IF IF (abs(t1-t2).GT.0.01D0) THEN diff = (chi01-chi02)/ (t1-t2) ELSE C Expand in a Taylor series about (t1+t2)/2 tmid = 0.5D0* (t1+t2) CALL chidrv(tmid,chi0,chi1,chi2,chi3,chi4,chi5) tdiff = t2 - t1 diff = chi1 + chi3* (tdiff**2)/24.D0 C & + chi5* (tdiff**4)/ (1920.d0) END IF RETURN END SUBROUTINE chidif C --------------------------------------------------------------------- SUBROUTINE phidif(t1,t2,diff) C .. Scalar Arguments .. DOUBLE PRECISION diff,t1,t2 C .. C .. Local Scalars .. DOUBLE PRECISION drv1,drv3,phi0,phi01,phi02,phi1,phi2,phi3,phi4, & phi5,rat1,rat2,sqrto,tdiff,tmid,to1,to2 C .. C .. External Functions .. cc DOUBLE PRECISION phi,x02amf cc EXTERNAL phi,x02amf C .. C .. External Subroutines .. cc EXTERNAL phidrv C .. C .. Intrinsic Functions .. INTRINSIC abs,log,min,sin,sinh,sqrt C .. to1 = min(t1, (log(x02amf(t1))**2)*5.D-1) to2 = min(t2, (log(x02amf(t2))**2)*5.D-1) IF (abs(t1-t2).GT.0.01D0) THEN IF (t1.GT.0.1D0) THEN sqrto = sqrt(to1) phi01 = sinh(sqrto)/sqrto ELSE IF (t1.LT. (-0.1D0)) THEN sqrto = sqrt(-to1) phi01 = sin(sqrto)/sqrto ELSE phi01 = phi(to1) END IF IF (t2.GT.0.1D0) THEN sqrto = sqrt(to2) phi02 = sinh(sqrto)/sqrto ELSE IF (t2.LT. (-0.1D0)) THEN sqrto = sqrt(-to2) phi02 = sin(sqrto)/sqrto ELSE phi02 = phi(to2) END IF diff = (1.D0/phi01-1.D0/phi02)/ (t1-t2) ELSE C ABS(t1-t2) is very small tmid = 0.5D0* (t1+t2) CALL phidrv(tmid,phi0,phi1,phi2,phi3,phi4,phi5) tdiff = t2 - t1 rat1 = phi1/phi0 rat2 = phi2/phi0 C rat3 = phi3/phi0 C rat4 = phi4/phi0 C rat5 = phi5/phi0 drv1 = -rat1 drv3 = -6.D0* ((rat1**2)-rat2)*rat1 C drv5 = -12.d1* (rat1**5) + 24.d1* (rat1**3)*rat2 - C & 9.d1*rat1* (rat2**2) - 6.d1* (rat1**2)*rat3 + C & 2.d1*rat2*rat3 + 1.d1*rat1*rat4 - rat5 diff = (drv1+ (tdiff**2)*drv3/24.D0)/phi0 C & + (tdiff**4)*drv5/192.d1)/phi0 END IF RETURN END SUBROUTINE phidif C --------------------------------------------------------------------- C --------------------- Source from USEFUN ---------------------------- C --------------------------------------------------------------------- C -------------------- Useful Functions ----------------------------- DOUBLE PRECISION FUNCTION spexp(x) C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. Local Scalars .. DOUBLE PRECISION eneg LOGICAL first C .. C .. External Functions .. cc DOUBLE PRECISION x02amf cc EXTERNAL x02amf C .. C .. Intrinsic Functions .. INTRINSIC exp,log C .. C .. Save statement .. SAVE first,eneg C .. C .. Data statements .. DATA first/.true./ C .. IF (first) THEN eneg = log(x02amf(x)) first = .false. END IF spexp = x02amf(x) IF (x.GT.eneg) spexp = exp(x) END FUNCTION spexp C ------------------------------------------------------------------- DOUBLE PRECISION FUNCTION sptanh(x) C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. Local Scalars .. DOUBLE PRECISION loc C .. C .. External Functions .. cc DOUBLE PRECISION spexp cc EXTERNAL spexp C .. C .. Intrinsic Functions .. INTRINSIC abs,sign C .. loc = spexp(-2.0D0*abs(x)) sptanh = sign(1.0D0,x)* (1.0D0-loc)/ (1.0D0+loc) END FUNCTION sptanh C ---------------- Other Useful Functions -------------------------- DOUBLE PRECISION FUNCTION phi(v) C .. Parameters .. DOUBLE PRECISION a0,a1,a2,a3,a4,a5 PARAMETER (a0=1.D0,a1=a0/6.D0,a2=a1/20.D0,a3=a2/42.D0,a4=a3/72.D0, & a5=a4/110.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION v C .. phi = a0 + v* (a1+v* (a2+v* (a3+v* (a4+v*a5)))) END FUNCTION phi DOUBLE PRECISION FUNCTION psi(v) C .. Parameters .. DOUBLE PRECISION b0,b1,b2,b3,b4,b5 PARAMETER (b0=1.D0,b1=b0/2.D0,b2=b1/12.D0,b3=b2/30.D0,b4=b3/56.D0, & b5=b4/90.D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION v C .. psi = b0 + v* (b1+v* (b2+v* (b3+v* (b4+v*b5)))) END FUNCTION psi DOUBLE PRECISION FUNCTION chi(v) C .. Scalar Arguments .. DOUBLE PRECISION v C .. C .. External Functions .. cc DOUBLE PRECISION phi,psi cc EXTERNAL phi,psi C .. chi = psi(v)/phi(v) END FUNCTION chi DOUBLE PRECISION FUNCTION scl(th,u) C .. Parameters .. DOUBLE PRECISION one PARAMETER (one=1.0D0) C .. C .. Scalar Arguments .. DOUBLE PRECISION th,u C .. C .. Intrinsic Functions .. INTRINSIC atan2,cos,sin C .. scl = th + atan2((u-one)*sin(th)*cos(th),one+ (u-one)*sin(th)**2) END FUNCTION scl C --------------------------------------------------------------------- C --------------------- Source from USEFUN ---------------------------- C --------------------------------------------------------------------- SUBROUTINE c05azf(x,y,fx,tolx,ir,c,ind,ifail) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1979. C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 12A REVISED. IER-496 (AUG 1986). C MARK 13 REVISED. USE OF MARK 12 X02 FUNCTIONS (APR 1988). C .. Parameters .. CHARACTER*6 srname PARAMETER (srname='C05AZF') C .. C .. Scalar Arguments .. DOUBLE PRECISION fx,tolx,x,y INTEGER ifail,ind,ir C .. C .. Array Arguments .. DOUBLE PRECISION c(17) C .. C .. Local Scalars .. DOUBLE PRECISION ab,diff,diff1,diff2,rel,rmax,tol,tol1 INTEGER i LOGICAL t C .. C .. Local Arrays .. CHARACTER p01rec(1)*1 C .. C .. External Functions .. cc DOUBLE PRECISION x02ajf,x02akf cc INTEGER p01abf cc EXTERNAL x02ajf,x02akf,p01abf C .. C .. Intrinsic Functions .. INTRINSIC abs,dble,int,max,sign,sqrt C .. i = 0 IF ((ind.LE.0.OR.ind.GT.4) .AND. ind.NE.-1) THEN C USER NOT CHECKED IND OR CHANGED IT i = 2 ind = 0 ELSE IF (tolx.GT.0.0D0 .AND. (ir.EQ.0.OR.ir.EQ.1.OR.ir.EQ.2)) THEN rel = 1.0D0 ab = 1.0D0 IF (ir.EQ.1) rel = 0.0D0 IF (ir.EQ.2) ab = 0.0D0 IF (ind.EQ.-1) THEN c(3) = x ELSE GO TO (10,30,40,20) ind 10 c(3) = x ind = 2 RETURN 20 IF (fx.EQ.0.0D0) THEN GO TO 80 ELSE c(4) = fx rmax = abs(fx) IF (c(13)*rmax.LE.c(15)) THEN c(16) = 0.0D0 ELSE IF (c(16).EQ.1.0D0) c(16) = -1.0D0 IF (c(16).EQ.0.0D0) c(16) = 1.0D0 END IF IF (c(2).GE.0.0D0) THEN t = c(4) .GE. 0.0D0 ELSE t = c(4) .LE. 0.0D0 END IF IF (t) THEN GO TO 50 ELSE i = int(c(17)+0.1D0) i = i + 1 IF (c(11).EQ.c(12)) i = 0 c(17) = dble(i) GO TO 60 END IF END IF END IF 30 IF (fx.NE.0.0D0) THEN c(4) = fx c(15) = abs(fx) c(16) = 0.0D0 x = y y = c(3) c(2) = c(4) c(5) = x IF (ind.EQ.-1) THEN fx = c(1) ind = 3 ELSE ind = 3 RETURN END IF ELSE GO TO 80 END IF 40 IF (fx.EQ.0.0D0) THEN GO TO 80 ELSE IF (sign(1.0D0,fx).NE.sign(1.0D0,c(2))) THEN c(6) = fx c(13) = sqrt(x02ajf(0.0D0)) c(15) = max(c(15),abs(fx)) c(14) = x02akf(0.0D0) c(16) = 0.0D0 ELSE ind = 0 i = 1 GO TO 90 END IF 50 c(1) = c(5) c(2) = c(6) c(17) = 0.0D0 60 IF (abs(c(2)).LT.abs(c(4))) THEN IF (c(1).NE.c(5)) THEN c(7) = c(5) c(8) = c(6) END IF c(5) = c(3) c(6) = c(4) x = c(1) c(3) = x c(4) = c(2) c(1) = c(5) c(2) = c(6) END IF tol = 0.5D0*tolx*max(ab,rel*abs(c(3))) tol1 = 2.0D0*x02ajf(0.0D0)*max(ab,rel*abs(c(3))) diff2 = 0.5D0* (c(1)-c(3)) c(12) = diff2 diff2 = diff2 + c(3) IF (c(12).NE.0.0D0) THEN IF (abs(c(12)).LE.tol) THEN IF (c(16).GE.0.0D0) THEN y = c(1) i = 0 ELSE i = 4 END IF ind = 0 GO TO 90 ELSE IF (abs(c(12)).GT.tol1) THEN IF (c(17).LT.2.5D0) THEN tol = tol*sign(1.0D0,c(12)) diff1 = (c(3)-c(5))*c(4) IF (c(17).LE.1.5D0) THEN diff = c(6) - c(4) ELSE IF (c(7).NE.c(3) .AND. c(7).NE.c(5)) THEN c(9) = (c(8)-c(4))/ (c(7)-c(3)) c(10) = (c(8)-c(6))/ (c(7)-c(5)) diff1 = c(10)*diff1 diff = c(9)*c(6) - c(10)*c(4) ELSE GO TO 70 END IF IF (diff1.LT.0.0D0) THEN diff1 = -diff1 diff = -diff END IF IF (abs(diff1).LE.c(14) .OR. & diff1.LE.diff*tol) THEN c(11) = tol ELSE IF (diff1.GE.c(12)*diff) THEN c(11) = c(12) ELSE c(11) = diff1/diff END IF ELSE c(11) = c(12) END IF c(7) = c(5) c(8) = c(6) c(5) = c(3) c(6) = c(4) c(3) = c(3) + c(11) x = c(3) y = c(1) ind = 4 RETURN END IF END IF 70 ind = 0 i = 5 GO TO 90 80 y = x ind = 0 i = 0 ELSE i = 3 ind = 0 END IF 90 ifail = p01abf(ifail,i,srname,0,p01rec) END SUBROUTINE c05azf C -------------------------------------------------------------------- SUBROUTINE m01caf(rv,m1,m2,order,ifail) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C M01CAF SORTS A VECTOR OF REAL NUMBERS INTO ASCENDING C OR DESCENDING ORDER. C C M01CAF IS BASED ON SINGLETON'S IMPLEMENTATION OF THE C 'MEDIAN-OF-THREE' QUICKSORT ALGORITHM, BUT WITH TWO C ADDITIONAL MODIFICATIONS. FIRST, SMALL SUBFILES ARE C SORTED BY AN INSERTION SORT ON A SEPARATE FINAL PASS. C SECOND, IF A SUBFILE IS PARTITIONED INTO TWO VERY C UNBALANCED SUBFILES, THE LARGER OF THEM IS FLAGGED FOR C SPECIAL TREATMENT: BEFORE IT IS PARTITIONED, ITS END- C POINTS ARE SWAPPED WITH TWO RANDOM POINTS WITHIN IT; C THIS MAKES THE WORST CASE BEHAVIOUR EXTREMELY UNLIKELY. C C THE MAXIMUM LENGTH OF A SMALL SUBFILE IS DEFINED BY THE C VARIABLE MINQIK, SET TO 15. C C THE ROUTINE ASSUMES THAT THE NUMBER OF ELEMENTS TO BE C SORTED DOES NOT EXCEED MINQIK*2**MAXSTK. C C WRITTEN BY N.M.MACLAREN, UNIVERSITY OF CAMBRIDGE. C REVISED BY NAG CENTRAL OFFICE. C C .. Parameters .. INTEGER maxstk PARAMETER (maxstk=40) CHARACTER*6 srname PARAMETER (srname='M01CAF') INTEGER minqik PARAMETER (minqik=15) C .. C .. Scalar Arguments .. INTEGER ifail,m1,m2 CHARACTER order*1 C .. C .. Array Arguments .. DOUBLE PRECISION rv(m2) C .. C .. Local Scalars .. DOUBLE PRECISION a,rand,x INTEGER i,i1,i2,ierr,ir1,ir2,ir3,istk,j,j1,j2,k,leng,nrec C .. C .. Local Arrays .. INTEGER ihigh(maxstk),ilow(maxstk) CHARACTER p01rec(2)*80 C .. C .. External Functions .. cc INTEGER p01abf cc EXTERNAL p01abf C .. C .. Intrinsic Functions .. INTRINSIC dble,mod C .. C .. Save statement .. SAVE ir1,ir2,ir3 C .. C .. Data statements .. DATA ir1,ir2,ir3/15223,17795,28707/ C .. C C CHECK THE PARAMETERS AND DECIDE IF QUICKSORT IS NEEDED. C IF (m2.LT.1 .OR. m1.LT.1 .OR. m1.GT.m2) THEN ierr = 1 WRITE (p01rec,FMT=9000) m1,m2 nrec = 2 ELSE IF (order.NE.'A' .AND. order.NE.'a' .AND. order.NE.'D' .AND. & order.NE.'d') THEN ierr = 2 WRITE (p01rec,FMT=9010) order nrec = 1 ELSE IF (m1.EQ.m2) THEN ierr = 0 ELSE ierr = 0 leng = m2 - m1 + 1 IF (leng.GT.minqik) THEN C C INITIALISE AND START QUICKSORT ON THE WHOLE VECTOR. C istk = 0 i = m1 j = m2 10 CONTINUE C C IF THE PREVIOUS PASS WAS BAD, CHANGE THE END VALUES AT C RANDOM. C IF (i.LT.0) THEN i = -i ir1 = 171*mod(ir1,177) - 2* (ir1/177) ir2 = 172*mod(ir2,176) - 35* (ir2/176) ir3 = 170*mod(ir3,178) - 63* (ir3/178) IF (ir1.LT.0) ir1 = ir1 + 30269 IF (ir2.LT.0) ir2 = ir2 + 30307 IF (ir3.LT.0) ir3 = ir3 + 30323 rand = mod(dble(ir1)/30269.0D0+dble(ir2)/30307.0D0+ & dble(ir3)/30323.0D0,1.0D0) k = i + rand* (j-i) x = rv(i) rv(i) = rv(k) rv(k) = x k = i + j - k x = rv(k) rv(k) = rv(j) rv(j) = x END IF C C CALCULATE A MEDIAN BY SINGLETONS METHOD. C k = (i+j)/2 IF (rv(i).GT.rv(j)) THEN x = rv(i) rv(i) = rv(j) rv(j) = x END IF a = rv(k) IF (a.LT.rv(i)) THEN rv(k) = rv(i) rv(i) = a a = rv(k) ELSE IF (a.GT.rv(j)) THEN rv(k) = rv(j) rv(j) = a a = rv(k) END IF C C SPLIT THE VECTOR INTO TWO ASCENDING PARTS. THIS IS WHERE C THE TIME IS SPENT. C i1 = i j1 = j 20 CONTINUE i1 = i1 + 1 IF (rv(i1).LT.a) THEN GO TO 20 ELSE 30 CONTINUE j1 = j1 - 1 IF (rv(j1).GT.a) GO TO 30 IF (i1.LT.j1) THEN x = rv(i1) rv(i1) = rv(j1) rv(j1) = x GO TO 20 END IF END IF C C STACK ONE SUBFILE, IF APPROPRIATE, AND CARRY ON. C i2 = i1 - i j2 = j - j1 IF (j2.LE.i2) THEN IF (i2.GT.minqik) THEN C C TEST FOR VERY UNBALANCED SUBFILES C ( THE DETAILS OF THE TEST ARE FAIRLY ARBITRARY.) C IF (5* (j2+5).LT.i2) i = -i IF (j2.LE.minqik) THEN j = i1 - 1 ELSE istk = istk + 1 ilow(istk) = i ihigh(istk) = i1 - 1 i = j1 + 1 END IF GO TO 10 ELSE IF (istk.GT.0) THEN i = ilow(istk) j = ihigh(istk) istk = istk - 1 GO TO 10 END IF C C DEAL WITH THE CASE WHEN THE SECOND PART IS LARGER. C ELSE IF (j2.GT.minqik) THEN C C TEST FOR VERY UNBALANCED SUBFILES C ( THE DETAILS OF THE TEST ARE FAIRLY ARBITRARY.) C IF (5* (i2+5).LT.j2) j1 = - (j1+2) IF (i2.LE.minqik) THEN i = j1 + 1 ELSE istk = istk + 1 ilow(istk) = j1 + 1 ihigh(istk) = j j = i1 - 1 END IF GO TO 10 ELSE IF (istk.GT.0) THEN i = ilow(istk) j = ihigh(istk) istk = istk - 1 GO TO 10 END IF END IF C C TIDY UP AND DO AN ASCENDING INSERTION SORT. C DO 50 i = m1 + 1,m2 a = rv(i) j = i - 1 IF (a.LT.rv(j)) THEN 40 CONTINUE rv(j+1) = rv(j) j = j - 1 IF (j.GE.m1) THEN IF (a.LT.rv(j)) GO TO 40 END IF rv(j+1) = a END IF 50 CONTINUE C C REVERSE THE ORDER IF NECESSARY AND RETURN. C IF ((order.EQ.'D') .OR. (order.EQ.'d')) THEN DO 60 i = m1, (m1+m2-1)/2 i1 = m1 + m2 - i x = rv(i) rv(i) = rv(i1) rv(i1) = x 60 CONTINUE END IF C END IF IF (ierr.NE.0) THEN ifail = p01abf(ifail,ierr,srname,nrec,p01rec) ELSE ifail = 0 END IF C 9000 FORMAT (' ** On entry, one or more of the following parameter va', & 'lues is illegal',/,' M1 =',I16,' M2 =',I16) 9010 FORMAT (' ** On entry, ORDER has an illegal value: ORDER = ',A1) END SUBROUTINE m01caf C -------------------------------------------------------------------- INTEGER FUNCTION p01abf(ifail,ierror,srname,nrec,rec) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C MARK 13 REVISED. IER-621 (APR 1988). C MARK 13B REVISED. IER-668 (AUG 1988). C C P01ABF is the error-handling routine for the NAG Library. C C P01ABF either returns the value of IERROR through the routine C name (soft failure), or terminates execution of the program C (hard failure). Diagnostic messages may be output. C C If IERROR = 0 (successful exit from the calling routine), C the value 0 is returned through the routine name, and no C message is output C C If IERROR is non-zero (abnormal exit from the calling routine), C the action taken depends on the value of IFAIL. C C IFAIL = 1: soft failure, silent exit (i.e. no messages are C output) C IFAIL = -1: soft failure, noisy exit (i.e. messages are output) C IFAIL =-13: soft failure, noisy exit but standard messages from C P01ABF are suppressed C IFAIL = 0: hard failure, noisy exit C C For compatibility with certain routines included before Mark 12 C P01ABF also allows an alternative specification of IFAIL in which C it is regarded as a decimal integer with least significant digits C cba. Then C C a = 0: hard failure a = 1: soft failure C b = 0: silent exit b = 1: noisy exit C C except that hard failure now always implies a noisy exit. C C S.Hammarling, M.P.Hooper and J.J.du Croz, NAG Central Office. C C .. Scalar Arguments .. INTEGER ierror,ifail,nrec CHARACTER srname* (*) C .. C .. Array Arguments .. CHARACTER rec(*)* (*) C .. C .. Local Scalars .. INTEGER i,nerr CHARACTER mess*72 C .. C .. External Subroutines .. cc EXTERNAL p01abz,x04aaf,x04baf C .. C .. Intrinsic Functions .. INTRINSIC abs,mod C .. IF (ierror.NE.0) THEN C Abnormal exit from calling routine IF (ifail.EQ.-1 .OR. ifail.EQ.0 .OR. ifail.EQ.-13 .OR. & (ifail.GT.0.AND.mod(ifail/10,10).NE.0)) THEN C Noisy exit CALL x04aaf(0,nerr) DO 10 i = 1,nrec CALL x04baf(nerr,rec(i)) 10 CONTINUE IF (ifail.NE.-13) THEN WRITE (mess,FMT=9000) srname,ierror CALL x04baf(nerr,mess) IF (abs(mod(ifail,10)).NE.1) THEN C Hard failure CALL x04baf(nerr, & ' ** NAG hard failure - execution terminated' & ) CALL p01abz ELSE C Soft failure CALL x04baf(nerr, & ' ** NAG soft failure - control returned' & ) END IF END IF END IF END IF p01abf = ierror C 9000 FORMAT (' ** ABNORMAL EXIT from NAG Library routine ',A,': IFAIL', & ' =',I6) END FUNCTION p01abf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x01aaf(x) C MARK 8 RE-ISSUE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE VALUE OF THE MATHEMATICAL CONSTANT PI. C C X IS A DUMMY ARGUMENT C C IT MAY BE NECESSARY TO ROUND THE REAL CONSTANT IN THE C ASSIGNMENT STATEMENT TO A SMALLER NUMBER OF SIGNIFICANT C DIGITS IN ORDER TO AVOID COMPILATION PROBLEMS. IF SO, THEN C THE NUMBER OF DIGITS RETAINED SHOULD NOT BE LESS THAN C . 2 + INT(FLOAT(IT)*ALOG10(IB)) C WHERE IB IS THE BASE FOR THE REPRESENTATION OF FLOATING- C . POINT NUMBERS C . AND IT IS THE NUMBER OF IB-ARY DIGITS IN THE MANTISSA OF C . A FLOATING-POINT NUMBER. C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x01aaf = 3.14159265358979323846264338328D0 END FUNCTION x01aaf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02agf(x) C MARK 8 RELEASE. NAG COPYRIGHT 1980. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C RETURNS THE SMALLEST POSITIVE FLOATING-POINT NUMBER R C EXACTLY REPRESENTABLE ON THE COMPUTER SUCH THAT -R, 1.0/R, C AND -1.0/R CAN ALL BE COMPUTED WITHOUT OVERFLOW OR UNDERFLOW. C ON MANY MACHINES THE CORRECT VALUE CAN BE DERIVED FROM THOSE C OF X02AAF, X02ABF AND X02ACF AS FOLLOWS C C IF (X02ABF(X)*X02ACF(X).GE.1.0) X02AGF = X02ABF(X) C IF (X02ABF(X)*X02ACF(X).LT.1.0) C * X02AGF = (1.0+X02AAF(X))/X02ACF(X) C C THE CORRECT VALUE SHOULD BE DEFINED AS A CONSTANT, C POSSIBLY IN SOME BINARY, OCTAL OR HEXADECIMAL REPRESENTATION, C AND INSERTED INTO THE ASSIGNMENT STATEMENT BELOW. C C X IS A DUMMY ARGUMENT C C .. Scalar Arguments .. DOUBLE PRECISION x C .. C .. External Functions .. cc DOUBLE PRECISION x02amf cc EXTERNAL x02amf C .. x02agf = x02amf(x) END FUNCTION x02agf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02ahf(x) C MARK 9 RELEASE. NAG COPYRIGHT 1981. C MARK 11.5(F77) REVISED. (SEPT 1985.) C C * MAXIMUM ARGUMENT FOR SIN AND COS * C RETURNS THE LARGEST POSITIVE REAL NUMBER MAXSC SUCH THAT C SIN(MAXSC) AND COS(MAXSC) CAN BE SUCCESSFULLY COMPUTED C BY THE COMPILER SUPPLIED SIN AND COS ROUTINES. C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02ahf = 2.147483648D9 END FUNCTION x02ahf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02ajf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1/2)*B**(1-P) IF ROUNDS IS .TRUE. C RETURNS B**(1-P) OTHERWISE C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02ajf = 1.110223024625157D-16 END FUNCTION x02ajf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02akf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS B**(EMIN-1) (THE SMALLEST POSITIVE MODEL NUMBER) C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02akf = 1d-300 c x02akf = 2.9387358770557188D-39 END FUNCTION x02akf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02alf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS (1 - B**(-P)) * B**EMAX (THE LARGEST POSITIVE MODEL C NUMBER) C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02alf = 1d300 c x02alf = 1.7014118346046923D38 END FUNCTION x02alf C -------------------------------------------------------------------- DOUBLE PRECISION FUNCTION x02amf(x) C MARK 12 RELEASE. NAG COPYRIGHT 1986. C C RETURNS THE 'SAFE RANGE' PARAMETER C I.E. THE SMALLEST POSITIVE MODEL NUMBER Z SUCH THAT C FOR ANY X WHICH SATISFIES X.GE.Z AND X.LE.1/Z C THE FOLLOWING CAN BE COMPUTED WITHOUT OVERFLOW, UNDERFLOW OR OTHER C ERROR C C -X C 1.0/X C SQRT(X) C LOG(X) C EXP(LOG(X)) C Y**(LOG(X)/LOG(Y)) FOR ANY Y C C .. Scalar Arguments .. DOUBLE PRECISION x C .. x02amf = 1d-300 c x02amf = 5.8774717541114401D-39 END FUNCTION x02amf C -------------------------------------------------------------------- SUBROUTINE x04aaf(i,nerr) C MARK 7 RELEASE. NAG COPYRIGHT 1978 C MARK 7C REVISED IER-190 (MAY 1979) C MARK 11.5(F77) REVISED. (SEPT 1985.) C MARK 14 REVISED. IER-829 (DEC 1989). C IF I = 0, SETS NERR TO CURRENT ERROR MESSAGE UNIT NUMBER C (STORED IN NERR1). C IF I = 1, CHANGES CURRENT ERROR MESSAGE UNIT NUMBER TO C VALUE SPECIFIED BY NERR. C C .. Scalar Arguments .. INTEGER i,nerr C .. C .. Local Scalars .. INTEGER nerr1 C .. C .. Save statement .. SAVE nerr1 C .. C .. Data statements .. DATA nerr1/6/ C .. IF (i.EQ.0) nerr = nerr1 IF (i.EQ.1) nerr1 = nerr END SUBROUTINE x04aaf C -------------------------------------------------------------------- SUBROUTINE x04baf(nout,rec) C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C X04BAF writes the contents of REC to the unit defined by NOUT. C C Trailing blanks are not output, except that if REC is entirely C blank, a single blank character is output. C If NOUT.lt.0, i.e. if NOUT is not a valid Fortran unit identifier, C then no output occurs. C C .. Scalar Arguments .. INTEGER nout CHARACTER rec* (*) C .. C .. Local Scalars .. INTEGER i C .. C .. Intrinsic Functions .. INTRINSIC len C .. IF (nout.GE.0) THEN C Remove trailing blanks DO 10 i = len(rec),2,-1 IF (rec(i:i).NE.' ') GO TO 20 10 CONTINUE C Write record to external file 20 WRITE (nout,FMT=9000) rec(1:i) END IF C 9000 FORMAT (A) END SUBROUTINE x04baf C -------------------------------------------------------------------- SUBROUTINE p01abz C MARK 11.5(F77) RELEASE. NAG COPYRIGHT 1986. C C Terminates execution when a hard failure occurs. C C ******************** IMPLEMENTATION NOTE ******************** C The following STOP statement may be replaced by a call to an C implementation-dependent routine to display a message and/or C to abort the program. C ************************************************************* STOP END SUBROUTINE p01abz C MARK 11.5 end module MARCOMOD SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'probsets' then mkdir 'probsets' fi cd 'probsets' if test -f 'sample.f' then echo shar: will not over-write existing file "'sample.f'" else cat << SHAR_EOF > 'sample.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1997 **|****+****|****+****|** module TESTMOD use SLTSTVAR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** !Warning by JDP ! The ABINFO routine used by SLEIGN, SLEIGN2 may well be out of date ! since I kept trying new problems frequently ! GTHUHV is currently a dummy routine C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine TSTSET(ISWTCH) C .. Parameters .. C+------------------------------------------------------------------+ C| TSETNM is name given to Test Set by its implementer. | C| NPROBP is total no. of Problems. | C| There must be a Problem number I for every I from 1 to NPROBP. | C| *NOTE* When altering the Problem Set, re-set TSETNM & NPROBP !!! | C+------------------------------------------------------------------+ implicit none integer NPROBP character*8 TSETNM parameter(TSETNM='sample ', NPROBP=10) C These are used in various problems. Some are given a value by the C TSTSET(1) call, which is held for later use, so they need to be C SAVEd. Others are used as temporaries so don't need to be SAVEd: C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C .. Scalar Arguments .. integer ISWTCH C .. Local variables .. double precision TMP,NU,C1,C2 C .. Save statement .. save NU,C1,C2 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** cc print*,'Calling SAMPLE''s TSTSET with ISWTCH=',ISWTCH C Put ISWTCH.EQ.2 case first as this is the most frequently called: if (ISWTCH.eq.2) then C 'COEFFN' call: go to (12,22,32,42,52,62,72,82,92,102) IPROB else if (ISWTCH.eq.-1) then C 'TSTINI' call: C Copy title & total no. of Problems into COMMON variables: TITLE(1:8) = TSETNM NPROB = NPROBP return else if (ISWTCH.eq.0) then C 'SETUP0' call: C Start of new problem so set default values of IPARM, NEPRM: IPARM = 0 NEPRM = 0 go to (10,20,30,40,50,60,70,80,90,100) IPROB else if (ISWTCH.eq.1) then C 'SETUP1' call: go to (11,21,31,41,51,61,71,81,91,101) IPROB else if (ISWTCH.eq.3) then go to (13,23,33,43,53,63,73,83,93,103) IPROB else if (ISWTCH.eq.4) then go to (14,24,34,44,54,64,74,84,94,104) IPROB else C This signals a serious coding error in the Package so: print *,'Invalid ISWTCH',ISWTCH,' and/or IPROB',IPROB, + ' input to TSTSET call' stop end if C***+****|****+****| START OF PROBLEM SET |****+****|****+****|** C Problem #1 10 TITLE = 'Simple equation -u" = lambda u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 11 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 12 P = 1D0 Q = 0D0 W = 1D0 go to 1002 13 U = A2 PDU = A1 go to 1003 14 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #2 20 TITLE = "transformed -u''=lambda u" NPARM = 1 NEPRM = 0 PARNM = 'NU, must be >0' go to 1000 21 NU = PARM(1) C1 = (NU*NU-1D0)/4D0 C2 = NU+NU-2D0 A = 0D0 B = PI**(1D0/NU) ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 22 P = 1D0 Q = C1/(X*X) W = NU*NU*X**C2 go to 1002 23 U = A2 PDU = A1 go to 1003 24 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #3 30 TITLE = "Branko Curgus2: -y''=lambda x y on [-1,1]" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 31 A = -1D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 1D0 A1 = 01D0 B2 = 1D0 B1 = 01D0 go to 1001 32 P = 1D0 Q = 0D0 W = X go to 1002 33 U = A2 PDU = A1 go to 1003 34 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #4 40 TITLE = "-u''=lambda u with a lambda-dependent BC" NPARM = 2 NEPRM = 0 PARNM = "A1', A2' where (A1+lam*A1')u(a)=(A2+lam*A2')pu'(a)" go to 1000 41 A = 0d0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0d0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 42 P = 1D0 Q = 0D0 W = 1D0 go to 1002 43 U = A2+EIG*PARM(2) PDU = A1+EIG*PARM(1) go to 1003 44 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #5 50 TITLE = "Branko Curgus4: -(sign(x)y')'=lambda sign(x) y on [-1,1]" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 51 A = -1d0 B = 1d0 ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 52 P = sign(1D0,X) Q = 0D0 W = P go to 1002 53 U = A2 PDU = A1 go to 1003 54 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #6 60 TITLE = "Klaus 1: -(y'/2)'+(x^2/8(x<0),x^2/2(x>=0)y = lambda y" NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 61 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 62 P = 0.5D0 if (X.lt.0d0) then Q = 0.125d0*X*X else Q = 0.5d0*X*X end if W = 1D0 go to 1002 63 U = A2 PDU = A1 go to 1003 64 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #7 70 TITLE = 'Simple equation -u" = lambda u with u = A1*x+A2 near 0' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 71 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 72 P = 1D0 Q = 0D0 W = 1D0 go to 1002 73 U = A1*X+A2 PDU = A1 go to 1003 74 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #8 80 TITLE = 'Another transformed version of Hinz problem' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 81 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 1D0 B1 = 0D0 go to 1001 82 TMP = 1D0-X P = X*TMP Q = X/(TMP**3)*COS(X/TMP) W = X/(TMP**3) go to 1002 83 U = A2 PDU = A1 go to 1003 84 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #9 90 TITLE = +'Transformed Hinz prob, -(xu'')'' + x cos(x) u = lambda x u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 91 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 92 P = X Q = X*COS(X) W = X go to 1002 93 U = A2 PDU = A1 go to 1003 94 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #10 100 TITLE = 'Hinz problem -u" + (cos(x) - 1/(4x^2))u = lambda u' NPARM = 0 NEPRM = 0 PARNM = ' ' go to 1000 101 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 102 P = 1D0 Q = COS(X) - 0.25D0/(X*X) W = 1D0 go to 1002 103 U = A2 PDU = A1 go to 1003 104 U = B2 PDU = B1 go to 1004 C***+****|****+****| END OF PROBLEM SET |****+****|****+****|** 1000 continue 1001 continue 1002 continue 1003 continue 1004 continue end subroutine TSTSET C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine ABINFO(P0ATA,QFATA,P0ATB,QFATB) C This is a special routine for SLEIGN, SLEIGN2 C******* THIS ROUTINE APPLIES TO A SPECIFIC TEST SET ONLY ************ C User beware. It may be out of date. implicit none integer NPROB parameter (NPROB=10) C .. Scalar Arguments .. double precision P0ATA,QFATA,P0ATB,QFATB C .. Local Arrays .. integer P0A(1:NPROB),QFA(1:NPROB),P0B(1:NPROB),QFB(1:NPROB) C 1 2 3 4 5 6 7 8 9 10 data P0A/0,0,0,0,0,0,0,0,0,0/ data QFA/1,0,1,1,1,1,1,1,1,0/ data P0B/0,0,0,0,0,0,0,0,0,1/ data QFB/1,1,1,1,1,1,1,1,1,1/ P0ATA = 2*P0A(IPROB) - 1 QFATA = 2*QFA(IPROB) - 1 P0ATB = 2*P0B(IPROB) - 1 QFATB = 2*QFB(IPROB) - 1 C Now special cases need to be handled! C In some problems this info may depend on values of parameters C ... end subroutine ABINFO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTHUHV(IEND,XA,UA,VA,HU,HV) C This routine is used only by SOLVRS in its interface to SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE SAMPLE TEST SET ONLY ************ C When changing the test set, you must put code in here if you wish C the limit-circle facility of SLEIGN2 to work correctly! implicit none integer IEND double precision XA,UA,VA,HU,HV double precision AA,BB,ALPHA,NU,OM,OMSQ,TEMP C Returns the HU,HV info needed by SLEIGN2 as part of its UV routine. C (May be included in main TSTSET eventually) C Arguments: C IEND: (input) 0 or 1 for left or right endpoint C XA: (input) point where boundary condition info is evaluated C For the others, see SLEIGN2's documentation. C Kluge, to set valid fl.pt. values: SLEIGN2 does funny things.. HU = 0D0 HV = 0D0 C Change the labels below to execute appropriate code for any problem C with a LC endpoint. if (ATYPE(1:2).eq.'LC' .or. BTYPE(1:2).eq.'LC') then go to(10,10,10,10,10,10,10,10,10,10) IPROB else C If neither endpoint is LC, UV is not needed so do nothing return end if 10 write(*,*) 'Error in GTHUHV, Problem',IPROB,' has LC endpoint', + ' but no HU,HV info implemented for it' stop C Insert code on these lines: C 120 if (IEND.eq.0) then C HU = ... C HV = ... C else ... C end if C go to 1000 C 1000 end subroutine GTHUHV end module TESTMOD SHAR_EOF fi # end of overwriting check if test -f 'standard.f' then echo shar: will not over-write existing file "'standard.f'" else cat << SHAR_EOF > 'standard.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1997 **|****+****|****+****|** module TESTMOD use SLTSTVAR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C STANDARD Problem Set v1.2 Apr 96 by John Pryce C Revision History C v1.0 with original SLTSTPAK 1994 C v1.1 Apr 96: C - Minor changes to coefficient functions to reduce risk of overflow C - Implement/correct almost all the BC functions for LC problems. C Still some that I haven't managed to solve, on LCN/LCO border! C v1.2 Feb 97: converted to a F90 module. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine TSTSET(ISWTCH) C TSTSET contains the full definition of each problem. C The effect of a call is controlled by the module variable IPROB C (Problem number) and argument ISWTCH(section of code within the C Problem) via a number of computed GOTO statements at the top. C Case ISWTCH=-1: initialization call done once per run C Case ISWTCH=0: SETUP0 code, first setting-up stage C Case ISWTCH=1: SETUP1 code, second setting-up stage after reading C parameter values C Case ISWTCH=2: COEFFN code, evaluate coefficient functions C Case ISWTCH=3: GETBCS(Left) code, evaluate left BC C Case ISWTCH=4: GETBCS(Right) code, evaluate right BC C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Uses module variables described below C * NOTE. For readability the module variables are renamed inside C this routine(PARM becomes PARM etc); the description below uses C the 'standard' names. C The different types of call are: C+------------------------------------------------------------------+ C| Case ISWTCH=-1(called from TSTINI) | C| INITIALIZATION CALL done once per run: | C+------------------------------------------------------------------+ C Copies value of C NPROBP(the no. of Problems in the collection) C TSETNM(the name of the collection) C set in a PARAMETER statement, to module vars NPROB & TITLE, so C they can be transmitted to the Driver by TSTINI. C * NOTE. TSTSET is the only package routine that 'knows' this C information. Encapsulating this data inside TSTSET makes it C replaceable by another TSTSET without changing *any* other C part of the package. C C+------------------------------------------------------------------+ C| PROBLEM-SPECIFIC CALLS: | C| Various computed GOTOs controlled by IPROB cause a jump to | C| label 10*IPROB+ISWTCH, for instance calling TSTSET(3) for | C| Problem 17 will jump to label 173. | C+------------------------------------------------------------------+ C Case ISWTCH=0(called from SETUP0). C Input is the value of IPROB, set by SETUP0. C The title of the problem, number of parameters and the names C of parameters are put in the module variables TITLE, NPARM C and PARNM respectively. C Case ISWTCH=1(called from SETUP1). C Input, as well as the data set up by SETUP0 call, is the C parameter array PARM, set by SETUP1. C The endpoints are put in module variables A and B. C Their types are put in module variables ATYPE and BTYPE. C Their default BC coefficients are put in module variables C A1, A2, B1, B2. C Symmetry information is put in SYM. C Case ISWTCH=2(called from COEFFN). C Input is the value of X, set by COEFFN. C Evaluate p,q,w at x=X and put the result in P,Q,W. C Case ISWTCH=3(called from GETBCS(Left), i.e. GETBCS with IEND=0). C Input is the value of X and PARM(0), aka EIG, set by GETBCS. C Evaluate the LEFT-hand BC information at x=X, lambda=PARM(0), C aka EIG, putting the results in module variables PDU, U. C Case ISWTCH=4(called from GETBCS(Right), i.e. GETBCS with IEND=1). C Input is the value of X and PARM(0), aka EIG, set by GETBCS. C Evaluate the RIGHT-hand BC information at x=X, lambda=PARM(0), C aka EIG, putting the results in module variables PDU, U. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C .. Parameters .. C+------------------------------------------------------------------+ C| TSETNM is name given to Test Set by its implementer. | C| NPROBP is total no. of Problems. | C| There must be a Problem number I for every I from 1 to NPROBP. | C| *NOTE* When altering the Problem Set, re-set TSETNM & NPROBP !!! | C+------------------------------------------------------------------+ implicit none integer NPROBP character*8 TSETNM parameter(TSETNM='standard', NPROBP=60) C .. Local Scalars .. C These are used in various problems. Some are given a value by the C TSTSET(1) call, which is held for later use, so they need to be C SAVEd. Others are used as temporaries so don't need to be SAVEd: C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** double precision ALPHA,BETA,C,D,DE,DESCAL,EXPM2X,EXPMX,L, + LLP1,N,NU,NUSQ,OMEGA,PDUF,PDUNF,R,RE,REX6,T,TEMP,THETA,UF, + UNF,VEL C .. Scalar Arguments .. integer ISWTCH C .. Save statement .. save ALPHA,BETA,C,NU,NUSQ,N, + OMEGA,T,VEL,DE,RE,L,DESCAL,LLP1,REX6 C .. Data statements .. data DE/62D0/,RE/3.56D0/,L/7D0/ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Put ISWTCH.EQ.2 case first as this is the most frequently called: if (ISWTCH.eq.2) then C 'COEFFN' call: go to(12,22,32,42,52,62,72,82,92,102,112,122,132,142,152,162, + 172,182,192,202,212,222,232,242,252,262,272,282,292,302, + 312,322,332,342,352,362,372,382,392,402,412,422,432,442, + 452,462,472,482,492,502,512,522,532,542,552,562,572,582, + 592,602) IPROB else if (ISWTCH.eq.-1) then C 'TSTINI' call: C Copy title & total no. of Problems into module variables: TITLE(1:8) = TSETNM NPROB = NPROBP return else if (ISWTCH.eq.0) then C 'SETUP0' call: C Start of new problem so set default values of IPARM, NEPRM: IPARM = 0 NEPRM = 0 go to(10,20,30,40,50,60,70,80,90,100,110,120,130,140,150,160, + 170,180,190,200,210,220,230,240,250,260,270,280,290,300, + 310,320,330,340,350,360,370,380,390,400,410,420,430,440, + 450,460,470,480,490,500,510,520,530,540,550,560,570,580, + 590,600) IPROB else if (ISWTCH.eq.1) then C 'SETUP1' call: go to(11,21,31,41,51,61,71,81,91,101,111,121,131,141,151,161, + 171,181,191,201,211,221,231,241,251,261,271,281,291,301, + 311,321,331,341,351,361,371,381,391,401,411,421,431,441, + 451,461,471,481,491,501,511,521,531,541,551,561,571,581, + 591,601) IPROB else if (ISWTCH.eq.3) then go to(13,23,33,43,53,63,73,83,93,103,113,123,133,143,153,163, + 173,183,193,203,213,223,233,243,253,263,273,283,293,303, + 313,323,333,343,353,363,373,383,393,403,413,423,433,443, + 453,463,473,483,493,503,513,523,533,543,553,563,573,583, + 593,603) IPROB else if (ISWTCH.eq.4) then go to(14,24,34,44,54,64,74,84,94,104,114,124,134,144,154,164, + 174,184,194,204,214,224,234,244,254,264,274,284,294,304, + 314,324,334,344,354,364,374,384,394,404,414,424,434,444, + 454,464,474,484,494,504,514,524,534,544,554,564,574,584, + 594,604) IPROB else C This signals a serious coding error in the Package so: print *,'Invalid ISWTCH',ISWTCH,' and/or IPROB',IPROB, + ' input to TSTSET call' stop end if C***+****|****+****| START OF PROBLEM SET |****+****|****+****|** C Problem #1 C This is parametrized to test the nonlinear-in-eigenparameter facility C of NAG D02Kxx routines 10 TITLE = '-u" + u/(x+alpha)^2 = lambda u' NPARM = 1 NEPRM = 1 PARNM = 'alpha(>0, 0.1 gives standard problem in book)' go to 1000 11 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 12 ALPHA = PARM(1) P = 1D0 Q = 1D0/(X+ALPHA)**2 W = 1D0 if (IPARM .eq. 1) then Q = EIG*W - Q W = 2d0/(X+ALPHA)**3 end if go to 1002 13 U = A2 PDU = A1 go to 1003 14 U = B2 PDU = B1 go to 1004 C For $\lam_k$ see Appendix A C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #2 20 TITLE = 'Mathieu equation -u" + 2r cos(2x) u = lambda u' NPARM = 1 NEPRM = 1 PARNM = 'r' go to 1000 21 A = 0D0 B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 22 P = 1D0 Q = 2D0*PARM(1)*COS(2D0*X) W = 1D0 if (IPARM .ne. 0) then C Only IPARM=1 allowed, taking PARM(1)=r as eigenparameter Q = PARM(0)*W - Q W = 4D0*SIN(2D0*X) end if go to 1002 23 U = A2 PDU = A1 go to 1003 24 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems with strongly varying coefficient behaviour C Problem #3 30 TITLE = 'Ref: Klotter, Technisch Schwingungslehre, I, p.12' NPARM = 0 PARNM = ' ' go to 1000 31 A = 8D0/7D0 B = 8D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 32 P = 1D0 Q = 3D0/(4D0*X**2) W = 64*PI*PI/(9D0*X**6) go to 1002 33 U = A2 PDU = A1 go to 1003 34 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 2$ \qquad Regular \qquad $u(b) = 0$ C $\lam_k =(k+1)^{2}$, $k = 0,1,\ldots$\\ C Transformation of $-d^2v/dt^2=\lam v$, $v(\pi/3)=0=v(4\pi/3)$ by C $t={4\pi / 3x^2}$, $u=x^{3/2}v$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #4 40 TITLE = 'Truncated Hydrogen equation' NPARM = 1 PARNM = 'Right-hand endpoint b' go to 1000 41 A = 0D0 B = PARM(1) ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 42 P = 1D0 Q = -1D0/X + 2D0/X**2 W = 1D0 go to 1002 43 U = A2 PDU = A1 go to 1003 44 U = B2 PDU = B1 go to 1004 C As $b$ is increased some codes run into meshing difficulties, putting C too few meshpoints near 0. C The lower evs well approximate those of the infinite problem. C E.g. with b=1000: C \lambda_0=-6.250000000000E-2, \lambda_9=-2.066115702478E-3, C \lambda_17=-2.5757359232E-4, \lambda_18=2.873901310E-5. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems with oscillatory coefficients C Problem #5 50 TITLE = 'Version of Mathieu equation, -u" + c cos(x) u = lambda u' NPARM = 1 PARNM = 'c' go to 1000 51 A = 0D0 B = 40D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 52 P = 1D0 Q = PARM(1)*COS(X) W = 1D0 go to 1002 53 U = A2 PDU = A1 go to 1003 54 U = B2 PDU = B1 go to 1004 C The lower eigenvalues form clusters of 6; more and tighter clusters as C $c$ increases. C For $c=5$: $\lam_0=-3.484229$, $\lam_5=-3.484187$, $\lam_6=-0.599543$, C $\lam_11=-0.595603$, $\lam_12=1.932915$, $\lam_17=1.995459$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #6 60 TITLE = 'Truncated Gelfand-Levitan.' NPARM = 0 PARNM = ' ' go to 1000 61 A = 0D0 B = 100D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 1D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 62 P = 1D0 T = 1D0 + X/2D0 + SIN(2D0*X)/4D0 Q = 2D0*(T*SIN(2D0*X)+COS(X)**4)/T**2 W = 1D0 go to 1002 63 U = A2 PDU = A1 go to 1003 64 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)-(pu')(a) = 0$ \\ C $b = 100$ \qquad Regular \qquad $u(b) = 0$ C $\lam_0 = 0.00024681157 \qquad\lam_{99} = 9.77082852816$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Close-eigenvalue problems C Problem #7 70 TITLE = + 'Coffey-Evans eqn -u" + beta[beta sin(2x)^2 - 2cos(2x)]u = lam u' NPARM = 1 PARNM = 'beta' go to 1000 71 A = -PI/2D0 B = -A ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. BETA = PARM(1) A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 72 P = 1D0 Q = -2D0*BETA*COS(2.D0*X) + (BETA*SIN(2D0*X))**2 W = 1D0 go to 1002 73 U = A2 PDU = A1 go to 1003 74 U = B2 PDU = B1 go to 1004 C $a = -\pi/2 $ \qquad Regular \qquad $u(a) = 0$ \\ C $b = \pi/2 $ \qquad Regular \qquad $u(b) = 0$ C As $\beta$ increases there are very close eigenvalue triplets C $\{\lam_2,\lam_3,\lam_4\}$, $\{\lam_6,\lam_7,\lam_8\}$, \ldots, with C the other evs well separated. $\lam_0$ is very close to zero. \\ C $(\beta=20)\lam_0 = 0.0000000000000 \qquad \lam_3 = 151.46322365766$\\ C $(\beta=30)\lam_0 = 0.0000000000000 \qquad \lam_3 = 231.66492931296$\\ C $(\beta=50)\lam_0 = 0.0000000000000 \qquad \lam_3 = 391.808191489$\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #8 80 TITLE = 'Truncated Lennard-Jones LJ(12,6)' NPARM = 1 PARNM = 'endpoint b' go to 1000 81 A = 0D0 B = PARM(1) ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. DESCAL = 1.92D0/16.858056*DE LLP1 = L*(L+1D0) A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 82 P = 1D0 REX6 =(RE/X)**6 Q = DESCAL*REX6*(REX6-2D0) + LLP1/X**2 W = 1D0 go to 1002 83 U = A2 PDU = A1 go to 1003 84 U = B2 PDU = B1 go to 1004 C Shows close evs can happen even with highly asymmetric potentials. C The effect is due to the resonance barrier. C With constants as given, b=38.85 gives approximately the minimum C splitting: C \lam_0=0.0899594272, \lam_1=0.0899769187. C q(x) gets large at 0: left BC u(0.8)=0 is acceptable substitute C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Regular problems that look singular C Problem #9 90 TITLE = + 'Regular with nasty w(x). Ref Fox, BVPs in DEs, Wisconsin 1960' NPARM = 0 PARNM = ' ' go to 1000 91 A = -1D0 B = 1D0 ATYPE = 'WR' BTYPE = 'WR' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 92 P = 1D0/SQRT(1-X**2) Q = 0D0 W = P go to 1002 93 U = A2 PDU = A1 go to 1003 94 U = B2 PDU = B1 go to 1004 C $a = -1$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C $\lam_0 = 3.559279966 \qquad \lam_9 = 258.8005854$ C $\lam_{24} = 1572.635284 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #10 100 TITLE = + 'Regular with nasty 1/p(x). Ref: J D Pryce, Num Sol SLPs, 1993' NPARM = 0 PARNM = ' ' go to 1000 101 A = -1D0 B = 1D0 ATYPE = 'WR' BTYPE = 'WR' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 102 P = SQRT(1-X**2) Q = 0D0 W = 1D0 go to 1002 103 U = A2 PDU = A1 go to 1003 104 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = 0.3856819?? \qquad \lam_9 = 1031.628??$(values uncertain) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #11 110 TITLE = 'Regular with nasty q(x). Ref: Pruess/Fulton 133' NPARM = 0 PARNM = ' ' go to 1000 111 A = 0D0 B = 4D0 ATYPE = 'WR' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 112 P = 1D0 Q = LOG(X) W = 1D0 go to 1002 113 U = A2 PDU = A1 go to 1003 114 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ C $b = 4$ \qquad Regular \qquad $u(b) = 0$ C $ \lambda _0 = 1.1248168097 \qquad \lambda _{24} = 385.92821596$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Parametrized singular problems C Problem #12 120 TITLE = 'Bessel`s equation -(xu'')'' + (nu**2/x) u = lambda x u' NPARM = 1 PARNM = 'nu**2(can be <0)' go to 1000 121 A = 0D0 B = 1D0 NUSQ = PARM(1) C Note usual NU is actually i*(this NU) when NUSQ<0: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if BTYPE = 'R' SYM = .FALSE. C in all cases: A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 122 P = X Q = NUSQ/X W = X go to 1002 123 if (NUSQ.ge.1D0) then U = A2 PDU = A1 else if (NUSQ.gt.0D0) then U = A1*(X**NU) + A2/(X**NU) PDU = NU*A1*(X**NU) - NU*A2/(X**NU) else if (NUSQ.eq.0D0) then U = A1 + A2*LOG(X) PDU = A2 else U = A1*COS(NU*LOG(X)) + A2*SIN(NU*LOG(X)) PDU = NU*(-A1*SIN(NU*LOG(X))+A2*COS(NU*LOG(X))) end if go to 1003 124 U = B2 PDU = B1 go to 1004 C $ a = 0 $ \qquad LcN if $0\leq\nu<1$, LpN if $\nu\geq1$ C \qquad Fried. bc: $\nu u(a)-(pu')(a) = 0$ \\ C $ b = 1 $ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\nu={1\over3}$: $\lam_0=8.4250069295$ \qquad $\lam_9=970.7184494$\\ C $\nu=2$: $\lam_0 = 26.374616427 \qquad \lam_9 = 1136.8036878 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #13 130 TITLE = + 'Bessel eqn in normal form. -u" + ((nu**2-1/4)/x**2)u = lam u' NPARM = 1 PARNM = 'nu**2(can be <0)' go to 1000 131 NUSQ = PARM(1) A = 0D0 B = 1D0 C settng NU for NUSQ < 0(as well as >= 0) is useful for LCO case: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' C special case which doesn't occur in the non-normal form else if (NUSQ.eq.0.25D0) then ATYPE = 'R' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if C In all cases take: A2 = 0D0 A1 = 1D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 132 P = 1D0 Q = 0D0 if (NUSQ.ne.0.25D0) Q =(NUSQ-0.25D0)/(X*X) W = 1D0 go to 1002 C BCs handle all cases: 133 if (NUSQ.ge.1D0) then C LPN case U = A2 PDU = A1 else if (NUSQ.eq.0.25D0) then C Regular case U = A1*X + A2 PDU = A1 else if (NUSQ.ge.0D0) then C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(0.5D0+NU) UNF = X**(0.5D0-NU) PDUF =(0.5D0+NU)*UF/X PDUNF =(0.5D0-NU)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF c print*,'TSTSET#13:X,A1,A2,UF,UNF,PDUF,PDUNF,U,PDU', c + X,A1,A2,UF,UNF,PDUF,PDUNF,U,PDU else C LCO case, BC function RealPart(x**(1/2+i*nu)(a1-i*a2)) TEMP = NU*LOG(X) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A1+NU*A2)*COS(TEMP)-(NU*A1-0.5D0*A2)*SIN(TEMP))/ + SQRT(X) end if go to 1003 134 U = B2 PDU = B1 go to 1004 C Same cases as Problem 12 except for extra Regular case. C BC functions are sqrt(x) times those of Problem 12. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #14 140 TITLE = + 'Ref: Bender & Orzsag. -u" - l(l+1)sech**2(x) u = lambda u' NPARM = 1 PARNM = 'l' go to 1000 141 L = PARM(1) A = -XINFTY B = XINFTY ATYPE = 'LPNO' BTYPE = 'LPNO' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 142 P = 1D0 C Compute sech^2 x without overflow risk: EXPM2X = EXP(-2D0*ABS(X)) Q = -L*(L+1D0) * 4D0*EXPM2X/(1D0+EXPM2X)**2 W = 1D0 go to 1002 143 U = A2 PDU = A1 go to 1003 144 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN/O \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: $l$ \qquad \Spc:(0,$\infty $) \qquad C $ \lam_k = -(l+1-k)^{2}$, $k = 1,2,\ldots,l$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #15 150 TITLE = + 'Assoc. Legendre eqn. -((1-x^2)u'')'' + c u/(1-x^2) = lambda u' NPARM = 1 PARNM = 'c(c=0 for usual Legendre, c=1/4 for Chebyshev)' go to 1000 151 A = -1D0 B = 1D0 C = PARM(1) C See note re NU in Prob 12: NU = SQRT(ABS(C)) if (C.ge.1D0) then ATYPE = 'LPN' BTYPE = 'LPN' else if (C.ge.0D0) then ATYPE = 'LCN' BTYPE = 'LCN' else ATYPE = 'LCO' BTYPE = 'LCO' end if C In all cases: A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .TRUE. go to 1001 C Remaining bits assume C & NU have been set: 152 P = 1D0 - X**2 Q = C/(1D0-X**2) W = 1D0 go to 1002 153 if (C.ge.1D0) then C LPN case: U = A2 PDU = A1 else if (C.gt.0D0) then C LCN case: TEMP =(1D0-X**2)**(NU*0.5D0) U = A1*TEMP + A2/TEMP PDU = NU*X*(-A1*TEMP+A2/TEMP) else if (C.eq.0D0) then C Also LCN: U = A1 + A2*LOG(1-X**2) PDU = -A2*2D0*X else C LCO case: TEMP = NU*0.5D0*LOG(1-X**2) U = A1*COS(TEMP) + A2*SIN(TEMP) PDU = NU*X*(A1*SIN(TEMP)-A2*COS(TEMP)) end if go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 154 if (C.gt.1D0) then C LPN case: U = B2 PDU = B1 else if (C.gt.0D0) then C LCN case: TEMP =(1D0-X**2)**(NU*0.5D0) U = B1*TEMP + B2/TEMP PDU = NU*X*(-B1*TEMP+B2/TEMP) else if (C.eq.0D0) then C Also LCN: U = B1 + B2*LOG(1-X**2) PDU = -B2*2D0*X else C LCO case: TEMP = NU*0.5D0*LOG(1-X**2) U = B1*COS(TEMP) + B2*SIN(TEMP) PDU = NU*X*(B1*SIN(TEMP)-B2*COS(TEMP)) end if go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $ \lambda _k =(k+\nu+1)(k+\nu), k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #16 160 TITLE = +'Assoc Legendre tfmed. -u" + [(c-1/4)sec(x)^2 - 1/4] u = lambda u' NPARM = 1 PARNM = + 'c(c=0 for usual Legendre, c=1/4 reduces to regular case)' go to 1000 161 A = -PI/2D0 B = PI/2D0 C = PARM(1) NU = SQRT(ABS(C)) if (C.ge.1D0) then ATYPE = 'LPN' BTYPE = 'LPN' else if (C.eq.0.25D0) then ATYPE = 'R' BTYPE = 'R' else if (C.ge.0D0) then ATYPE = 'LCN' BTYPE = 'LCN' else ATYPE = 'LCO' BTYPE = 'LCO' end if C In all cases: A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .TRUE. go to 1001 C Remaining bits assume C & NU have been set: 162 P = 1D0 Q =(C-0.25D0)/COS(X)**2 - 0.25D0 W = 1D0 go to 1002 163 if (C.gt.1D0) then C LPN case: U = A2 PDU = A1 else if (C.gt.0D0) then C LCN case: TEMP = COS(X)**NU U =(A1*TEMP+A2/TEMP)*SQRT(COS(X)) PDU = -((0.5D0+NU)*A1*TEMP+ (0.5D0-NU)*A2/TEMP)*SIN(X)/ + SQRT(COS(X)) else if (C.eq.0D0) then if(cos(x).lt.1d-7) print*,'x,x-a,cos x=',x,x-a,cos(x) C Also LCN: U =(A1+A2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(A1+A2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) else C LCO case: TEMP = NU*LOG(COS(X)) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(COS(X)) PDU =((-0.5D0*COS(TEMP)+NU*SIN(TEMP))*A1+ + (-0.5D0*SIN(TEMP)-NU*COS(TEMP))*A2)*SIN(X)/SQRT(COS(X)) end if go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 164 if (C.gt.1D0) then C LPN case: U = B2 PDU = B1 else if (C.gt.0D0) then C LCN case: TEMP = COS(X)**NU U =(B1*TEMP+B2/TEMP)*SQRT(COS(X)) PDU = -((0.5D0+NU)*B1*TEMP+ (0.5D0-NU)*B2/TEMP)*SIN(X)/ + SQRT(COS(X)) else if (C.eq.0D0) then if(cos(x).lt.1d-7) print*,'x,b-x,cos x=',x,b-x,cos(x) C Also LCN: U =(B1+B2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(B1+B2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) else C LCO case: TEMP = NU*LOG(COS(X)) U =(B1*COS(TEMP)+B2*SIN(TEMP))*SQRT(COS(X)) PDU =((-0.5D0*COS(TEMP)+NU*SIN(TEMP))*B1+ + (-0.5D0*SIN(TEMP)-NU*COS(TEMP))*B2)*SIN(X)/SQRT(COS(X)) end if go to 1004 C Spectrum as for previous problem C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #17 170 TITLE = + 'Anharmonic oscillator(Marletta PhD) -u" + x^alpha u = lambda u' NPARM = 1 PARNM = 'alpha' go to 1000 171 ALPHA = PARM(1) A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPN' A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 SYM = .FALSE. go to 1001 172 P = 1D0 Q = X**ALPHA W = 1D0 go to 1002 173 U = A2 PDU = A1 go to 1003 174 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN \\ C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\alpha=2$: $\lam_k = 4k+3$, $k = 0,1,2,\ldots$ C $\alpha=3$: $\lam_0 = 3.4505626899 \qquad \lam_{24} = 228.52088139$ C $\alpha=4$: $\lam_0 = 3.7996730298 \qquad \lam_{24} = 397.14132678$ C $\alpha=5$: $\lam_0 = 4.0891593149 \qquad \lam_{24} = 588.17824969$ C As $\alpha$ increases, and for large $k$, choice of mesh at the RH C truncation point seems to become more difficult for Pruess methods C and stiffness makes initial-value methods expensive. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Finite interval singular: LPN, and LCN Friedrichs BC C Problem #18 180 TITLE = 'Bessel, order 0. -(xu'')'' = lambda x u' NPARM = 0 PARNM = ' ' go to 1000 181 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 182 P = X Q = 0D0 W = X go to 1002 183 U = A1 + A2*LOG(X) PDU = A2 go to 1003 184 U = B2 PDU = B1 go to 1004 C $\nu=0$: $\lam_0 = 5.78318596295 \qquad \lam_{19} = 3850.01252885 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #19 190 TITLE = 'Bessel, order 1/2. -(xu'')'' + 1/(4x) u = lambda x u' NPARM = 0 PARNM = ' ' go to 1000 191 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 192 P = X Q = 0.25D0/X W = X go to 1002 193 U = A1*sqrt(X) + A2/sqrt(X) PDU = 0.5D0*(A1*sqrt(X) - A2/sqrt(X)) go to 1003 194 U = B2 PDU = B1 go to 1004 C $\lam_k=((k+1)\pi)^2$, this is $-v''=\lam v$ transformed C by $v=x^{\half}u$.\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #20 200 TITLE = 'Legendre eqn. -((1-x^2)u'')'' = lambda u' NPARM = 0 PARNM = ' ' go to 1000 201 A = -1D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'LCN' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. C Set C, NU for subsequent invocation of Problem 15 C = 0D0 NU = 0D0 go to 1001 202 P = 1D0 - X**2 Q = 0D0 W = 1D0 go to 1002 203 U = A1 + A2*LOG(1-X**2) PDU = -A2*2D0*X go to 1003 C Right end is same as left end except A1 A2 become B1 B2: 204 U = B1 + B2*LOG(1-X**2) PDU = -B2*2D0*X go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $ \lambda _k =(k+1)k, k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #21 210 TITLE = 'Slightly tricky q(x). -u" -(10/x^1.5) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 211 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 212 P = 1D0 Q = -10D0/(X*SQRT(X)) W = 1D0 go to 1002 C The BC functions can be defined in terms of Bessel fns. C However the following is a more elementary way to define them. C Non-Friedrichs BC was provided by Prof Patrick Parks formerly of RMCS C then at Oxford Centre for Industrial & Applied Mathematics(OCIAM), C Oxford, UK. Sadly died Jan 1994 213 UF = X -(40D0/3D0)*X*SQRT(X) PDUF = 1D0 - 20D0*SQRT(X) UNF = LOG(X)*UF - 0.0025D0 - 0.1D0*SQRT(X) + 320.D0/9.D0*X*SQRT(X) PDUNF = LOG(X)*PDUF + 1.D0 + 40.D0*SQRT(X) - 1.D0/(20.D0*SQRT(X)) U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 214 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C With f, g being UF, UNF above: C Though f ~ const.x, g ~ const, neither 1 nor x is an admissible C function! Check-calculation: with Lu := -u''-(10/x^1.5) u we have C Lf = 40/3, Lg =(40/3)ln(x) - 3200/9 C so f, g, Lf, Lg *are* square-integrable, i.e. f, g are admissible. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #22 220 TITLE = + 'Legendre eqn, Liouville form. -u" -(1/4)sec(x)^2 u = lambda u' C but note Prob 16 can't be invoked for coeff functions C as eigenvalue is shifted by 0.25(could invoke it for BCs though) NPARM = 0 PARNM = ' ' go to 1000 221 A = -PI/2D0 B = PI/2D0 ATYPE = 'LCN' BTYPE = 'LCN' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. go to 1001 222 P = 1D0 Q = -0.25D0/(COS(X)**2) W = 1D0 go to 1002 223 U =(A1+A2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(A1+A2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) go to 1003 224 U =(B1+B2*LOG(COS(X)))*SQRT(COS(X)) PDU = -(B1+B2*(1D0+0.5D0*LOG(COS(X))))*SIN(X)/SQRT(COS(X)) go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lambda _k = k(k+1)+0.25$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #23 230 TITLE = +'Generalized hypergeom., -u"+ (-242ch x + 241)/(4sh(x)^2)u=lam u' NPARM = 0 PARNM = ' ' go to 1000 231 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 232 P = 1D0 C Q =(-242D0*COSH(X)+241D0)/(4D0*SINH(X)**2) if (X.le.1D0) then Q =(-121D0*SINH(0.5D0*X)**2 - 0.25D0) /(SINH(X)**2) else EXPMX = EXP(-X) Q =(-121D0*(1D0-EXPMX)**2-EXPMX)*EXPMX /(1D0-EXPMX**2)**2 end if W = 1D0 go to 1002 233 U = SQRT(X)*(A1+A2*LOG(X)) PDU =(A1*0.5D0+A2*(0.5D0*LOG(X)+1D0))/SQRT(X) go to 1003 234 U = B2 PDU = B1 go to 1004 C $ \lambda_k = -(5-k)^2, k=0,1,2,3,4$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #24 240 TITLE = 'Latzko equation. -((1-x^7)u'')'' = lambda x^7 u' NPARM = 0 PARNM = ' ' go to 1000 241 A = 0D0 B = 1D0 ATYPE = 'R' BTYPE = 'LCN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 242 P = 1D0 - X**7 Q = 0D0 W = X**7 go to 1002 243 U = A2 PDU = A1 go to 1003 244 U = B1 - B2*LOG(1D0-X) PDU = B2*( (((((X+1D0)*X+1D0)*X+1D0)*X+1D0)*X+1D0)*X+1D0 ) go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = 1$ \qquad LcN \qquad BC fns f=1, g=ln(1-x)\\ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lam_0 = 8.7274703526 \qquad \lam_2 = 435.06333218$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #25 250 TITLE = 'Transformed regular -(x^4 u'')'' - 2x^2 u = lambda x^4 u' NPARM = 0 PARNM = ' ' go to 1000 251 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 252 P = X**4 Q = -2D0*X**2 W = P go to 1002 253 U = A1/X + A2/(X**2) PDU = -A1*X**2 - 2D0*A2*X go to 1003 254 U = B2 PDU = B1 go to 1004 C This is -v" = lambda v transformed by v = x^2 u. C The p=x^4 may cause difficulty in choosing mesh at x=0 C $\lam_k =((k+1)\pi)^2, k=0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #26 260 TITLE = + 'Mysterious exact lam_0=7. -(x^3 u'')'' + x^3 u = lambda x^2 u' NPARM = 0 PARNM = ' ' go to 1000 261 A = 0D0 B = 1D0 ATYPE = 'LPN' BTYPE = 'R' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 262 P = X**3 Q = P W = X**2 go to 1002 263 U = A2 PDU = A1 go to 1003 264 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\lam_0 = 7.0000000000 \qquad \lam_9 = 284.53608972 $\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Infinite interval singular: LPN, and LCN Friedrichs BC C Problem #27 270 TITLE = 'Airy equation. -u" + x u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 271 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 272 P = 1D0 Q = X W = 1D0 go to 1002 273 U = A2 PDU = A1 go to 1003 274 U = B2 PDU = B1 go to 1004 C $ a = 0 $ \qquad Regular \qquad $u(a) = 0$ \\ C $ b = +\infty $ \qquad LpN C Number of eigenvalues: $\infty $ \qquad \Spc: none C Eigenvalues are the zeros of Airy function $\mbox{Ai}(\lam)= C(J_{1/3}+J_{-1/3})({2 / 3}\lam^{1/3})$.\\ C $\lam_0 = 2.3381074104 \qquad \lam_9 = 12.828776753$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #28 280 TITLE = 'Harmonic oscillator. -u" + x^2 u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 281 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 282 P = 1D0 Q = X**2 W = 1D0 go to 1002 283 U = A2 PDU = A1 go to 1003 284 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty$ \qquad \Spc: none \qquad C $\lam_k = 2k+1$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #29 290 TITLE = 'Hydrogen atom. -u" + (2/x^2 - 1/x) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 291 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 292 P = 1D0 Q = -1/X + 2/X**2 W = 1D0 go to 1002 293 U = A2 PDU = A1 go to 1003 294 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $ \qquad \Spc:(0,$\infty $) \qquad C $\lam_k = -1/(2k+4)^2$, $k = 0,1,\dots$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #30 300 TITLE = 'Coulomb potential. -u" - u/x = lambda u' NPARM = 0 PARNM = ' ' go to 1000 301 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 302 P = 1D0 Q = -1D0/X W = 1D0 go to 1002 303 U = A1*X + A2*(1D0-X*LOG(X)) PDU = A1 + A2*(-1D0-LOG(X)) go to 1003 304 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcN \\ C $b = +\infty \qquad $ LpN/O C Number of eigenvalues: $\infty $. \qquad \Spc:(0,$\infty $)\\ C $ \lam_k = -1/[4(k+1)^2]$, $k = 0,1,\ldots $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #31 310 TITLE = + 'Transformed H-atom. -(x^2 u'')'' -(l(l+1)-x) u = lambda x^2 u' NPARM = 1 PARNM = 'l(integer>=0)' go to 1000 311 A = 0D0 B = XINFTY L = PARM(1) if (L.lt.1D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = 0D0 B2 = 0D0 B1 = 1D0 go to 1001 312 P = X*X Q = L*(L+1D0) - X W = P go to 1002 C I haven't checked what happens for l that are not integer >=0 C BEWARE! 313 if (L.eq.0D0) then U = A1 + A2*(1D0/X-LOG(X)) PDU = A2*(-1D0-X) else U = A2 PDU = A1 end if go to 1003 314 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $\infty $. \qquad \Spc:(0,$\infty $)\\ C $ \lam_k = -1/[4(k+l+1)^2]$, $k = 0,1,\ldots $ C This is Hydrogen atom eqn -v" + (l(l+1)/x^2 - 1/x) v = lambda v C transformed by u = x v. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #32 320 TITLE = 'Laguerre eqn. -u" + (x^2 + (alpha-1/4)/x^2) u = lambda u' NPARM = 1 PARNM = 'alpha(=1 for standard problem)' go to 1000 321 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 322 P = 1D0 Q = X**2 + (PARM(1)-0.25)/(X**2) W = 1D0 go to 1002 323 U = A2 PDU = A1 go to 1003 324 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LpN\qquad Fried. bc: $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN \qquad Fried. bc: $u(b) = 0$ C Number of eigenvalues: $\infty C $ \qquad \Spc: none \\ C When $\alpha=1$, $ \lambda _k = 4(k+1), k = 0,1,...$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #33 330 TITLE = + 'Raman Scattering. -u" + (-7x^2 + 0.5x^3 + x^4) u = 0.5 lambda u' NPARM = 0 PARNM = ' ' go to 1000 331 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .FALSE. go to 1001 332 P = 1D0 Q = X*X*(-7D0+X*(0.5D0+X)) W = 0.5D0 go to 1002 333 U = 0D0 PDU = 1D0 go to 1003 334 U = 0D0 PDU = 1D0 go to 1004 C $a = -\infty $ \qquad LpN \\ C $b = \infty $ \qquad LpN C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = -24.5175977072 \qquad \lam_5 = 8.10470769427 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #34 340 TITLE = +'Pruess LCN/LCO border. -u"/2 -(1/(8x^2)+sech(x)^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 341 A = 0D0 B = XINFTY ATYPE = 'LCN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 342 P = 0.5D0 C Compute sech^2 x without overflow risk: EXPM2X = EXP(-2D0*ABS(X)) Q = -0.125D0/X**2 - 4D0*EXPM2X/(1D0+EXPM2X)**2 W = 1D0 go to 1002 343 U =(A1+A2*LOG(X))*SQRT(X) PDU = 0.5D0*(A1*0.5D0+A2*(0.5D0*LOG(X)+1D0))/SQRT(X) go to 1003 344 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: 1 \qquad \Spc:(0,$\infty $) \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Typical problems from chemical physics literature C Problem #35 350 TITLE = + 'Morse(1929) potential. -u" + (9e^(-x)-18e^(-2x))u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 351 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 352 P = 1D0 C Put a 'ceiling' on T hopefully to stop incautious codes C from overflowing with x<<0 C T = EXP(-X) T = EXP(min(22D0,-X)) Q = 9D0*T*(T-2D0) W = 1D0 go to 1002 353 U = A2 PDU = A1 go to 1003 354 U = B2 PDU = B1 go to 1004 C $ a = -\infty $ \qquad LpN \\ C $ b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 3 \qquad \Spc:(0,$\infty $) \qquad C $\lam_k = -0.25-(3-k)(2-k)$, $k = 0,1,2 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #36 360 TITLE = 'Morse potential, Secrest et al.(1962)' NPARM = 0 PARNM = ' ' go to 1000 361 A = 0D0 B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 362 P = 1D0 T = EXP(-1.7D0*(X-1.3D0)) Q = 2D0/(X**2) + 2000D0*T*(T-2D0) W = 1D0 go to 1002 363 U = A2 PDU = A1 go to 1003 364 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LpN \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 26 \qquad \Spc:(0,$\infty$) C $\lam_0 = -1923.529653 \qquad \lam_1 = -177.2908125 \qquad C \lambda _{13} = -473.29709743 \qquad\lam_{25} = -1.7670126867 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #37 370 TITLE = + 'Quartic anharmonic oscillator. -u" + (x^4 + x^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 371 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 372 P = 1D0 Q = X**2 + X**4 W = 1D0 go to 1002 373 U = A2 PDU = A1 go to 1003 374 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN \\ C $b = \infty $ \qquad LpN \\ C Number of eigenvalues: $\infty $ \qquad \Spc: none C $\lam_0 = 1.3923516415 \qquad \lam_9 = 46.965069501 $ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #38 380 TITLE = 'Close-evs problem -u" + (x^4-25x^2) u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 381 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPN' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 382 P = 1D0 Q =(X**2-25D0)*X**2 W = 1D0 go to 1002 383 U = A2 PDU = A1 go to 1003 384 U = B2 PDU = B1 go to 1004 C $a = -\infty $ \qquad LpN \qquad Fried. bc: $u(a)= 0$ \\ C $b = +\infty $ \qquad LpN \qquad Fried. bc: $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none\\ C $ \lambda _0 = -149.2194561 \qquad \lambda _1 = -149.2194561 \qquad C \lambda {_40} = 75.69072485$\\ C Double-well version of quartic anharmonic oscillator. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #39 390 TITLE = + 'Morse(Marletta). -u" + 8000[e^(-3x) - 2e^(-3x/2)] u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 391 A = -XINFTY B = XINFTY ATYPE = 'LPN' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 392 P = 1D0 T = EXP(-1.5D0*X) Q = 8D3*T*(T-2D0) W = 1D0 go to 1002 393 U = A2 PDU = A1 go to 1003 394 U = B2 PDU = B1 go to 1004 C $ a = -\infty $ \qquad LpN \\ C $ b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 60 \qquad \Spc:(0,$\infty $) C With this deep well a large truncated interval seems to be C needed to give good approximations to higher \ev s. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #40 400 TITLE = 'Wicke and Harris(1976), spike at bottom of well' NPARM = 0 PARNM = ' ' go to 1000 401 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 402 P = 1D0 Q = 1250D0*EXP(-83.363D0*(X-2.47826D0)**2) + + 3906.25D0*(1D0-EXP(2.3237D0-X))**2 W = 1D0 go to 1002 403 U = A2 PDU = A1 go to 1003 404 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad regular \qquad $u(a) = 0$ \\ C $b = +\infty $\qquad LpN/O \\ C Number of eigenvalues: 62 \qquad \Spc:(3906.25,$\infty$)\\ C $ \lambda _0 = 163.2238021 \qquad \lambda _9 = 1277.536963 $\\ C This has a spike at the bottom of the well: whether this causes any C trouble to automatic codes is doubtful. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #41 410 TITLE = 'Woods-Saxon potential(Vanden Berghe et al. 1989).' NPARM = 1 PARNM = 'l(>=0)' go to 1000 411 A = 0D0 B = XINFTY L = PARM(1) LLP1 = L*(L+1D0) if (L.eq.0.D0) then ATYPE = 'R' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 412 P = 1D0 C T is the reciprocal of t as given in SL Book T = EXP(-(X-7D0)/0.6D0) Q = LLP1/(X*X) - 50D0*T/(T+1D0)*(1D0-(5D0/3D0)/(T+1D0)) W = 1D0 go to 1002 413 U = A2 PDU = A1 go to 1003 414 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular($l=0$), LpN($l=1$) \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LpN/O \\ C($l=0$):\\ C Number of eigenvalues: 14 \qquad \Spc:(0,$\infty $) \\ C $ \lambda _0 = -49.457788728 \qquad \lambda _{10} = -18.094688282$ \\ C($l=1$):\\ C Number of eigenvalues: 13 \qquad \Spc:(0,$\infty $) \\ C $ \lambda _0 = -48.349481052 \qquad \lambda _{10} = -13.522303353$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #42 420 TITLE = 'Another model potential(Vanden Berghe et al. 1989).' NPARM = 1 PARNM = 'l' go to 1000 421 A = 0D0 B = XINFTY L = PARM(1) if (L.eq.0D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 422 P = 1D0 Q = L*(L+1D0)/X**2 + (-1D0+5D0*EXP(-2D0*X))/X W = 1D0 go to 1002 423 if (L.eq.0D0) then U = A1*X + A2*(1D0+4D0*X*LOG(X)) PDU = A1 + A2*(4D0*LOG(X)+4D0) else U = A2 PDU = A1 end if go to 1003 424 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad LcN($l=0$), LpN($l=1$) \qquad Fried. bc: $u(a)=0$\\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: $\infty $ \qquad \Spc:(0,$\infty $) \\ C($l=0$):\\ C $\lambda_0=-0.156358880971 \qquad \lambda _2 = -0.023484895664$\\ C($l=0$):\\ C $ \lambda _0 = -0.061681846633 \qquad \lambda _2 = -0.015501561691$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Borderline Problems C Problem #43 430 TITLE = 'Bessel, LCN/LCO border. -u" + ((alpha-1/4)/x^2)u = lam u' NPARM = 1 PARNM = 'alpha, say in range -0.1 to 0.1' go to 1000 C This is just Problem 13 so code is an exact copy (apart from labels) 431 NUSQ = PARM(1) A = 0D0 B = 1D0 C settng NU for NUSQ < 0(as well as >= 0) is useful for LCO case: NU = SQRT(ABS(NUSQ)) if (NUSQ.ge.1D0) then ATYPE = 'LPN' C special case which doesn't occur in the non-normal form else if (NUSQ.eq.0.25D0) then ATYPE = 'R' else if (NUSQ.ge.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if C In all cases take: A2 = 0D0 A1 = 1D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 C Remaining bits assume NUSQ & NU have been set: 432 P = 1D0 Q =(NUSQ-0.25D0)/(X*X) W = 1D0 go to 1002 C BCs handle all cases: 433 if (NUSQ.ge.1D0) then C LPN case U = A2 PDU = A1 else if (NUSQ.eq.0.25D0) then C Regular case U = A1*X + A2 PDU = A1 else if (NUSQ.ge.0D0) then C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(0.5D0+NU) UNF = X**(0.5D0-NU) PDUF =(0.5D0+NU)*UF/X PDUNF =(0.5D0-NU)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF else C LCO case, BC function RealPart(x**(1/2+i*nu)(a1-i*a2)) TEMP = NU*LOG(X) U =(A1*COS(TEMP)+A2*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A1+NU*A2)*COS(TEMP)-(NU*A1-0.5D0*A2)*SIN(TEMP))/ + SQRT(X) end if go to 1003 434 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcN $(0\leq\alpha<0.25)$, LcO $(\alpha<0)$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty\quad(\alpha\geq0)$, C $\pm\infty\quad(\alpha<0)$, \qquad \Spc: none \qquad C $\alpha=0.01$: $\lambda_0=6.540555712 \qquad\lam_{24}=6070.441468$\\ C $\alpha=0$: $\lambda_0=5.78318596295 \qquad\lam_{24}=6045.999522$\\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #44 440 TITLE = 'Border of LPN and LCN. -u" + x^(alpha-2) u = lambda u' NPARM = 1 PARNM = 'alpha(near 0)' go to 1000 441 A = 0.D0 B = 1.D0 ALPHA = PARM(1) if (ALPHA.gt.0D0) then ATYPE = 'LCN' else ATYPE = 'LPN' end if BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 442 P = 1D0 Q = X**(ALPHA-2D0) W = 1D0 go to 1002 C The BC function in the book is in terms of Bessel fns. C This one is wrong: only the 1st 2 terms of a series that needs C more & more as alpha decreases to 0 443 if (ALPHA.gt.0D0) then UF = X*(1D0 + X**ALPHA/(ALPHA*(1D0+ALPHA))) PDUF = 1D0+X**ALPHA/ALPHA UNF =(1D0 + X**ALPHA/(ALPHA*(ALPHA-1D0))) PDUNF = X**(ALPHA-1D0)/ALPHA U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF else U = 0D0 PDU = 1D0 end if go to 1003 444 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Changes from LcN to LpN as $\alpha$ decreases thru $-2$ C \qquad Fried. bc: $u(a) = 0$ \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\infty $ \qquad \Spc: none \qquad C $\alpha=-1.99$: $\lam_0=15.87305674 \qquad \lam_{24} = 6316.899940$\\ C $\alpha=-2.01$: $\lam_0=15.96808975 \qquad \lam_{24} = 6325.038047$ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #45 450 TITLE = 'Border of LCN and LCO. -u" - x^(alpha-2) u = lambda u' NPARM = 1 PARNM = 'alpha(near 0)' go to 1000 451 A = 0D0 B = 1D0 ALPHA = PARM(1) if (ALPHA.gt.0D0) then ATYPE = 'LCN' else ATYPE = 'LCO' end if BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 452 P = 1D0 Q = -X**(ALPHA-2D0) W = 1D0 go to 1002 C I'm not too sure of this one(JDP): C It should be analysed in same way as #44 453 if (ALPHA.gt.0D0) then U = A1*(X-X**(1D0+ALPHA)/(ALPHA*(1D0+ALPHA))) + A2*0D0 PDU = A1*(1D0-X**ALPHA/ALPHA) + A2*0D0 else if (ALPHA.eq.0D0) then U = A1*(SIN(SQRT(0.75)*LOG(X))*SQRT(X)) + A2*0D0 PDU = A1*(SIN(SQRT(0.75)*LOG(X)+PI/6D0)/SQRT(X)) + A2*0D0 else write(*,FMT=*) 'Problem',IPROB,': LCO BCs not implemented yet' stop end if go to 1003 454 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad Changes from LcN to LcO as $\alpha$ decreases thru $0$ C \\ C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none\\ C $\alpha=-1.9$: $\lam_0 = -6152??. \qquad\lam_2 = 11.38??$\\ C $\alpha=-2.01$: requires LcO BC at $x=0$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Singular problems: LCN, Non-Friedrichs BC C Problem #46 460 TITLE = +'Bessel normal form, nonFried. BC, ref. Bailey Everitt Zettl 1991' NPARM = 0 PARNM = ' ' go to 1000 C This is just Problem 13 with \nu=3/4 461 NU = 0.75D0 A = 0D0 B = 1D0 ATYPE = 'LCN' C But with non-default left-hand BC defined by g=x^(-\nu+1/2): A2 = 1D0 A1 = 0D0 BTYPE = 'R' SYM = .FALSE. B2 = 0D0 B1 = 1D0 go to 1001 462 P = 1D0 Q =(5D0/16D0)/(X*X) W = 1D0 go to 1002 463 continue C LCN case, Fried. BC function=x**(1/2+nu), other=x**(1/2-nu) UF = X**(1.25D0) UNF = X**(-0.25D0) PDUF =(1.25D0)*UF/X PDUNF =(-0.25D0)*UNF/X U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 464 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #47 470 TITLE = +'NonFriedrichs, Pryce/Marletta. -(xu'')''+(b/x)^2 u = lam x^(2b)u' NPARM = 1 PARNM = 'b(>0)' go to 1000 471 A = 0D0 B = 1D0 ATYPE = 'LCN' BTYPE = 'R' SYM = .FALSE. BETA = PARM(1) A2 = 1.D0 A1 = 0.D0 B2 = 1.D0 B1 = -BETA go to 1001 472 P = X Q = BETA**2/X W = X**(2D0*BETA) go to 1002 473 U = A1*X**(BETA) + A2/X**(BETA) PDU = BETA*(A1*X**(BETA)-A2/X**(BETA)) go to 1003 474 U = B2 PDU = B1 go to 1004 C $a=0$ \qquad LcN \qquad non-Fried. bc: $[x^{-\beta},u](a)=0$\\ C $b=1$ \qquad regular \qquad $u'(b)=-\beta u(b)$\\ C $\lam_0=0$ for all $\beta$. For $\beta>14$(approx.) this appears C to cause severe problems to all codes, see \scref{sngexpts}. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #48 480 TITLE = 'Spectral density fn. example. Ref: Pruess/Fulton 75' NPARM = 0 PARNM = ' ' go to 1000 481 A = 0D0 B = 1D0 ATYPE = 'LPNO' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 482 P = X**4 Q = 0D0 W = X**2 go to 1002 483 U = A2 PDU = A1 go to 1003 484 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: 0 \qquad \Spc:(2.25,$\infty $) \\ C Spectral density $\rho(t) = {2\over 3\pi}(t-2.25)^{1.5}$ C The Frobenius index at 0 depends on lambda, and the p=x^4 can C cause meshing problems. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Singular problems: LCO C Problem #49 490 TITLE = + 'Modified Bessel(Bessel of order nu=i/2). Ref: Pruess/Fulton 33' NPARM = 0 PARNM = ' ' go to 1000 491 A = 0D0 B = 1D0 ATYPE = 'LCO' BTYPE = 'R' SYM = .FALSE. A1 = 1D0 A2 = 0D0 B1 = 1D0 B2 = 0D0 go to 1001 492 P = X Q = -1/(4D0*X) W = X go to 1002 493 TEMP = 0.5D0*LOG(X) U = A1*SIN(TEMP) + A2*COS(TEMP) PDU = 0.5D0*(A1*COS(TEMP)-A2*SIN(TEMP)) go to 1003 494 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcO \\ C $b = 1$ \qquad Regular \qquad $u(b) = 0$ C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none \\ C General BC at 0 is $[x^{1/2}\sin(\half\ln x+\gamma),u](0)=0$ where C$\gamma$ is constant. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #50 500 TITLE = +'Weierstrass-Mandelbrot. -u" + (c-(omega^2+.25)/x^2) u = lambda u' NPARM = 2 PARNM = +'omega >0 & offset c; c>0 vital for SLEIGN2 to find lambda_0' go to 1000 501 OMEGA = PARM(1) A = 0D0 B = XINFTY ATYPE = 'LCO' BTYPE = 'LPNO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 502 P = 1D0 Q = PARM(2)-(OMEGA**2+0.25D0)/X**2 W = 1D0 go to 1002 503 TEMP = OMEGA*LOG(X) U =(A2*COS(TEMP)+A1*SIN(TEMP))*SQRT(X) PDU =((0.5D0*A2+OMEGA*A1)*COS(TEMP) - + (OMEGA*A2-0.5D0*A1)*SIN(TEMP))/SQRT(X) go to 1003 504 U = B2 PDU = B1 go to 1004 C Number of eigenvalues: $+-\infty$ \qquad \Spc:(0,$\infty $) \qquad C BC functions f=x^(1/2) sin(omega ln(x) + gamma), gamma arbitrary C For c=0 & any gamma the evs are a 2-sided infinite geometric C progression with common ratio exp(2 pi/omega). C For ratio=10 take omega = 2.72875270768368 C For ratio=2 take omega = 9.06472028365439 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #51 510 TITLE = 'Titchmarsh problem. -u" - e^x u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 511 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LCO' A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .FALSE. go to 1001 512 P = 1D0 Q = -EXP(X) W = 1D0 go to 1002 513 U = A2 PDU = A1 go to 1003 514 TEMP = 2D0*EXP(0.5D0*X) U = EXP(-0.25D0*X)*(B1*SIN(TEMP)+B2*COS(TEMP)) PDU = -0.5D0*U + 2D0*EXP(0.25D0*X)*(B1*COS(TEMP)-B2*SIN(TEMP)) go to 1004 C $a = 0$ \qquad Regular \qquad $u(a) = 0$ \\ C $b = +\infty $ \qquad LcO C Number of eigenvalues: $\pm \infty $ \qquad \Spc: none \\ C General BC at $\infty$ is of form $[f,u](\infty)=0$ where C $f=e^{-x/4}\sin(2e^{x/2} + \gamma)$, which is an exact solution of C the DE with $\lam=-1/16$ for any value of the constant $\gamma$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #52 520 TITLE = + 'Limit-circle osc with cont spectrum. -u" -1/x^3 u = lambda u' NPARM = 0 PARNM = ' ' go to 1000 521 A = 0D0 B = XINFTY ATYPE = 'LCO' BTYPE = 'LPNO' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 522 P = 1D0 Q = -1D0/X**3 W = 1D0 go to 1002 523 continue C This needed JWKB expansion up to R_3 term (JDP book p41) C to get approximations u,v s.t. Lu,Lv are square integrable. R = X**0.75D0*exp((3D0/64D0)*X) THETA = 2D0/sqrt(X) + (3D0/16D0)*sqrt(X) C = 0.75D0/X + 3D0/64D0 D = (-1D0/X + (3D0/32D0))/sqrt(X) UF = R*cos(THETA) UNF = R*sin(THETA) PDUF = C*UF-D*UNF PDUNF = D*UF+C*UNF U = A1*UF + A2*UNF PDU = A1*PDUF + A2*PDUNF go to 1003 524 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad LcO, BC functions x^{0.5) Z(2x^{-1/2}) C where Z is a combination of Bessel fns J1 and Y1.\\ C Elementary BC functions from real, imaginary parts of $w$ where C \[w'/w = -ix^{-3/2} + {3\over4}x^{-1} + i{3\over32}x^{-1/2} C + {3\over64}x^0 \] C obtained by terms up to $R_3$ in JWKB expansion (book p41). C $b = +\infty $ \qquad LpN/O \\ C \Spc:(0,$\infty $) \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problems with discontinuous coefficients C Problem #53 530 TITLE = 'Approximate harmonic oscillator, Pryce 1993' NPARM = 1 PARNM = + 'b (reg BCs u(-b)=u(b)=0 are used, b>=10^35 taken as Infinity)' go to 1000 531 B = MIN(PARM(1),XINFTY) A = -B if (B.lt.XINFTY) then ATYPE = 'R' BTYPE = 'R' else ATYPE = 'LPN' BTYPE = 'LPN' end if A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 SYM = .TRUE. go to 1001 532 P = 1D0 T = ABS(X) N = FLOAT(INT(T)) Q = N*N + (2*N+1)*(T-N) W = 1D0 go to 1002 533 U = A2 PDU = A1 go to 1003 534 U = B2 PDU = B1 go to 1004 C q is piecewise linear function joining the points(x,x^2) for x an C integer. Codes seem to find automatic endpoint analysis hard, C hence the PARM which allows one to set finite regular endpoints C at which u=0 is imposed. C Number of eigenvalues: $\infty $ \qquad \Spc: none \\ C $\lambda_0=.3456792711$, $\lambda_9=18.079846195$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Extensions to the classical SLP C Problem #54 540 TITLE = 'Indefinite weight function, Marletta PhD 1991' NPARM = 0 PARNM = ' ' go to 1000 541 A = 0D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 542 P = 1D0 Q = 1D0 if (X.le.0.5D0) then W = 0D0 else W = 1D0 end if go to 1002 543 U = A2 PDU = A1 go to 1003 544 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)=0$\\ C $b = 1$ \qquad Regular \qquad $u(b)=0$\\ C Number of eigenvalues: $\infty $. C $\lam_k=\mu_k^2+1$ where $\mu_k$ are roots of C $\tan{\mu\over2}+\mu\tanh\half=0$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #55 550 TITLE = 'Indefinite weight fn, Bailey et al. ACM TOMS 1978' NPARM = 0 PARNM = ' ' go to 1000 551 A = -1D0 B = 1D0 ATYPE = 'R' BTYPE = 'R' SYM = .FALSE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 552 P = EXP(-X**2) Q = P W = -2D0*X*P go to 1002 553 U = A2 PDU = A1 go to 1003 554 U = B2 PDU = B1 go to 1004 C $a = -1$ \qquad Regular \qquad $u(a)=0$\\ C $b = 1$ \qquad Regular \qquad $u(b)=0$\\ C Number of eigenvalues: $\pm\infty $. C The conversion to self-adjoint form of the problem C u'' - x u' -(1+2\lambda x) u = 0, u(-1)=u(1)=0 C $\lambda_5=250.974149734$. C By the antisymmetry, if lambda is an eigenvalue so is -lambda. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #56 560 TITLE = 'lambda-dependent BC at x=a, Fulton/Pruess 1992' NPARM = 4 PARNM = 'A1 A2 A1'' A2'' in SLEDGE-style BCs'// *', 1 0 0 1 for prob. in book' go to 1000 561 A = 1D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. C The BC at x=a is not adjustable so A1, A2 not set: B2 = 0D0 B1 = 1D0 go to 1001 562 P = 1D0 Q = -0.25D0/X**2 W = 1D0 go to 1002 563 U = PARM(1)-EIG*PARM(3) PDU = PARM(2)-EIG*PARM(4) go to 1003 564 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $\lambda u(a) -(pu')(a) = 0$\\ C $b = \infty$ \qquad LPN/O\\ C Number of eigenvalues: $1$ \qquad \Spc: $(0,\infty)$ \\ C $\lambda_0=-0.02229899486$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #57 570 TITLE = + 'lambda-dependent BC at x=a, Fulton/Pruess private comm. 1992' NPARM = 4 PARNM = 'A1 A2 A1'' A2'' in SLEDGE-style BCs'// *', 1 0 0 1 for prob. in book' go to 1000 571 A = 1D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. C The BC at x=a is not adjustable so A1, A2 not set: B2 = 0D0 B1 = 1D0 go to 1001 572 P = 1D0 Q = -1D0/X W = 1D0 go to 1002 573 U = PARM(1)-EIG*PARM(3) PDU = PARM(2)-EIG*PARM(4) go to 1003 574 U = B2 PDU = B1 go to 1004 C $a = 1$ \qquad Regular \qquad $\lambda u(a) -(pu')(a) = 0$\\ C $b = \infty$ \qquad LPN/O\\ C Number of eigenvalues: $\infty$ \qquad \Spc: $(0,\infty)$ \\ C $\lambda_0=-0.30017359365$ \qquad $\lambda_9=-0.0025669706$. C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #58 580 TITLE = 'Rossby wave equation, Drazin et al. J Fluid Mech 1982' NPARM = 2 NEPRM = 2 PARNM = 'alpha, c' go to 1000 581 A = -PI B = PI ATYPE = 'R' BTYPE = 'R' SYM = .TRUE. A2 = 0D0 A1 = 1D0 B2 = 0D0 B1 = 1D0 go to 1001 C This problem is quite far from the classical SLP and one cannot C classify it for SLEIGN (q finite at a or b, etc) in a simple way. C In the following section: C BETA is beta, the standard 'linear' eigenparameter. C VEL is called U(x) in the cited paper. C To provide an interface for problems nonlinear in parameters, C for a NAG D02KEF-style solver, if IPARM>0, C writing QQ=beta*w-q, we compute WW=partial d(QQ)/d(alpha), C WW = partial d(QQ)/d(c) according as IPARM is 1 or 2 C and return QQ, WW in variables Q and W. 582 BETA = PARM(0) ALPHA = PARM(1) C = PARM(2) VEL =(X/B)**2 P = 1D0 Q = ALPHA**2 + VEL/(VEL-C) W = 1D0/(VEL-C) if (IPARM .ne. 0) then Q = BETA*W - Q if (IPARM .eq. 1) then W = -2D0*ALPHA else if (IPARM .eq. 2) then W =(BETA-VEL)/(VEL-C)**2 end if end if go to 1002 583 U = A2 PDU = A1 go to 1003 584 U = B2 PDU = B1 go to 1004 C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problems contrived to show special features C Problem #59 590 TITLE = 'Ref Gelfand & Levitan, AMS Translations 1955.' NPARM = 0 PARNM = ' ' go to 1000 591 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = 1D0 A1 = -1D0 B2 = 0D0 B1 = 1D0 go to 1001 592 P = 1D0 T = 1D0 + X/2D0 + SIN(2D0*X)/4D0 Q = 2D0*(T*SIN(2D0*X)+COS(X)**4)/T**2 W = 1D0 go to 1002 593 U = A2 PDU = A1 go to 1003 594 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $u(a)+ (pu')(a) = 0$ \\ C $b = \infty$ \qquad LPN/O \\ C Number of(isolated) eigenvalues: none \qquad \Spc: $(0,\infty)$ \\ C There is an eigenvalue at $\lambda=1$ in the \Spc. \\ C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C Problem #60 600 TITLE = + 'Problem with pseudo-eigenvalue, Pryce 1989, ref Marletta PhD 91' NPARM = 0 PARNM = ' ' go to 1000 601 A = 0D0 B = XINFTY ATYPE = 'R' BTYPE = 'LPNO' SYM = .FALSE. A2 = -8D0 A1 = 5D0 B2 = 0D0 B1 = 1D0 go to 1001 602 P = 1D0 Q =(3D0*(X-31D0))/(4D0*(1D0+X)*(4D0+X)**2) W = 1D0 go to 1002 603 U = A2 PDU = A1 go to 1003 604 U = B2 PDU = B1 go to 1004 C $a = 0$ \qquad Regular \qquad $5u(a)+8(pu')(a) = 0$ \\ C $b = +\infty $ \qquad LpN/O \\ C Number of eigenvalues: 1 \qquad \Spc:(0,$\infty $) \qquad C $\lam_0 = -1.185214105$\\ C There is a solution for $\lam=0$ satisfying the BC at 0 and converging C to 0 at $\infty$. However it is not square-integrable, so $0$ is not C an eigenvalue. C***+****|****+****| END OF PROBLEM SET |****+****|****+****|** 1000 continue 1001 continue 1002 continue 1003 continue 1004 continue end subroutine TSTSET C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine ABINFO(P0ATA,QFATA,P0ATB,QFATB) C This routine is used only by SLEIGN & SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE STANDARD TEST SET ONLY ************ implicit none integer NPROB parameter(NPROB=60) C .. Scalar Arguments .. double precision P0ATA,QFATA,P0ATB,QFATB C .. Local Arrays .. integer P0A(1:NPROB),QFA(1:NPROB),P0B(1:NPROB),QFB(1:NPROB) data P0A/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, 1, 0, 0, 1, 1, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ data QFA/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 1, 1, 1, 0, 1, 1, 1, 0, 1, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1/ data P0B/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ data QFB/ C 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0, 1, 1, 1, C 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 + 1, 0, 1, 1, 1, 1, 0, 0, 1, 1, 0, 0, 0, 1, 1, 1, 0, 0, 1, 1, C 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 1, 0, 1, 1, 1, 1, 1, 1, 1/ C***+****|****+****|**** Special Cases Section **|****+****|****+****|** C in several problems this info depends on values of parameters so: goto(999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 999, 120, 130, 999, 150, 160, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999, + 410, 999, 430, 440, 450, 999, 999, 999, 999, 999, + 999, 999, 999, 999, 999, 999, 999, 999, 999, 999) + IPROB C Problem #12, Bessel: q finite at 0 if nusq=0 120 if (PARM(1).eq.0D0) QFATA=1 go to 999 C Problem #13, Bessel LNF: q finite at 0 if nusq=1/4 130 if (PARM(1).eq.0.25D0) QFATA=1 go to 999 C Problem #15, Assoc Legendre: q finite at -1, +1 if c=0 150 if (PARM(1).eq.0D0) then QFATA=1 QFATB=1 end if go to 999 C Problem #16, Assoc Legendre LNF: q finite at -1, +1 if c=1/4 160 if (PARM(1).eq.0.25D0) then QFATA=1 QFATB=1 end if go to 999 C Problem #41, Woods-Saxon: q finite if l = -1 or 0 410 if (PARM(1).eq.-1D0 .or. PARM(1).eq.0D0) QFATA=1 go to 999 C Problem #43, `borderline 1', is a copy of Prob 13 430 if (PARM(1).eq.0.25D0) QFATA=1 go to 999 C Problem #44, `borderline 2': q finite at 0 iff alpha>=2 440 QFATA = 0 if (PARM(1).ge.2D0) QFATA=1 go to 999 C Problem #45, `borderline 3': q behaves like #44 450 QFATA = 0 if (PARM(1).ge.2D0) QFATA=1 go to 999 C***+****|****+****|**** End of Special Cases **|****+****|****+****|** 999 continue P0ATA = 2*P0A(IPROB) - 1 QFATA = 2*QFA(IPROB) - 1 P0ATB = 2*P0B(IPROB) - 1 QFATB = 2*QFB(IPROB) - 1 end subroutine ABINFO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine GTHUHV(IEND,XA,UA,VA,HU,HV) C This routine is used only by SLEIGN2. C Its functionality should be incorporated into TSTSET eventually. C******* THIS ROUTINE APPLIES TO THE STANDARD TEST SET ONLY ************ implicit none integer IEND double precision XA,UA,VA,HU,HV double precision AA,BB,ALPHA,NU,OM,OMSQ,TEMP C Returns the HU,HV info needed by SLEIGN2 as part of its UV routine. C (May be included in main TSTSET eventually) C Kluge, to set valid fl.pt. values: SLEIGN2 does funny things.. HU = 0D0 HV = 0D0 if (ATYPE(1:2).eq.'LC' .or. BTYPE(1:2).eq.'LC') then go to(10,10,10,10,10,10,10,10,10, 10, 10,120,130, 10,150,160, + 10,180,190,200,210,220,230,240,250, 10, 10, 10, 10,300, + 310, 10, 10,340, 10, 10, 10, 10, 10, 10, 10,420, 10,440, + 450,460,470, 10,490,500,510,520, 10, 10, 10, 10, 10, 10, + 10, 10) IPROB else C If neither endpoint is LC, UV is not needed so do nothing return end if 10 write(*,*) 'Error in UV, Problem',IPROB,' has LC endpoint but', + ' no HU,HV info implemented for it' stop 120 if (IEND.eq.0) then C Whatever the value of PARM(1)=NU**2: HU = 0D0 HV = 0D0 end if go to 1000 130 if (IEND.eq.0) then C Whatever the value of PARM(1)=NU**2: HU = 0D0 HV = 0D0 end if go to 1000 150 continue C Whether IEND is 0 or 1: if (PARM(1).ge.0D0) then NU = sqrt(PARM(1)) HU =(NU*NU+NU)*UA HV =(NU*NU-NU)*VA else C Here UA,VA are Re,Im of(1-x*x)**{i*omega}, nu=i*omega OMSQ = PARM(1) OM = sqrt(-OMSQ) HU = OMSQ*UA-OM*VA HV = OMSQ*VA+OM*UA end if go to 1000 160 continue C Whatever the value of PARM(1)=NU**2 and at both ends: HU = 0D0 HV = 0D0 go to 1000 180 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 190 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 200 continue C At both ends: HU = 0D0 HV = 0D0 go to 1000 210 continue C for truncated series BC functions(see TSTSET) not the Bessel ones HU = 400D0/3D0 HV = HU*log(XA) - 3200D0/9D0 go to 1000 220 continue C At both ends: HU = 0D0 HV = 0D0 go to 1000 230 continue print*,'UV: Prob 23 not implemented yet, program terminated' stop go to 1000 240 if (IEND.eq.1) then HU = 0D0 HV = - (1D0+XA*(2D0+XA*(3D0+XA*(4D0+XA*(5D0+XA*6D0)))) ) end if go to 1000 250 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 300 if (IEND.eq.0) then HU = -1D0 HV = log(XA) end if go to 1000 310 if (IEND.eq.0) then HU = -XA HV = log(XA) print*,'UV: Prob 31 Warning, only valid for l=0' end if go to 1000 340 if (IEND.eq.0) then C Probably no need to worry about overflow in cosh x here: HU = -sqrt(XA)/(cosh(XA)**2) HV = HU*log(XA) end if go to 1000 420 if (IEND.eq.0) then HU = 5D0*exp(-2D0*XA) - 1D0 if (abs(XA).le.1D-4) then TEMP = -2D0+2D0*XA-(4D0/3D0)*XA*XA+ (2D0/3D0)*XA*XA*XA else TEMP = 5D0*(exp(-2D0*XA)-1D0)/XA end if HV = TEMP + (5D0*exp(-2D0*XA)-1D0)*4D0*log(XA) print*,'UV: Prob 42 Warning, only valid for l=0' end if go to 1000 440 if (IEND.eq.0) then print*,'UV: Prob 44, BC fns are known NOT to be correct!' ALPHA = PARM(1) HU = XA**(2D0*ALPHA-1D0)/((ALPHA+1D0)*ALPHA) HV = XA**(2D0*ALPHA-2D0)/(ALPHA*(ALPHA-1D0)) end if go to 1000 450 if (IEND.eq.0) then print*,'UV: Prob 45, BC fns are known NOT to be correct!' ALPHA = PARM(1) C this is false! HU = 0D0 HV = 0D0 end if go to 1000 460 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 470 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 490 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 500 if (IEND.eq.0) then HU = 0D0 HV = 0D0 end if go to 1000 510 if (IEND.eq.1) then HU = UA/(-16D0) HV = VA/(-16D0) end if go to 1000 520 if (IEND.eq.0) then AA = (63D0/1024D0)/XA + 9D0/4096D0 BB = (9D0/1024D0)/sqrt(XA) HU = AA*UA - BB*VA HV = AA*VA + BB*UA end if go to 1000 1000 end subroutine GTHUHV end module TESTMOD SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'sldriver' then mkdir 'sldriver' fi cd 'sldriver' if test -f 'batchio.f' then echo shar: will not over-write existing file "'batchio.f'" else cat << SHAR_EOF > 'batchio.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C BATCHIO is a module with the same name, SAFEIO, and interface as the C interactive SAFEIO package, but intended for use when running a C program non-interactively. Differences: C 1. SPAUSE doesn't wait for ENTER to be pressed but waits 1 second C 2. 'ERR=' on input leads to a STOP. C 3. They echo their input to the screen. C The result is that the screen output in batch mode (using < to C read data from a file) should be identical to that produced by C running interactively, if the data has no errors! module SAFEIO contains C***+****|****+****|**SAFEIO package***|****+****|****+****|****+****|** C Simple 'secure, abortable interactive input' routines C C The following are logical functions which return values through C the argument list and also C either C .TRUE. through the function name meaning 'successful input' C and the input value(s) through its (first) argument C or C .FALSE. through the function name meaning 'aborted by user' C The routines are C GETI(X) - get one Integer value X C GETR(X) - get one Real value X C GETIR(X,XLO,XHI) - get one Integer value X in a Range C GETRR(X,XLO,XHI) - get one Real value X in a Range C GETIS(X,NX) - get NX integer values into array X C GETRS(X,NX) - get NX real values into array X C C The user is to signal 'abort' by typing z or Z (followed by Enter) C C The following is a non-abortable routine requiring a yes/no answer C YESNO() - character*1 function, returns either 'y' or 'n' C The following non-abortable routine waits for ENTER to be pressed C SPAUSE() C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine OPNPBK C Dummy routine end subroutine OPNPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine CLOPBK C Dummy routine end subroutine CLOPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETI(X) implicit none C .. Scalar Arguments .. integer X character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETI = .FALSE. return else read (LINE,FMT=*,ERR=30) X GETI = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop end if end function GETI C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETR(X) implicit none C .. Scalar Arguments .. double precision X character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETR = .FALSE. return else read (LINE,FMT=*,ERR=30) X GETR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Real value required, please retype: '')') stop end if end function GETR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIR(X,XLO,XHI) implicit none C .. Scalar Arguments .. integer X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIR = .FALSE. return else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETIR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') stop end if end function GETIR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRR(X,XLO,XHI) implicit none C .. Scalar Arguments .. double precision X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRR = .FALSE. return else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETRR = .TRUE. return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') stop 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') stop end if end function GETRR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. integer X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIS = .FALSE. return else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETIS = .TRUE. return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Integer values required, please retype from item',i2,': ') stop end if end function GETIS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. double precision X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)') LINE call PRTRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRS = .FALSE. return else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETRS = .TRUE. return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Real values required, please retype from item',i2,': ') stop end if end function GETRS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*1 function YESNO(ASK) implicit none character*(*) ASK C .. Local Scalars .. character YN C .. write(*,'(a)',advance='NO') ASK 10 read (*,FMT='(a)',END=40,ERR=30) YN write (*,'(a)') YN if (YN.eq.'y' .or. YN.eq.'Y') then YESNO = 'y' else if (YN.eq.'n' .or. YN.eq.'N') then YESNO = 'n' else go to 30 end if return 30 write (*,ADVANCE='NO', + FMT='(1x,''***Please type one of y,Y,n,N: '')') stop 40 write (*,*) 'Don''t use end-of-file,', + ' it means end of run in most F90 & some F77 systems' write (*,*) 'Sorry!' stop end function YESNO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SPAUSE double precision DELAY integer CTRL_C parameter (DELAY=1d0, CTRL_C=3) integer ICURR,IRATE,ISTART integer(kind=2) K write (*,FMT='(a)') 'Press ENTER to continue' C read (*,FMT=*,END=100,ERR=100) call SYSTEM_CLOCK(ISTART,IRATE) 50 continue !C start of Salford FTN90-specific code !C Salford FTN90 routine to check if key has been pressed ! call GET_KEY1@(K) ! if (K.eq.CTRL_C) then ! print*,'User-requested Break' ! stop ! end if !C end of Salford FTN90-specific code call SYSTEM_CLOCK(ICURR,IRATE) if (dble(ICURR-ISTART)/dble(IRATE) 'dbmod.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module DBMOD use SLCONSTS use SLPSET use SAFEIO use SLUTIL implicit none C Unit for reading data files: integer, parameter:: INFIL=18 C***+****|****+****|****+ GENERAL DESCRIPTION ***|****+****|****+****|** C DBMOD contains the routines C DBINIT C EVCHK C EFCHK C SDCHK C UPEVTR C UPEFTR C UPSDTR C UPXMUN C UPLMUN C GTXMTR C GTXMUN C GTLMTR C GTLMUN C EVSCAN C EVDAT C EFSCAN C EFDAT C SDSCAN C SDDAT C & debugging routine C DBSUMM C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** C DBMOD handles 3 data objects that are read from an external file of C "true" data values and 'cached' within the program: C Name of | C object |Contents C --------+-------------------------------------------------------------- C 'EVTRUE'|A set of "true" e-vs of a given problem: abstractly, a vector C |of k-values and a corresponding vector of lambda(k), and of C |believed errors in the lambda(k), where the C |k's are a subset of the current range KLO,KHI. C | C 'EFTRUE'|An x-mesh (x(i), i=1, ..., n) plus a set of "true" e-fns of a C |given problem: abstractly, a matrix with rows labelled by k C |values, and columns by i which indexes the x(i). The k,i C |position holds u(x(i)) and pu'(x(i)) for the k-th e-fn. Again C |the k's are a subset of the current range KLO,KHI. They need C |have no relation to the k's of any "true" e-vs for the same C |problem. C | C 'SDTRUE'|A lambda-mesh (lambda(j), j=1, ..., m) plus a corresponding C |vector of "true" Spectral Density Function (SDF) values C |rho(lambda(j) of a given problem, and a vector of believed C |errors in these values. C | C --------+-------------------------------------------------------------- C Also 2 data objects not connected to an external file: C --------+-------------------------------------------------------------- C 'XMSHUN'|A "uniform" x-mesh C | C 'LMSHUN'|A "uniform" lambda-mesh C --------+-------------------------------------------------------------- C C Once an object has got a value, this value is not discarded till it C "has to be". This is for user convenience: meshes and "true" data act C as 'settings' that can be re-used many times. Just when a value is C discarded, is driven by what objects are used by different values of C Calculation-Choices setting CALSET, shown by the Y entries in this C Table below. C For each object we can also determine if 'no value is defined'. C This is shown by the logical expression in the "'Undefd' flag" column C in the table. C | USAGE | ID data |'Undefd' C CALSET = | 1 2 | 3 4 5 6 | 7 8 9 | | flag C ---------+------+------------+---------+------------------+----------+ C 'EVTRUE' | Y | Y | | %IPROB %KLO %KHI | %IPROB=-1 C 'EFTRUE' | | Y Y | | %IPROB %KLO %KHI | %IPROB=-1 C 'SDTRUE' | | | Y Y | %IPROB | %IPROB=-1 C ---------+------+------------+---------+------------------+----------+ C 'XMSHUN' | | Y | | none | %NMESH=-1 C 'LMSHUN' | | | Y | none | %NMESH=-1 C ---------+------+------------+---------+------------------+----------+ C where %IPROB in the ID data of 'EVTRUE' means a 'EVTRUE'%IPROB field C in the (conceptual) record 'EVTRUE'. C When the user invokes 'Solve' from the main menu the program checks C whether the object(s) required by the current CALSET have values that C are usable. C E.g if CALSET=6, the table shows 'EVTRUE' and 'EFTRUE' will be used. C For each, the "true" data cached within the program belongs to a C specific problem & k-range, so the program checks that the %IPROB C field *equals* the currently set IPROB and the %KLO:%KHI range C *contains* the currently set KLO:KHI (so that any "true" e-v, e-fn C data held on file for this k-range must be in the cache). If not, the C database is accessed. C C It is not necessary for any "true" values for this IPROB and k-range C to be present, but a valid x-mesh must be read, or the operation is C aborted. Other CALSET values are similar. C C The items with no ID data can be used *unconditionally* provided a C value is present (in case of 'XMSHUN' the program checks if the mesh C lies wholly within the current interval (A,B) and warns if not, but it C can use the mesh anyway). C C When the user invokes 'Display/change' from the main menu, the C program checks whether the object(s) required by the current CALSET C (1) have defined values, (2) are usable, and reports summary data. The C user then has the options C - update the object(s), as in case of 'Solve'. If this fails for any C object, the current value is left unchanged. (For CALSET=6, the C result may be that 'EVTRUE' is updated and 'EFTRUE' not, or v.v.) C - show values in more detail, if defined. E.g. for CALSET=5, the C x-mesh would be reported. For CALSET=6, each of "true" e-vs, x-mesh, C and "true" e-fn values can be requested. C C x-mesh design points C -------------------- C We expect users to wish to compare different e-fns on the *same* C x-mesh provided they come from the same Problem (same IPROB value) C in the following circumstances: C a. Different solver used C b. Changed e-v index C c. Changed BCs but same endpoints C d. Changed values of Problem-parameters C e. Changing the endpoints a,b from their "original" values. C C - For case d recall that changing parameters can change an C endpoint's classification, e.g. from regular to singular. C - For case e, recall an endpoint that is singular in the Problem C as originally posed can only be moved *inward* from its original C value, but an originally regular point can be moved in either C direction. C C Also, some solvers crash if an e-fn is evaluated *at* a singular C endpoint. But SLEDGE is explicitly designed not to do so, and in C fact the endpoints *must* be given it as part of any mesh, or it C will give an error exit. C C To cope with cases d,e above, SOLVIT *copies* the x-mesh passed to C it and alters it before passing it to the solver as follows. C Remove all points <=a and >=b (where a,b are the *current* C endpoints). Then add a (and similarly b) in the mesh if it is C regular (in particular if it has been moved inward from the C original a value), or if the solver is SLEDGE. The resulting mesh C is output from SOLVIT for use by REPORT. C C Inserting a,b like this improves the look of e-fn graphs! C C AUTO meshes are treated as if the mesh is formed by the SOLVIT call, C used in the REPORT call and forgotten. It can't be re-used; nor C displayed, except as part of the e-fn printout in REPORT. C C***+****|****+****| Details of module variables |****+****|****+****|** C DBPATH: Pathname relative to directory of executable program, where C data files are held. C Concrete storage representing 'EVTRUE': C QEVPRB,QEVKLO,QEVKHI: C 'ID-card' of "true" ev data currently cached in memory. C EVTRU: Row 1 holds "true" e-vs, row 2 holds believed absolute errors C Data for index k is in EVTRU(:,k-QEVKLO+1) C QEVTRU(K) says whether K-th "true" e-v is ABSENT or PRESNT C Ancillary data for 'EVTRUE', used for reporting C NEVBLK: No. of data blocks in file EVTRU.nn C IEVBLK: index of block chosen by user, in range 1:NEVBLK C Concrete storage representing 'EFTRUE': C QEFPRB,QEFKLO,QEFKHI: C 'ID-card' of "true" efn data currently cached in memory. C NXMTR: no. of points in XMSHTR C XMSHTR,EFTR,PDEFTR: C x-mesh, "true" values of u(x), pu'(x) on x-mesh for each k C QEFTRU(K) says whether K-th "true" e-fn is ABSENT or PRESNT C Ancillary data for 'EFTRUE', used for reporting C NEFBLK: No. of data blocks in file EFTRU.nn C IEFBLK: index of block chosen by user, in range 1:NEFBLK C Concrete storage representing 'SDTRUE': C QSDPRB: 'ID card' of lambda-mesh currently cached in memory C NLMTR: no. of points in lambda-mesh C LMSHTR,SDTRU C lambda-mesh, "true" values of SDF rho(lambda) on mesh C Ancillary data for 'SDTRUE', used for reporting C NSDBLK: No. of data blocks in file SDTRU.nn C ISDBLK: index of block chosen by user, in range 1:NSDBLK C Concrete storage representing 'XMSHUN': C NXMUN: no. of points in UNIForm x-mesh C XMSHUN UNIForm x-mesh C Concrete storage representing 'LMSHUN': C NLMUN: no. of points in UNIForm lambda-mesh C LMSHUN UNIForm lambda-mesh C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*40 DBPATH C 'EVTRUE': integer QEVPRB,QEVKLO,QEVKHI double precision EVTRU(1:2,1:MAXEVS) integer QEVTRU(1:MAXEVS) integer NEVBLK,IEVBLK C 'EFTRUE': integer:: QEFPRB,QEFKLO,QEFKHI integer NXMTR double precision XMSHTR(1:MAXMSH),EFTR(1:MAXMSH,1:MAXEVS) + ,PDEFTR(1:MAXMSH,1:MAXEVS) integer QEFTRU(1:MAXEVS) integer NEFBLK,IEFBLK C 'SDTRUE': integer QSDPRB integer NLMTR double precision LMSHTR(1:MAXMSH),SDTRU(1:2,1:MAXMSH) integer NSDBLK,ISDBLK C 'XMSHUN': integer NXMUN double precision XMSHUN(1:MAXMSH) C 'LMSHUN': integer NLMUN double precision LMSHUN(1:MAXMSH) C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** contains C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function EVCHK(IPROB,KLO,KHI) integer IPROB,KLO,KHI EVCHK = QEVPRB.eq.IPROB .and. QEVKLO.eq.KLO .and. QEVKHI.eq.KHI end function EVCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function EFCHK(IPROB,KLO,KHI) integer IPROB,KLO,KHI EFCHK = QEFPRB.eq.IPROB .and. QEFKLO.eq.KLO .and. QEFKHI.eq.KHI end function EFCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function SDCHK(IPROB) integer IPROB SDCHK = QSDPRB.eq.IPROB end function SDCHK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBINIT C Set initial state of 'EVTRUE', 'EFTRUE', 'SDTRUE', 'XMSHUN', 'LMSHUN' C to have no data. QEVPRB =-1 QEFPRB =-1 QSDPRB =-1 NXMUN = -1 NLMUN = -1 C and default k-range: does this make sense? QEVKLO = 0 QEVKHI = 9 QEFKLO = 0 QEFKHI = 9 end subroutine DBINIT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPEVTR(IPROB,KLO,KHI,FORCE) C UPEVTR updates DBMOD's 'EVTRUE'=(EVTRU,QEVTRU,QEVPRB,QEVKLO,QEVKHI). C All arguments are input. C If .not.FORCE and already present with 'ID'=(IPROB,KLO,KHI), nothing C is done. C If .not.FORCE and present with same IPROB & enclosing [KLO,KHI] it C doesn't read database file but shifts existing data appropriately. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it returns without changing C anything. C It sets ancillary 'EVTRUE' info if it reads file or tries to: C NEVBLK=no. of blocks on data file, 0 if no file C IEVBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB,KLO,KHI logical FORCE C .. Local scalars .. integer I,OFFSET if (QEVPRB.eq.IPROB .and. .not.FORCE) then if (QEVKLO.eq.KLO .and. QEVKHI.eq.KHI) return if (QEVKLO.le.KLO .and. QEVKHI.ge.KHI) then OFFSET = KLO-QEVKLO do 100 I=1,KHI-KLO+1 EVTRU(1,I) = EVTRU(1,I+OFFSET) EVTRU(2,I) = EVTRU(2,I+OFFSET) QEVTRU(I) = QEVTRU(I+OFFSET) 100 continue QEVKLO = KLO QEVKHI = KHI return end if end if C Else access database: call EVSCAN(IPROB,NEVBLK) IEVBLK = 0 if (NEVBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NEVBLK if (.not.GETIR(IEVBLK,1,NEVBLK)) return C Else OK with NEVBLK, IEVBLK both >0 so: C Reset 'EVTRUE's ID data QEVPRB = IPROB QEVKLO = KLO QEVKHI = KHI C Read the actual data: c print*,'UPEVTR calling EVDAT' call EVDAT(IPROB,KLO,KHI,EVTRU,QEVTRU) end subroutine UPEVTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPEFTR(IPROB,KLO,KHI,FORCE) C UPEFTR updates DBMOD's C 'EFTRUE'=(NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU,QEFPRB,QEFKLO,QEFKHI). C All arguments are input. C If .not.FORCE and already present with 'ID'=(IPROB,KLO,KHI), nothing C is done. C If .not.FORCE and present with same IPROB & *wider* k-range it C doesn't read database file but shifts existing data appropriately C to match the given k-range. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it returns without changing C 'EFTRUE'. C It sets ancillary 'EFTRUE' info if it reads file or tries to: C NEFBLK=no. of blocks on data file, 0 if no file C IEFBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB,KLO,KHI logical FORCE C .. Local scalars .. integer I,J,OFFSET if (QEFPRB.eq.IPROB .and. .not.FORCE) then if (QEFKLO.eq.KLO .and. QEFKHI.eq.KHI) return if (QEFKLO.le.KLO .and. QEFKHI.ge.KHI) then OFFSET = KLO-QEFKLO do 30 I=1,KHI-KLO+1 do 20 J=1,NXMTR EFTR(J,I) = EFTR(J,I+OFFSET) PDEFTR(J,I) = PDEFTR(J,I+OFFSET) QEFTRU(I) = QEFTRU(I+OFFSET) 20 continue 30 continue QEFKLO = KLO QEFKHI = KHI return end if end if C Else access database: call EFSCAN(IPROB,NEFBLK) IEFBLK = 0 if (NEFBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NEFBLK if (.not.GETIR(IEFBLK,1,NEFBLK)) return C Else OK with NEFBLK, IEFBLK both >0 so: C Reset 'EFTRUE's ID data QEFPRB = IPROB QEFKLO = KLO QEFKHI = KHI C Read the actual data: c print*,'UPEFTR calling EFDAT' call EFDAT(IPROB,KLO,KHI,NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU) end subroutine UPEFTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPSDTR(IPROB,FORCE) C All arguments are input. C UPSDTR updates DBMOD's 'SDTRUE'=(NLMTR,LMSHTR,SDTRU,QSDPRB). C If .not.FORCE and already present with 'ID'=(IPROB), nothing is done. C Else, it gets from database file a block of "true" data with C this ID. C If no file exists, or user aborts, it pretends it does and puts C empty info in 'SDTRUE'. C It sets ancillary 'SDTRUE' info if it reads file or tries to: C NSDBLK=no. of blocks on data file, 0 if no file C ISDBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB logical FORCE if (QSDPRB.eq.IPROB .and. .not.FORCE) return C Else access database: call SDSCAN(IPROB,NSDBLK) ISDBLK = 0 if (NSDBLK.eq.0) return write(*,'(''Which block do you want (1 to'',i2, + ''), z to abort? '')',advance='NO') NSDBLK if (.not.GETIR(ISDBLK,1,NSDBLK)) return C Else OK with NSDBLK, ISDBLK both >0 so: C Reset 'SDTRUE's ID data QSDPRB = IPROB C Read the actual data: c print*,'UPSDTR calling SDDAT' call SDDAT(IPROB,NLMTR,LMSHTR,SDTRU) end subroutine UPSDTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPXMUN(FORCE) C Argument FORCE is input. C UPXMUN updates DBMOD's 'XMSHUN'=(NXMUN,XMSHUN). C It gets NXMSHI from user, default 10 if abort, forms uniform mesh of C NXMUN=NXMSHI+2 points in XMSHUN. C .. Scalar arguments .. logical FORCE C .. Local scalars .. integer NXMSHI double precision A,B if (NXMUN.le.0 .or. FORCE) then C extract current endpoints of SLP from module SLPSET call GTABCU(A,B) write(*,9991,advance='NO') MAXMSH-2 9991 format('How many interior points in x-mesh (not counting A,B)',/ + ' in range 10 to',i3,': ') if (.not. GETIR(NXMSHI,10,MAXMSH-2)) then NXMSHI = 10 write(*,'(3x,a)') 'No. of points set to default of 10' end if NXMUN = NXMSHI+2 write(*,'(3x,a,i3,a)') + 'Forming "UNIForm" mesh of ',NXMUN,' points' C Revised x-meshes spec means we always include A,B in UNIF mesh: call MKMESH(NXMUN,A,B,.TRUE.,.TRUE.,XMSHUN) end if end subroutine UPXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine UPLMUN(FORCE) C Argument FORCE is input. C UPLMUN updates DBMOD's 'LMSHUN'=(NLMUN,LMSHUN). C It gets NLMUN from user, default 10 if abort, forms uniform mesh of C NLMUN points, over [LLO,LHI], in LMSHUN. If LLO or LHI is infinite, C it is excluded from the mesh but the no. of points stays the same. C .. Scalar arguments .. logical FORCE C .. Local scalars .. double precision LLO,LHI if (NLMUN.le.0 .or. FORCE) then write(*,9999,advance='NO') -XINFTY 9999 format('Give lower endpoint of lambda-mesh',/ + ' (use ',1p,d10.2,'for minus infinity: ') if (.not. GETR(LLO)) then LLO=0d0 write(*,*) ' Lower endpoint set to default of ',LLO end if write(*,9998,advance='NO') XINFTY 9998 format('Give upper endpoint of lambda-mesh',/ + ' (use ',1p,d10.2,'for plus infinity: ') if (.not. GETRR(LHI,LLO,XINFTY)) then LHI=XINFTY write(*,*) ' Upper endpoint set to default of ',LHI end if write(*,9991,advance='NO') MAXMSH 9991 format('How many points in lambda-mesh',/ + ' in range 1 to',i3,': ') if (.not. GETIR(NLMUN,1,MAXMSH)) then NLMUN = 10 write(*,*) 'No. of points set to default of ',NLMUN end if write(*,'(3x,a,i3,a)') + 'Forming "UNIForm" mesh of ',NLMUN,' points' call MKMESH(NLMUN,LLO,LHI,LLO.gt.-XINFTY,LHI.lt.XINFTY,LMSHUN) end if end subroutine UPLMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIEVTR(IPROB,KLO,KHI) C DIEVTR displays DBMOD's 'EVTRUE'=(EVTRU,QEVTRU,QEVPRB,QEVKLO,QEVKHI). C Also ancillary 'EVTRUE' info C NEVBLK=no. of blocks on data file, 0 if no file C IEVBLK=index of user-selected block, 0 if no block selected C .. Scalar arguments .. integer IPROB,KLO,KHI C .. Local scalars .. integer IK,K if (QEVPRB.eq.-1) then write(*,*)'No "true" eigenvalue data is present' return end if write(*,*)'Stored "true" eigenvalue data is block ',IEVBLK, + ' of ',NEVBLK,' on file' if (QEVPRB.eq.IPROB) then if (QEVKLO.eq.KLO .and. QEVKHI.eq.KHI) then write(*,*) + 'Data matches current problem and k range' elseif (QEVKLO.le.KLO .and. QEVKHI.ge.KHI) then write(*,*) + 'Data matches current problem and ', + 'encloses current k range' else write(*,*) + 'Data matches current problem but ', + 'for different k range' end if else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QEVPRB,' from k= ',KLO,' to k= ',KHI write(*,fmt="(3x,'K',5x,'Eigenvalue',13x,'Believed error')") do 100 K=KLO,KHI IK = K-KLO+1 if (QEVTRU(IK).eq.PRESNT) write(*, + fmt='(i4,3x,1p,g22.15,3x,d10.2)')K,EVTRU(1,IK),EVTRU(2,IK) 100 continue end subroutine DIEVTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIEFTR(IPROB,KLO,KHI) C DIEFTR displays DBMOD's 'EFTRUE'= C (EFTR,PDEFTR,QEFTRU,QEFPRB,QEFKLO,QEFKHI). C Also ancillary 'EFTRUE' info C NEFBLK=no. of blocks on data file, 0 if no file C IEFBLK=index of user-selected block, 0 if no block selected C .. Scalar arguments .. integer IPROB,KLO,KHI C .. Local scalars .. integer IK,J,K if (QEFPRB.eq.-1) then write(*,*)'No x-mesh / "true" eigenfunction data is present' return end if write(*,*)'Stored "true" eigenfunction data is block ',IEFBLK, + ' of ',NEFBLK,' on file' if (QEFPRB.eq.IPROB) then if (QEFKLO.eq.KLO .and. QEFKHI.eq.KHI) then write(*,*) + 'Data matches current problem and k range' elseif (QEFKLO.le.KLO .and. QEFKHI.ge.KHI) then write(*,*) + 'Data matches current problem and ', + 'encloses current k range' else write(*,*) + 'Data matches current problem but ', + 'for different k range' end if else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QEFPRB,' from k= ',KLO,' to k= ',KHI do 100 K=KLO,KHI IK = K-KLO+1 if (QEFTRU(IK).eq.PRESNT) then write(*,fmt=9999) K 9999 format (1x,'Stored Eigenfunction Values for k=',i4,/ + 1x,8x,'x u(x) pu''(x)') do 90 J=1,NXMTR write(*,fmt=9997)XMSHTR(J),EFTR(J,IK),PDEFTR(J,IK) 9997 format (1x,0p,f12.7,1p,2e18.10) 90 continue end if 100 continue end subroutine DIEFTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DISDTR(IPROB) C DISDTR displays DBMOD's 'SDTRUE'=(NLMTR,LMSHTR,SDTRU,QSDPRB). C Also ancillary 'SDTRUE' info C NSDBLK=no. of blocks on data file, 0 if no file C ISDBLK=index. of user-selected block, 0 if no file or user-abort C .. Scalar arguments .. integer IPROB C .. Local scalars .. integer I if (QSDPRB.eq.-1) then write(*,*) + 'No lambda-mesh / "true" spectral density data is present' return end if write(*,*)'Stored "true" spectral density data is block ', + ISDBLK,' of ',NSDBLK,' on file' if (QSDPRB.eq.IPROB) then write(*,*)'Data matches current problem' else write(*,*) 'Data is not for current problem' end if write(*,*) 'Problem ',QSDPRB write(*,fmt="(6x,'lambda',15x,'rho(lambda)',9x,'Believed error')") do 100 I=1,NLMTR write(*,fmt='(i2,3x,1p,2g22.15,3x,d10.2)') + I,LMSHTR(I),SDTRU(1,I),SDTRU(2,I) 100 continue end subroutine DISDTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DIXMUN() C DIXMUN displays DBMOD's 'XMSHUN'=(NXMUN,XMSHUN). C .. Local scalars .. integer I if (NXMUN.eq.-1) then write(*,*)'No "uniform" x-mesh data is present' return end if write(*,fmt=9999) NXMUN,XMSHUN(1),XMSHUN(NXMUN) 9999 format('Stored ''UNIForm'' x-mesh has',i3,' points from x =', + g10.5,' to x =',g10.5,/ + ' i x(i)') do 100 I=1,NXMUN write(*,fmt='(i3,3x,1p,g22.15)') I,XMSHUN(I) 100 continue end subroutine DIXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DILMUN() C DILMUN displays DBMOD's 'LMSHUN'=(NLMUN,LMSHUN). C .. Local scalars .. integer I if (NLMUN.eq.-1) then write(*,*)'No "uniform" lambda-mesh data is present' return end if write(*,fmt=9999) NLMUN,LMSHUN(1),LMSHUN(NLMUN) 9999 format('Stored ''UNIForm'' lambda-mesh has',i3, + ' points from lambda =',g10.5,' to lambda =',g10.5,/ + ' i lambda(i)') do 100 I=1,NLMUN write(*,fmt='(i3,3x,1p,g22.15)') I,LMSHUN(I) 100 continue end subroutine DILMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTXMTR(NXMESH,XMESH) C GTXMTR tries to copy 'EFTRUE's x-mesh to NXMESH,XMESH. If this mesh C exists (QEFPRB>0), it copies it and returns TRUE, else it leaves C NXMESH,XMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NXMESH C .. Array arguments .. double precision XMESH(1:MAXMSH) C .. Local scalars .. integer I if (QEFPRB.gt.0) then GTXMTR = .TRUE. NXMESH = NXMTR do 102 I=1,NXMESH XMESH(I) = XMSHTR(I) 102 continue return else GTXMTR = .FALSE. end if end function GTXMTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTXMUN(NXMESH,XMESH) C GTXMUN tries to copy 'XMSHUN's x-mesh to NXMESH,XMESH. If this mesh C exists (NXMUN>0), it copies it and returns TRUE, else it leaves C NXMESH,XMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NXMESH C .. Array arguments .. double precision XMESH(1:MAXMSH) C .. Local scalars .. integer I if (NXMUN.gt.0) then GTXMUN = .TRUE. NXMESH = NXMUN do 102 I=1,NXMESH XMESH(I) = XMSHUN(I) 102 continue return else GTXMUN = .FALSE. end if end function GTXMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTLMTR(NLMESH,LMESH) C GTLMTR tries to copy 'SDTRUE's lambda-mesh to NLMESH,LMESH. If this mesh C exists (QSDPRB>0), it copies it and returns TRUE, else it leaves C NLMESH,LMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NLMESH C .. Array arguments .. double precision LMESH(1:MAXMSH) C .. Local scalars .. integer I if (QSDPRB.gt.0) then GTLMTR = .TRUE. NLMESH = NLMTR do 102 I=1,NLMESH LMESH(I) = LMSHTR(I) 102 continue return else GTLMTR = .FALSE. end if end function GTLMTR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GTLMUN(NLMESH,LMESH) C GTLMUN tries to copy 'LMSHUN's lambda-mesh to NLMESH,LMESH. If this C mesh exists (NLMUN>0), it copies it and returns TRUE, else it leaves C NLMESH,LMESH unchanged and returns FALSE. C .. Scalar arguments .. integer NLMESH C .. Array arguments .. double precision LMESH(1:MAXMSH) C .. Local scalars .. integer I if (NLMUN.gt.0) then GTLMUN = .TRUE. NLMESH = NLMUN do 102 I=1,NLMESH LMESH(I) = LMSHUN(I) 102 continue return else GTLMUN = .FALSE. end if end function GTLMUN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EVSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C EVSCAN scans the file of "true" eigenvalue data for Problem no. C IPROB in the current test set, & displays on-screen the description C line for each data-block in the file, also any Comment lines. C It returns NBLOCK=no. of blocks in file, or 0 if file doesn't C exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C EVTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter B in column 1, the rest C of the line being treated as comment & displayed on screen. C E.g. B Evs with alpha=1, BCs u'(0)=0, u(pi)=0 C The block continues with a sequence of records with V in col. 1 C the rest of the line containing C Index k Eigenvalue eig_k Believed bound on absolute error C in free-format, with the k values >=0 and sorted in increasing order. C E.g. V 1 4.1234567890 2.0d-10 C indicates that we believe ev no. 1 equals 4.1234567890 with error at C most 2 units in the last place. C C Creating and adding to these files is the user's responsibility. C The log-file output from the program, using suitably high C accuracy, can often be trusted to provide the needed data. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the eigenvalue records for each block have C k's in ascending order. If records for a block are for k = 4 5 6 0 1 2 C in that order, and KLO..KHI is 2..5, then the routine will see the data C for k= 4 and 5, and miss that for k = 2. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'X', skip record C else increase NBLOCK & read description line & display it C end if C end loop C close input file & return integer INFIL parameter(INFIL=18) integer IP, IREC, IOERR character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'evtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'evtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying B and V data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'B') then C skip rest of line: read(INFIL,*) else read(INFIL,'(a)') LINE NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!",/ + "! ",a,t79,"!")') NBLOCK,LINE end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine EVSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EVDAT(IPROB,KLO,KHI,EVTRU,QEVTRU) integer IBLOCK,IPROB,KLO,KHI,QEVTRU(KLO:KHI) double precision EVTRU(1:2,KLO:KHI) C EVDAT reads the file of "true" eigenvalue data for Problem no. C IPROB in the current test set, up to the IEVBLK-th block where IEVBLK C is a module variable. C EVDAT returns in EVTRU a list comprising those ev's in the block C whose index k lies in the range KLO..KHI. C C Specifically, if the database file for this problem doesn't exist C nothing is altered. Otherwise, on exit from EVDAT: C - For each ev in database whose k is in KLO..KHI: C EVTRU(1,K) holds eig_k; C EVTRU(2,K) holds a believed bound >=0 for the error in eig_k; C QEVTRU(K) holds the value PRESNT (=1) C - For each other k in KLO..KHI C QEVTRU(K) holds the value ABSENT (=0) C C Algorithm summary: C Open input file C loop C Read to IEVBLK-th 'B'-record as in EVSCAN C end loop C loop C Read record-type ('B' or 'V' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'B' or 'E' C exit loop C elsif type 'V' C read V-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IP, IREC, IOERR, K double precision EV,EVERR C! character FNAME*43, LINE*72, REC_ID*1 character FNAME*43, REC_ID*1 C Make this a fatal error becuse it should never happen, and if it does, C an array bound exception will soon occur in main program! if (KHI-KLO+1 .gt. MAXEVS) then write(*,'(/,a)') '*** EVDAT: Fatal error, KHI-KLO+1>MAXEVS' stop end if C Set FNAME to 'evtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'evtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C Initialize ev-data status info do 20 K=KLO,KHI QEVTRU(K) = ABSENT 20 continue C C Now count up to IEVBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'B') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.IEVBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block, skip rest of line: 299 continue read(INFIL,'(a)') C Read V-data in the block, skipping comment lines but C terminating at any other record-type: write(*,'(t1,"! Block",i2,": K values",t79,"!")') IEVBLK 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'V') goto 900 read(INFIL,*,iostat=IOERR) K,EV,EVERR if (IOERR.ne.0) then write(*,*) write(*,*)'***EVDAT: error reading V-data at record',IREC elseif (K.ge.KLO .and. K.le.KHI) then EVTRU(1,K) = EV EVTRU(2,K) = EVERR QEVTRU(K) = PRESNT write(*,fmt='(i5)',advance='NO') K end if goto 350 900 write(*,*) close(INFIL) write(*,*)'... Done' end subroutine EVDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EFSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C EFSCAN scans the file of "true" eigenfunction data for Problem no. C IPROB in the current test set, & displays on-screen the Mesh C belonging to each data-block in the file, also any Comment lines. C It returns NBLOCK=no. of blocks in file, or 0 if file doesn't C exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C EFTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter X in column 1 C and continuing with the free-format data (which can spill over onto C further lines) C m x(1) ... x(m) C i.e. the value of NMESH and the points x(i) of the mesh. C C Convention: C x(1) may be given as -1.0d35 and x(m) as 1.0d35 (SLTSTPAK's C values for -infinity, +infinity), these will be set by the code C to the current value of a resp. b. C C Restrictions: C If you are setting up meshes to experiment with, you can do what you C like! But if setting up "true" eigenfunction values for general C use, observe these rules to avoid situations which some solvers C can't handle: C 1. a <= x(1) < x(2) < ... < x(m) <= b C where a, b are the endpoints of the problem (the current ones, which C may have been changed from the default ones!) C 2.Equality at either end is forbidden UNLESS that end is regular or C weakly regular (of type 'R' or 'WR' in SLTSTPAK). Of course any C end that has been moved inward from the default end is of type 'R'. C NOTE this excludes, for instance, x=-1, x=1 being included in "true" C data for the Legendre equation (Standard#20) even though all C efns (for the default BCs) are polynomials, and finite at these C points. C The rest of the block is a sequence of records having letter U in C column 1 and continuing with free-format data C k u(1) pu'(1) ... u(m) pu'(m) C i.e. the eigenvalue index k and the values of the k-th eigenfunction C u_k(x) and derivative p(x)u_k'(x) at the points x=x(i) of the mesh. C An example block is (with the X and U's assumed to be in col 1) C C This is a sample block C X 5 1.000 1.500 2.000 2.500 3.000 C U 0 0.12345678 1.3567890 C 0.35673892 0.2121212 C 0.50012098 0 C 0.35673892 -0.2121212 C 0.12345678 -1.3567890 C C Creating and adding to these files is the user's responsibility. C The log-file output from the program, using suitably high C accuracy, can sometimes be trusted to provide the needed data: C but often it can't! Codes' eigenfunction values are still erratic. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the eigenfunction records (U-records) for each block have C k's in ascending order. If U-records for a block are for k = 4 5 6 0 1 2 C in that order, and KLO..KHI is 2..5, then the routine will see the data C for k= 4 and 5, and miss that for k = 2. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'X', skip record C else increase NBLOCK & read mesh & display it C end if C end loop C close input file & return integer IP, IREC, IOERR, J, NMESH double precision XMSHTR(1:MAXMSH) character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'eftru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'eftru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying X and U data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c write(*,*)'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'X') then C skip rest of line: read(INFIL,*) else read(INFIL,*,iostat=IOERR) NMESH * ,(XMSHTR(J),J=1,MIN(NMESH,MAXMSH)) if (IOERR.ne.0) then write(*,*)'*** EFSCAN: error reading X-data at record' * ,IREC else NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!")') NBLOCK if (NMESH.gt.MAXMSH) then write(*,*)'Mesh specified with',NMESH,' points,', * ' reduced to maximum allowed:',MAXMSH NMESH = MAXMSH end if write(*,'("! has mesh of",i3," points:",t79,"!")') NMESH write(*,'("!",t79,"!",t4,1p6e12.4)')(XMSHTR(J),J=1,NMESH) end if end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine EFSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine EFDAT(IPROB,KLO,KHI,NXMTR,XMSHTR,EFTR,PDEFTR,QEFTRU) integer IBLOCK,IPROB,KLO,KHI,NXMTR,QEFTRU(KLO:KHI) double precision EFTR(1:MAXMSH,KLO:KHI), * PDEFTR(1:MAXMSH,KLO:KHI),XMSHTR(1:MAXMSH) C EFDAT reads the file of "true" eigenfunction data for Problem no. C IPROB in the current test set, up to the IEFBLK-th block where IEFBLK C is a module variable, and returns in XMSHTR (starting at C XMSHTR(1)) the x-mesh for that block, in EFTR a list of vectors C comprising the values on the x-mesh of those eigenfunctions in the C block for which data exists and whose index k lies in the range C KLO..KHI, in PDEFTR the corresponding derivative values. QEFTRU(K) C says whether data for index K is present. C C Specifically, on exit from EFDAT C NXMTR holds no. of points in x-mesh of user-chosen block C XMSHTR(1:NXMTR) holds their values C while for each such k, as above: C EFTR(k,1:NXMTR) holds values of k-th eigenfunction on mesh C PDEFTR(k,1:NXMTR) holds values of k-th eigenfunction on mesh C QEFTRU(k) holds the value PRESNT (=1) C For each other k in KLO..KHI C QEFTRU(k) holds the value ABSENT (=0) C C Algorithm summary: C Open input file C loop C Read to IEFBLK-th 'X'-record as in EFSCAN C end loop C Read X-mesh & store C loop C Read record-type ('X' or 'U' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'X' or 'E' C exit loop C elsif type 'U' C read U-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IP, IREC, IOERR, J, K double precision U(1:MAXMSH),PDU(1:MAXMSH) character FNAME*43, REC_ID*1 C Set FNAME to 'eftru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'eftru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C Make this a fatal error becuse it should never happen if (IOERR.ne.0 .or. IEFBLK.le.0) then write(*,*) + '*** EFDAT: Fatal error, cannot open file or Block no. <= 0' stop end if C Make this a fatal error becuse it should never happen, and if it does, C an array bound exception will soon occur in main program! if (KHI-KLO+1 .gt. MAXEVS) then write(*,*)'*** EFDAT: Fatal error, KHI-KLO+1>MAXEVS' stop end if C Initialize e-fn data status info: do 20 K=KLO,KHI QEFTRU(K) = ABSENT 20 continue C C Now count up to IEFBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'X') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.IEFBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block: 299 continue read(INFIL,*,iostat=IOERR) NXMTR * ,(XMSHTR(J),J=1,MIN(NXMTR,MAXMSH)) c print*,'NXMTR: ',NXMTR if (IOERR.ne.0) then write(*,*)'EFDAT: error reading X-data at record',IREC else if (NXMTR.gt.MAXMSH) then NXMTR = MAXMSH end if end if C Read U-data in the block, skipping comment lines but C terminating at any other record-type: write(*,'(t1,"! Block",i2,": K values",t79,"!")') IEFBLK 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c write(*,*)'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'U') goto 900 read(INFIL,*,iostat=IOERR) K,(U(J),PDU(J),J=1,NXMTR) if (IOERR.ne.0) then write(*,*)'EFDAT: error reading U-data at record',IREC elseif (K.ge.KLO .and. K.le.KHI) then do 400 J=1,NXMTR EFTR(J,K) = U(J) PDEFTR(J,K) = PDU(J) 400 continue QEFTRU(K) = PRESNT write(*,fmt='(i5)',advance='NO') K end if goto 350 900 write(*,*) c print*,'exit EFDAT: NXMTR=',NXMTR close(INFIL) write(*,*)'... Done' end subroutine EFDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SDSCAN(IPROB,NBLOCK) integer IPROB,NBLOCK C SDSCAN scans the file of "true" data for Spectral Density Function C (SDF) rho(lambda) of Problem no. IPROB in the current test set, & C displays on-screen the description line for each data-block in the C file, also any Comment lines. It returns NBLOCK=no. of blocks in file, C or 0 if file doesn't exist or has no data. C C The database for Problem no. nn (01<=nn<=60) is the textfile C SDTRU.nn C in directory "testset\truevals" where "testset" denotes the name of C current test set. It need not exist: if it does not, it is treated C as if it is empty. C C The file comprises a sequence of blocks, and may also have Comment C lines with C in column 1 (these must not occur in the middle of a C sequence of free-format data). C Each block starts with a record having letter B in column 1, the rest C of the line being treated as comment & displayed on screen. C E.g. B Problem with lambda-dependent BC coeffs = 1 0 0 1 C The block continues with a sequence of records with R in col. 1 C the rest of the line containing C lambda rho(lambda) Believed bound on absolute error C in free-format, with the lambda values sorted in increasing order. C E.g. R 0.5 0.7324 2d-4 C indicates that we believe rho(0.5) equals 0.7324 with error at C most 2 units in the last place. C C Creating and adding to these files is the user's responsibility. C C The file is identified by the Problem No. The individual data C blocks carry no identification of the parameter values, range A,B and C boundary conditions used, so if you use various values for these, C identify them by comment lines! The program can't understand the C comments, but displays them when it reads the file. C C Verifying the file is also the user's responsibility. In particular, C make sure the SDF records for each block have lambda's in ascending C order. C C Algorithm summary: C Set block-count NBLOCK & record-count ILINE to 0 C Open input file, if it doesn't exist count as end-of-file C loop C Read record-type (=1st character of record) C exit loop on end-of-file C if 'C' (comment), read & display rest of line C elseif not 'B', skip record C else increase NBLOCK & read description line & display it C end if C end loop C close input file & return integer IP, IREC, IOERR character FNAME*43, REC_ID*1, LINE*72 NBLOCK = 0 C Set FNAME to 'sdtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'sdtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) if (IOERR.ne.0) then write(*,'("! Database file ",a," not found",t79,"!")') + FNAME(1:IP) else write(*,'("! Reading database file ",a,t79,"!")') FNAME IREC = 0 C Main Loop over blocks, displaying B and R data for each: 150 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.lt.0 .or. REC_ID.eq.'E') goto 199 IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,'(a)') LINE write(*,'("! ",a,t79,"!")') LINE elseif (REC_ID.ne.'B') then C skip rest of line: read(INFIL,*) else read(INFIL,'(a)') LINE NBLOCK = NBLOCK+1 write(*,'("! Block",i2,":",t79,"!",/ + "! ",a,t79,"!")') NBLOCK,LINE end if C end of loop goto 150 199 continue end if close(INFIL) end subroutine SDSCAN C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SDDAT(IPROB,NLMTR,LMSHTR,SDTRU) integer IPROB,NLMTR double precision LMSHTR(1:MAXMSH),SDTRU(1:2,1:MAXMSH) C SDDAT reads the file of "true" SDF data for Problem no. IPROB in the C current test set, up to the ISDBLK-th block where ISDBLK is a module C variable. C SDDAT returns in LMSHTR a mesh of lambda values in ascending order, in C SDTRU(1,:) the corresponding SDF values rho(lambda) and in SDTRU(2,:), C believed bounds on the absolute errors in the SDF values. C C If the database file for this problem doesn't exist nothing is C altered. C C Algorithm summary: C Open input file C loop C Read to ISDBLK-th 'B'-record as in SDSCAN C end loop C loop C Read record-type ('B' or 'R' expected but could be garbage) C if end-of-file then count it as record-type 'E' C else increase line-count C end if C if type is 'B' or 'E' C exit loop C elsif type 'R' C read R-data & insert in output arrays & display C else C ERROR message: unrecognized record-type C end if C end loop C Close input file integer IBLOCK, IP, IREC, IOERR double precision LAMBDA, SD,SDERR character FNAME*43, LINE*72, REC_ID*1 logical RECOK C Set FNAME to 'sdtru.nn' where nn = decimal representation of IPROB C This is a f77-ish trick for getting nn with leading zeros C Pathname is then added. write(FNAME,'(i3)') 100+IPROB call STTRIM(DBPATH,IP) FNAME = DBPATH(1:IP)//'sdtru.'//FNAME(2:3) call STTRIM(FNAME,IP) open(INFIL,file=FNAME,status='OLD',action='READ', + position='REWIND',iostat=IOERR) C C Now count up to ISDBLK-th block: IBLOCK = 0 IREC = 0 250 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID IREC = IREC+1 if (REC_ID.eq.'B') IBLOCK = IBLOCK+1 c print*,'IREC IBLOCK REC_ID: ',IREC,IBLOCK,REC_ID if (IBLOCK.ge.ISDBLK) goto 299 read(INFIL,*) goto 250 C Now we are at 2nd character of desired block: 299 continue read(INFIL,'(a)') LINE write(*,'(t1,"! Block",i2,": lambda values",t79,"!")') ISDBLK C Read R-data in the block, skipping comment lines but C terminating at any other record-type: NLMTR = 0 350 continue read(INFIL,'(a1)',advance='NO',iostat=IOERR) REC_ID if (IOERR.ne.0) REC_ID = 'E' IREC = IREC+1 c print*, 'Record',IREC,' type "',REC_ID,'"' if (REC_ID.eq.'C') then read(INFIL,*) goto 350 end if if (REC_ID.ne.'R') goto 900 RECOK = .TRUE. read(INFIL,*,iostat=IOERR) LAMBDA,SD,SDERR if (IOERR.ne.0) then RECOK = .FALSE. write(*,*)'*** SDDAT: error reading R-data at record',IREC elseif (NLMTR .ge. MAXMSH) then RECOK = .FALSE. write(*,*)'SDDAT: more than ',MAXMSH, + ' values in SDF Data Block, excess ignored' elseif (NLMTR.gt.0) then if (LAMBDA.le.LMSHTR(NLMTR)) then RECOK = .FALSE. write(*,*)'SDDAT: lambda value ',LAMBDA, + ' in SDF Data Block not in asc. order will be ignored' end if end if if (RECOK) then NLMTR = NLMTR+1 LMSHTR(NLMTR) = LAMBDA SDTRU(1,NLMTR) = SD SDTRU(2,NLMTR) = SDERR write(*,fmt='(1pg10.4)',advance='NO') LAMBDA end if goto 350 900 write(*,*) close(INFIL) write(*,*)'... Done' end subroutine SDDAT C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine DBSUMM use SAFEIO C Crude routine to display ID information for cached data print*,'EVTRUE:' print*,' QEVPRB,QEVKLO,QEVKHI=',QEVPRB,QEVKLO,QEVKHI C double precision EVTRU(1:2,1:MAXEVS) print*,' QEVTRU(1:QEVKHI-QEVKLO+1)=',QEVTRU(1:QEVKHI-QEVKLO+1) print*,' NEVBLK,IEVBLK=',NEVBLK,IEVBLK print*,'EFTRUE:' print*,' QEFPRB,QEFKLO,QEFKHI=',QEFPRB,QEFKLO,QEFKHI print*,' NXMTR=',NXMTR print*,' XMSHTR(1:NXMTR)=',XMSHTR(1:NXMTR) C + ,EFTR(1:MAXMSH,1:MAXEVS),PDEFTR(1:MAXMSH,1:MAXEVS) print*,' QEFTRU(1:QEFKHI-QEFKLO+1)=',QEFTRU(1:QEFKHI-QEFKLO+1) print*,' NEFBLK,IEFBLK=',NEFBLK,IEFBLK print*,'SDTRUE:' print*,' QSDPRB=',QSDPRB print*,' NLMTR=',NLMTR print*,' LMSHTR(1:NLMTR)=',LMSHTR(1:NLMTR) print*,' NSDBLK,ISDBLK=',NSDBLK,ISDBLK print*,'XMSHUN:' print*,' NXMUN=',NXMUN print*,' XMSHUN(1:NXMUN)=',XMSHUN(1:NXMUN) print*,'LMSHUN:' print*,' NLMUN=',NLMUN print*,' LMSHUN(1:NLMUN)=',LMSHUN(1:NLMUN) call SPAUSE end subroutine DBSUMM end module DBMOD SHAR_EOF fi # end of overwriting check if test -f 'errflags.hlp' then echo shar: will not over-write existing file "'errflags.hlp'" else cat << SHAR_EOF > 'errflags.hlp' For information on error exits from the solvers: SLEIGN see source code SL\SLEIGN\SLEIGN.FOR SLEDGE see source code SL\SLEDGE\SLEDGE.FOR SL02F see source code of SL02F in SL\MARCOPAK\MARCOPK1.FOR SLEIGN2 see formats 9010 onward in source text of SL\SLEIGN2\EXTRAS\DRIVE.F Also lines 93 onward (re IFLAG values) in SL\SLEIGN2\SLEIGN2D.FOR though the info there does not seem to be complete. D02KEF see SL\D02KEF\D02KEF.DOC (the NAG online help file) SHAR_EOF fi # end of overwriting check if test -f 'evsimp.f' then echo shar: will not over-write existing file "'evsimp.f'" else cat << SHAR_EOF > 'evsimp.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** C A simple driver to show the use of SLTSTPAK. It uses SL02F as solver. C The problem-set is arbitrary and can be chosen at link-time. program EVSIMP use SLTSTPAK use MARCOMOD implicit none integer IWK,NTEMP parameter (IWK=10000,NTEMP=400) double precision A,A1,A2,B,B1,B2,CURREN,ELAPSE,TOL,XINFTY integer I,IFAIL,IPROB,K,N,NEPRM,NPARM,NPROB,KNOBS(3) logical SYM character ATYPE*4,BTYPE*4,PARNM*72,TITLE*72,TSETNM*8 double precision ELAM(0:1),PARM(0:10),WK(0:IWK,1:4), + WKSMAL(0:NTEMP,1:7) data KNOBS/3*0/ common/SL02CM/ AINFO,BINFO character AINFO*1,BINFO*1 external GETBC C SOLVER-INDEPENDENT STARTUP PHASE C Call the general initialization routine: call TSTINI(TSETNM,NPROB,XINFTY) C Select the Problem write (*,FMT='('' Problem number (1 to'',i3,''): '')') NPROB read (*,FMT=*) IPROB C Call the first section of set-up code: call SETUP0(IPROB,TITLE,NPARM,NEPRM,PARNM) C Write the problem title and ask for parameters if any: write (*,FMT=*) TITLE if (NPARM.gt.0) then write (*,FMT=*) 'Give values of these parameters: ', PARNM read (*,FMT=*) (PARM(I),I=1,NPARM) end if C Call the second section of set-up code: call SETUP1(PARM,A,B,ATYPE,BTYPE,A1,A2,B1,B2,SYM) C Set eigenvalue index & tolerance: write (*,FMT='('' Eigenvalue index: '')') read (*,FMT=*) K write (*,FMT='('' Tolerance: '')') read (*,FMT=*) TOL C SOLVER-SPECIFIC CODE C Give initial guess of ELAM(0) & its error: ELAM(0) = 0d0 ELAM(1) = 1d0 C Convert information about endpoints into form needed by SL02F: call TRANSL(A.ne.-XINFTY,ATYPE,AINFO) call TRANSL(B.ne.XINFTY,BTYPE,BINFO) C Give max no. of meshpoints to be used by SL02F N = 3000 C Select soft failure option: IFAIL = -1 C Set the CPU clock running: call CPU(0,CURREN,ELAPSE) C Solve the problem: call SL02F(ELAM,A,B,K,AINFO,BINFO,SYM,TOL,COEFFN,GETBC,N,WK,IWK, + WKSMAL,NTEMP,KNOBS,IFAIL) C Read the CPU clock: call CPU(1,CURREN,ELAPSE) C Report results: write (*,FMT=*) 'Final estimate of eigenvalue:',ELAM(0) write (*,FMT='('' Error estimate:'',1pd9.2)') ELAM(1) write (*,FMT=*) 'Number of function evaluations:',NEVAL(0) write (*,FMT=*) 'Number of meshpoints used during solution:',N write (*,FMT=*) 'Exit value of IFAIL:',IFAIL write (*,FMT='('' CPU time (sec): '',f10.5)') ELAPSE if (IFAIL.ne.0) write (*,FMT=*) ' WARNING: IFAIL IS NONZERO ' end subroutine TRANSL(XFINIT,XTYPE,XINFO) C Translates SLTSTPAK endpoint-type info into SL02F form. logical XFINIT character XINFO*1,XTYPE*4 if (XTYPE.eq.'R ' .or. XTYPE.eq.'RS ') then XINFO = 'R' else if (XFINIT) then XINFO = 'S' else XINFO = 'I' end if end subroutine GETBC(Y,PDY,EIG,X,IEND,ISING) C GETBC interfaces between SL02F and GETBCS, putting the arguments in a C different order. It also extracts the ISING data via SL02CM. use SLTSTPAK,only:GETBCS implicit none double precision EIG,PDY,X,Y integer IEND logical ISING common/SL02CM/ AINFO,BINFO character AINFO*1,BINFO*1 call GETBCS(IEND,X,EIG,PDY,Y) if (IEND.eq.0) then ISING = AINFO.ne.'R' else ISING = BINFO.ne.'R' end if end SHAR_EOF fi # end of overwriting check if test -f 'initpuff.hlp' then echo shar: will not over-write existing file "'initpuff.hlp'" else cat << SHAR_EOF > 'initpuff.hlp' _|\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/|_ >Now with added Spectral Density!< -|/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\|- Don't forget the playback facility (try BSTANDRD < PLAYBACK.DAT after a run of STANDARD) SHAR_EOF fi # end of overwriting check if test -f 'playback.dat' then echo shar: will not over-write existing file "'playback.dat'" else cat << SHAR_EOF > 'playback.dat' 1 .1 6 0 10 7 1d-8 8 1 2 8 1 3 1 4 0 7 0 4 6 9 10 15 y 1 3 1 2 1 1 y 0 7 2 48 8 0 100 11 z y SHAR_EOF fi # end of overwriting check if test -f 'safeio.f' then echo shar: will not over-write existing file "'safeio.f'" else cat << SHAR_EOF > 'safeio.f' C***+****|****+****|* COPYRIGHT J D PRYCE 1998 **|****+****|****+****|** module SAFEIO logical:: PLAYBK=.FALSE. integer, parameter:: IPBK=19 contains C***+****|****+****|**SAFEIO package***|****+****|****+****|****+****|** C Simple 'secure, abortable interactive input' routines C C The following are logical functions which return values through C the argument list and also C either C .TRUE. through the function name meaning 'successful input' C and the input value(s) through its (first) argument C or C .FALSE. through the function name meaning 'aborted by user' C The routines are C GETI(X) - get one Integer value X C GETR(X) - get one Real value X C GETIR(X,XLO,XHI) - get one Integer value X in a Range C GETRR(X,XLO,XHI) - get one Real value X in a Range C GETIS(X,NX) - get NX integer values into array X C GETRS(X,NX) - get NX real values into array X C C The user is to signal 'abort' by typing z or Z (followed by Enter) C C The following is a non-abortable routine requiring a yes/no answer C YESNO() - character*1 function, returns either 'y' or 'n' C The following non-abortable routine waits for ENTER to be pressed C SPAUSE() C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine OPNPBK integer IOERR open(IPBK,file='playback.dat', status='REPLACE', action='WRITE', + iostat=IOERR) if (IOERR.eq.0) then PLAYBK = .TRUE. else write(*,*) 'Unable to open playback-file unit',IPBK, + ', file playback.out, IOSTAT=',IOERR write(*,*) 'It may be in use by another process?' PLAYBK = .FALSE. call SPAUSE end if end subroutine OPNPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine CLOPBK close(IPBK) end subroutine CLOPBK C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETI(X) implicit none C .. Scalar Arguments .. integer X character*80 LINE C 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETI = .FALSE. else read (LINE,FMT=*,ERR=30) X GETI = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 end function GETI C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETR(X) implicit none C .. Scalar Arguments .. double precision X character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETR = .FALSE. else read (LINE,FMT=*,ERR=30) X GETR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Real value required, please retype: '')') go to 10 end function GETR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIR(X,XLO,XHI) implicit none C .. Scalar Arguments .. integer X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIR = .FALSE. else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETIR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') go to 10 end function GETIR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRR(X,XLO,XHI) implicit none C .. Scalar Arguments .. double precision X,XHI,XLO C .. character*80 LINE C .. 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRR = .FALSE. else read (LINE,FMT=*,ERR=30) X if (X.lt.XLO .or. X.gt.XHI) go to 40 GETRR = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT= + '(1x,''***Integer value required, please retype: '')') go to 10 40 write (*,FMT=45) XLO,XHI 45 format(1x,'***Not in range',i9,' :',i9,', please retype: ') go to 10 end function GETRR C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETIS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. integer X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETIS = .FALSE. else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETIS = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Integer values required, please retype from item',i2,': ') go to 10 end function GETIS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** logical function GETRS(X,NX) implicit none C .. Scalar Arguments .. integer NX C .. C .. Array Arguments .. double precision X(NX) C .. C .. Local Scalars .. integer I character*80 LINE C .. I = 1 10 read (*,FMT='(a)',ERR=30) LINE if (PLAYBK) write(IPBK,'(a)') TRIM(LINE) if (LINE(1:1)=='z' .or. LINE(1:1)=='Z') then GETRS = .FALSE. else read (LINE,FMT=*,ERR=30) (X(I),I=I,NX) GETRS = .TRUE. end if return 30 write (*,ADVANCE='NO',FMT=35) I 35 format + ('***Real values required, please retype from item',i2,': ') go to 10 end function GETRS C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** character*1 function YESNO(ASK) implicit none character*(*) ASK C .. Local Scalars .. character YN C .. write(*,'(a)',advance='NO') ASK 10 read (*,FMT='(a)',END=40,ERR=30) YN if (PLAYBK) write(IPBK,'(a)') YN if (YN.eq.'y' .or. YN.eq.'Y') then YESNO = 'y' else if (YN.eq.'n' .or. YN.eq.'N') then YESNO = 'n' else go to 30 end if return 30 write (*,ADVANCE='NO', + FMT='(1x,''***Please type one of y,Y,n,N: '')') go to 10 40 write (*,*) 'Don''t use end-of-file,', + ' it means end of run in most F90 & some F77 systems' write (*,*) 'Sorry!' stop end function YESNO C***+****|****+****|****+****|****+****|****+****|****+****|****+****|** subroutine SPAUSE write (*,ADVANCE='NO',FMT='(a)') 'Press ENTER to continue' read (*,FMT=*,END=100,ERR=100) 100 return end subroutine SPAUSE C***+****|****+****|****end of SAFEIO package****|****+****|****+****|** end module SAFEIO SHAR_EOF fi # end of overwriting check if test -f 'sample.lst' then echo shar: will not over-write existing file "'sample.lst'" else cat << SHAR_EOF > 'sample.lst' Contents of Test Set sample No. 1:Simple equation -u" = lambda u No parameters No. 2:transformed -u''=lambda u Parms NU, must be >0 No. 3:Branko Curgus2: -y''=lambda x y on [-1,1] No parameters No. 4:-u''=lambda u with a lambda-dependent BC Parms A1', A2' where (A1+lam*A1')u(a)=(A2+lam*A2')pu'(a) No. 5:Branko Curgus4: -(sign(x)y')'=lambda sign(x) y on [-1,1] No parameters No. 6:Klaus 1: -(y'/2)'+(x^2/8(x<0),x^2/2(x>=0)y = lambda y No parameters No. 7:Simple equation -u" = lambda u with u = A1*x+A2 near 0 No parameters No. 8:Another transformed version of Hinz problem