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 kn