INIT.csh000755 000311 000121 00000004762 06070006525 012146 0ustar00krivecf1000000 000000 #!/bin/csh -f # # Benchmark bm_a. # # Initialization file. Distributes all files, compiles and links main programs. # This file contains explicitly: # Names of main programs # Symbols referring to DIMENSION declarations # All files should initially be on the present directory; subdirectories # will be created. # # Master files are on marvin.ijs.si. # This file and other files can be edited on other machines, # and PACK.csh must then be used to repack them (includes the # node name where it was repacked). # # To edit (customization on a specific node): # library name ($lib) # compiler command # loader command # the last line of comment here # # R. Krivec 95/09/21. # R. Krivec 95/10/02. # # This file customized for: Convex. # ----------------------------------------------------------------------------- echo '---- Start INIT.csh:' set here = $cwd if ( $1 == 'C' ) goto _COMPILE if ( $1 == 'L' ) goto _LINK if ( -f pro || -l pro ) exit if ( -f inp || -l inp ) exit if ( -f out || -l out ) exit if ( ! -e pro ) mkdir pro # for programs if ( ! -e inp ) mkdir inp # for inputs if ( ! -e inp ) mkdir out # for outputs echo "---- Unpacking files..." tar xvf m2mk_pack.tar # Unpack sources tar xvf ewf2n_pack.tar tar xvf av3mj_pack.tar echo "---- Moving files..." mv *.f pro # Move (*.tar remain) mv *.i inp # mv m2m*.csh ewf2*.csh av3m*.csh inp # chmod +x inp/*00*.csh # make executable _COMPILE: echo "---- Compiling..." cd $here cd pro set lib = ol_O2 # Name of object library fc -c -O2 -vn *.f >&! fc_all_${lib}.l # Compile ar rv $lib.a *.o # Put into archive ar dv $lib.a m2mk.o ewf2n.o av3mj.o # Don't need main programs in archive ranlib ${lib}.a # Randomize _LINK: echo "---- Linking..." cd $here cd pro set pro = m2mk # Link program set eex = "40p0_${lib}" fc ${pro}.o ${lib}.a -Mhl -o ${pro}.e${eex} >! ${pro}.m${eex} set pro = ewf2n # Link set eex = "40p0s_${lib}" fc ${pro}.o ${lib}.a -Mhl -o ${pro}.e${eex} >! ${pro}.m${eex} set pro = av3mj # Link set eex = "${lib}" fc ${pro}.o ${lib}.a -Mhl -o ${pro}.e${eex} >! ${pro}.m${eex} cd .. if ( $cwd != $here ) echo "---- Where am I?" echo '---- End INIT.csh.' PACK.csh000755 000311 000121 00000002433 06033752435 012121 0ustar00krivecf1000000 000000 #!/bin/csh -f # # Packs all files to be transferred somewhere else. # When unpacked, INIT.csh can be run immediately. # # Program source files are repacked into a single tar file, thus # preserving any changes made to adapt to a specific machine, but # also preserving the orignal m2m...tar, etc, files. # # R. Krivec 95/09/21. # R. Krivec 95/10/02. # Convex. # ----------------------------------------------------------------------------- echo '---- Start PACK.csh:' echo '---- Including machine name into tar file name.' echo '---- Updated *.csh, *.i files are packed. The originals are lost.' echo '---- Updated source programs are tar-ed into a separate file first.' cp inp/*.csh . # update (destroy originals) cp inp/*.i . # update (destroy originals) tar cvf sources_`hostname`.tar pro/*.f # save updated sources separately if ( -e PACK_bm_a_`hostname`.tar ) \ mv PACK_bm_a_`hostname`.tar PACK_bm_a_`hostname`.tar.old # save original file just in case tar cvf PACK_bm_a_`hostname`.tar \ README.txt *.csh *.i *_pack.tar sources_`hostname`.tar # new echo '---- File is: ' ll PACK_bm_a_`hostname`.tar echo '---- End PACK.csh.' README.txt000644 000311 000121 00000001411 06070004217 012357 0ustar00krivecf1000000 000000 -------------------------------------------------------------------------------- Benchmark bm_a R. Krivec 95/09/21 R. Krivec 95/12/26 -------------------------------------------------------------------------------- He atom m2mk: Km = 40 ewf2n: Km = 24, E only. -------------------------------------------------------------------------------- To run: tar xvf PACK_bm_a.tar (presumably done already) -- edit INIT.csh -- -- edit m2m*.csh, ewf*.csh, av3*.csh -- INIT.csh RUN.csh To repack and carry to another location: PACK.csh -------------------------------------------------------------------------------- Corrected m2mk (3.0). RUN.csh000755 000311 000121 00000000553 06030231166 012036 0ustar00krivecf1000000 000000 #!/bin/csh -f # # Executes the sample run. Can be submitted to batch. # R. Krivec 95/09/21. # cd inp # This file should be in the initial directory source m2mk1a.csh # Matrix elements source ewf2n1a.csh # Find eigenvalue, calculate wave function, # calculate expectation values av3mj_pack.tar000644 000311 000121 00001344000 06070003102 013404 0ustar00krivecf1000000 000000 av3mj.f000644 000311 000121 00000234337 06067757604 012114 0ustar00krivecf1000000 000000 PROGRAM AV3MJ IMPLICIT REAL*8 (A-H, O-Z) C C C ****************************************************************** C * ERROR IN MODIFIED WEIGHTS (GAUSSIAN WEIGHTS OK). * C * NGO- = 0: NOT IMPLEMENTED FOR MODIFIED WEIGHTS. SEE ABOVE. * C * WF NORM CORRECTED 92/10/20. * C * Z0MG TO Z0UG 93/12/15. * C * WAL DIMENSION IS TOO LARGE BUT HARMLESS. * C ****************************************************************** C C ------------------------------------------------------------------ C C INPUT: C THE CFHHM WAVE FUNCTION EXPANSION COEFFICIENTS (EWF2-). C OUTPUT: C EXPECTATION VALUES OF C IDENTITY OPERATOR; C R(K)**P-TYPE OPERATORS; C HAMILTONIAN OPERATOR; C DELTA FUNCTION OPERATORS DELTA(R(K)). C (NORMALIZED) WAVE FUNCTION AT THE THREE COALESCENCE POINTS. C TABULATED CHI OR FULL WAVE FUNCTION AT SPECIFIED POINTS (WT3-) C (FOR PLOTTING AND CALCULATING POINTWISE DIFFERENCES OF CHI OR C PSI). C METHOD: C NUMERICAL (GAUSSIAN OR MODIFIED-WEIGHT GAUSSIAN) QUADRATURE. C C ------------------------------------------------------------------ C C C SHORT NOTES ON USAGE C C 1. RUN M2M- FOR MATRIX ELEMENTS. C 2. RUN EWF2- FOR CHI/WAVE FUNCTION. C 3. RUN THIS PROGRAM FOR AVERAGES AND W. F. AT R(K) = 0. C 3.1. RUN AV3CP- FOR STICKING ETC. C 3.2. RUN PLA3M- FOR PLATEAU VALUES OF AVERAGES. C 3.3. RUN PLWCM- FOR W. F. AT R(K) = 0 (PLOTTING ETC.) C 4. RUN THIS PROGRAM FOR W. F. TABULATION OR CHI OUTPUT. C 4.1. RUN AV??- FOR CHI COMPARISON (NEEDS 3.) C 4.2. RUN AV3X- FOR W. F. COMPARISON (NEEDS 3., 3.2.) C C C SOME INPUT CONTROL PARAMETERS C C UNNDEL: IF .TRUE., UNNNORMALIZED DELTA(R(K)) AVERAGES WILL BE C PRINTED (NOUT), ALLOWING NORMALIZATION USING A C PREVIOUS RUN IN WHICH NORMALIZATION WAS CALCULATED C (IF UNNDEL = .TRUE., A VERY SMALL NUMBER OF A, LAMBDA C GAUSSIAN POINTS CAN BE USED). C NORMAL: .FALSE. C C UNNAVE: IF .TRUE., DO NOT NORMALIZE AVERAGES (USEFUL FOR C TESTING QUADRATURE, ESPECIALLY ON SEPARATE (A,LAMBDA) C REGIONS. C C LNCOAL: IF .TRUE., NORMALIZE PSI(0,S) USING Q(1). THIS IS C MEANINGLESS IF Q(1,Z) HAS PLATEAUX. C C LCONVR: CONVERT TO ANOTHER MASS UNIT AVERAGES, BUT NOT C IDENTITY AVERAGE. C C C TESTING OPTIONS C C LTESTQ: CALCULATE QUADRATURES WITH FUNCTION 1, I.E., C ONLY THE WEIGHTS ARE INTEGRATED (SEE A5QZ-). C C LHHQ: CALCULATE TEST INTEGRALS OF HH AND HH**2 FOR THE C FIRST Z VALUE ENCOUNTERED. C C LHHQX: EXIT AFTER LHHQ TEST. C C C SOME OUTPUT PARAMETERS C C WN0: = N**2 / N(PROG) AS DEFINED BELOW. USE WITH Q(1) C PLATEAU VALUE (PLA3M-) TO GET NORMALIZED W. F.: C NORM. W. F. = W. F. / SQRT(WN0 * Q(1,PLATEAU)). C C C SOME WORKING PARAMETERS C C XCUW: CONVERTS THE NORMALIZED WAVE FUNCTION TO ANOTHER C MASS UNIT. (BEFORE AND AFTER CONVERSION, THE SAME C WN0 AND Q(1,PLATEAU) IN THE FORMULA C NORM. W. F. = W. F. / SQRT(WN0 * Q(1,PLATEAU)) C ARE USED.) C C C NOTES ON USAGE C C EXPECTATION VALUES IN CFHHM MAY DIVERGE AS FUNCTIONS OF THE C UPPER BOUND OF THE Z-QUADRATURE, I.E., HAVE PLATEAUX AS C FUNCTIONS OF THE UPPER BOUND. THE PLATEAU VALUES MUST BE C EXTRACTED BY A SUBSEQUENT PROGRAM (PLA3M-). THIS IS ALSO TRUE C FOR THE NORMALIZATION (IDENTITY) INTEGRAL. THEREFORE ABSOLUTE C NORMALIZATION OF THE WAVE FUNCTION CANNOT BE DETERMINED BY C THIS PROGRAM EXCEPT IF ONE KNOWS IN ADVANCE THAT THE C EXPECTATION VALUES CONVERGE.) C C NORMALIZATION OF EXPECTATION VALUES IS DONE ON EACH Z-INTERVAL C BEFORE LOOKING FOR PLATEAUX IN THE NORMALIZED RESULT (BY C ANOTHER PROGRAM, E.G. PLA3M-). NORMALIZATION OF WAVE FUNCTIONS C ETC. IS DONE BY FIRST EXTRACTING THE PLATEAU VALUE OF Q(1) C (SEE ABOVE). C C UNNORMALIZED DELTA(R(K)) EXPECTATION VALUES AND WAVE FUNCTIONS C AT COALESCENCE POINTS CAN BE CALCULATED QUICKLY WITH 2 C GAUSSIAN POINTS PER A, LAMBDA INTERVAL. C C RESULTS CAN BE CONVERTED TO ANOTHER MASS UNIT (DIFFERENT C FROM THE ONE USED TO CALCULATE MATRIX ELEMENTS IN M2M-). C C C C NORMALIZATION OF NUMERICAL INTEGRALS AND FUNCTIONS: C C HYPERRADIAL VOLUME ELEMENT IS Z*DZ, WHICH IS PROPORTIONAL TO C RHO**5*D(RHO) * RHO**-4, C WHERE Z = 2 SQRT(2 E) AND THE RHO**-4 FACTOR APPEARS BECAUSE C OF THE DEFINITION OF THE WAVE FUNCTION CALCULATED BY EWF2-. C (RHO**-2 IS FACTORIZED FROM THE FULL WAVE FUNCTION BEFORE THE C HH EXPANSION.) C C HYPERANGULAR VOLUME ELEMENT IS SIN(2A) DA D(LAMBDA), AND THE C FACTOR PI**2/2 IS NOT INCLUDED. C C THE HH ARE NORMALIZED. C C THE NORMALIZATION OF EXPECTATION VALUES IS THEREFORE NOT C DEFINED AT INTEGRATION TIME. AFTER INTEGRATION, THEY ARE C DIVIDED BY THE IDENTITY OPERATOR AVERAGE FOR EACH SEPARATE C UPPER Z BOUND OF INTEGRATION. (DIVISION MUST BE PERFORMED C BEFORE INCREASING THE UPPER Z BOUND BECAUSE OF PLATEAUX.) C C THE NORMALIZATION INTEGRAL IS CALCULATED WITH THE ABOVE C VOLUME ELEMENTS AND IS LEFT UNCHANGED (EVEN IF MASS UNIT IS C CHANGED). C C ABSOLUTE NORMALIZATION, E.G. OF WAVE FUNCTIONS, IS C CALCULATED SEPARATELY TAKING INTO ACCOUNT THE ABOVE VOLUME C ELEMENTS (SEE BELOW). C C C C DEFINITION OF THE DELTA FUNCTION OPERATOR: C C DELTA(R(K)) --> C C 8 -3/2 DELTA(A - PI/2) DELTA(LAMBDA - LAMBDA(K)) C --- (2 KAPPA(K)) ----------------------------------------- C PI 3 C RHO SIN(2 A) C C WHERE LAMBDA(K) = PI - OMEGA(K), AND INTEGRAL OVER THE A C VARIABLE IS 1, NOT 1/2. (THE PREVIOUS VERSION USED THE FACTOR C (8 / PI) (2**-3/2) ONLY, WITHOUT THE KAPPA(K)**-3/2.) C CONVERSION OF UNITS: IF THE RESULTS ARE TO BE CONVERTED TO C DIFFERENT ATOMIC UNITS, BOTH KAPPA AND RHO HAVE TO BE C CONVERTED, GIVING THE ADDITIONAL FACTOR OF (M0 / M1)**3, C WHERE M0 IS THE MASS UNIT OF THE INPUT TO THIS PROGRAM, AND M1 C IS THE MASS UNIT CONVERSION IS MADE TO. C C C DEFINITION OF THE NORMALIZED WAVE FUNCTION C C PSI(N;R,S) = PSI(R,S) / N C C WHERE R AND S ARE THE LENGTHS OF JACOBI COORDINATES C (NOT INCLUDING ANY MASS FACTORS; INTEGRATION VOLUME IS C D**3 R D**3 S). IF THE TOTAL WAVE FUNCTION IS DEFINED AS C PSI = EXP(F) WF / RHO**2, C WHERE F IS THE CORRELATION FUNCTION, AND WF IS THE HH-EXPANDED C PART OF THE W. F. AS CALCULATED BY EWF2-, THEN C C 2 C 2 PI -3/2 N(PROG) C N = --- (MU(K) MM(K)) ---------------- C 2 2 C (2 ROOT(2 E)) C C WHERE MU(K) IS THE K-TH PAIR REDUCED MASS, MM(K) IS THE C REDUCED MASS OF THE K-TH PARTICLE AND K-TH PAIR, AND N(PROG) C (= Q(1)) IS THE EXPECTATION VALUE OF IDENTITY AS CALCULATED BY C THIS PROGRAM (SEE VOLUME ELEMENTS ABOVE). PSI HAS UNITS C M0**-3. THIS NORMALIZATION DEPENDS ON THE A, LAMBDA GAUSSIAN C QUADRATURE VIA N(PROG). IF N(PROG) DIVERGES (HAS PLATEAUX), N C MAY BE IMPOSSIBLE TO CALCULATE IN THIS PROGRAM. C C C WAVE FUNCTION AT THE THREE COALESCENCE POINTS C C PSI(N;0,S); PSI(0,S) C C THE NORMALIZATION OF PSI(0,S) IS NOT DONE IF LNCOAL = .FALSE., C (USE IF N(PROG) HAS PLATEAUX). THE OUTPUT VALUES ARE C ACCOMPANIED BY THE VALUES OF S IN A.U. C C THE WAVE FUNCTION VALUES AT COALESCENCE POINTS ARE OUTPUT AS C DIRECTED BY IZWFN, IZWFS; IT IS RECOMMENDED, IF THE VALUES ARE C TO BE USED FOR COMPARISONS OF CONVERGENCE ETC. (OR IN PROGRAM C PLWCM- FOR PLOTTING), TO USE IZWFN = LARGE, IZWFS = 1, AND C LNCOAL = .FALSE., WITH 2 GAUSSIAN POINTS PER ANGULAR INTERVAL, C AND ENOUGH GAUSSIAN POINTS IN THE Z DIRECTION. C C C UNNORMALIZED WAVE FUNCTION OUTPUT C C VALUES CAN BE OUTPUT (INPUT PARAMETER LTESTW) AT SELECTED A, C LAMBDA GLOBAL POINT NUMBERS (IAXT, ILXT) WITH THE WINDOWS C (IAXTD, ILXTD), SELECTED Z INTERVALS (IIT, WINDOW IITD), AND C SELECTED Z POINT NUMBERS ON EACH INTERVAL (IZT, WINDOW IZTD). C THEY ARE ALSO OUTPUT AT COALESCENCE POINTS, BUT ONLY IF THE C Z VALUES SELECTED BY IZWFN, IZWFS MATCH THOSE SELCTED BY IZT, C IZTD. (USED FOR INVESTIGATING THE VICINITY OF COALESCENCE C POINTS BEFORE THE TABULATION OPTION WAS AVAILABLE.) C C C INTEGRATION OPTIONS: C C R(K)**P OPERATORS: C LRGAUS = .TRUE.: GAUSSIAN WEIGHTS IN ALL REGIONS. C .FALSE.: MODIFIED WEIGHTS IN SINGULAR REGIONS. C HAMILTONIAN TERMS: C LHGAUS = .TRUE.: GAUSSIAN WEIGHTS IN ALL REGIONS. C .FALSE.: MODIFIED WEIGHTS IN SINGULAR REGIONS. C (ALL TERMS OF H HAVE TO USE THE SAME SETS OF WEIGHTS C IN A REGION, IN ORDER TO GUARANTEE THE VARIATIONAL C PROPERTY.) C (SEE IOTAA, IOTLA FOR OPERATOR/SINGULAR REGION TABLES.) C THESE OPTIONS SHOULD HELP IN TESTING PARAMETERS. C C C (A, LAMBDA) QUADRATURE GRID: C C THE GAUSSIAN POINTS ARE ALWAYS FIXED (BUT CHECK THE ROLE OF C ARRAY XAM). THE GAUSSIAN ABSCISSAS AND WEIGHTS ARE STORED C SEPARATELY FOR DIFFERENT SEGMENTS AND REGIONS, TO FACILITATE C ADDRESSING, ALTHOUGH SUCH STORAGE LEAVES UNUSED SPACE IF THE C CORRESPONDING DIMENSIONS ARE TOO LARGE. THE MODIFIED WEIGHTS C FOR LAMBDA DEPEND ON BOTH A AND LAMBDA AND NEED MUCH MORE C SPACE. THEREFORE ALL THE MODIFIED WEIGHTS ARE STORED BY GLOBAL C POINT NUMBERS WHICH GENERALLY REQUIRES LESS SPACE THAN C SEGMENT-WISE STORAGE, AS IT LEAVES NO INTERMITTENT SPACE IN C ARRAYS. (THESE GLOBAL POINT NUMBERS RUN THROUGH THE SINGULAR C REGIONS ONLY.) ALSO, THE MODIFIED WEIGHTS DEPEND ON THE TYPES C OF SINGULARITY. THEY ARE STORED ONLY ONCE FOR EACH TYPE, AND C WHEN REFERRED TO IN THE PROGRAM, THE POINT COUNTS AND THE C TYPES OF SINGULARITY ARE PROVIDED BY POINTER TABLES; THESE C TABLES THEREFORE TELL FROM WHICH SET OF MODIFIED WEIGHTS THE C WEIGHTS ARE TAKEN, FOR A GIVEN OPERATOR, REGION, ETC. THIS C SAVES SPACE; EXPLICIT CONSTRUCTION OF FULL MODIFIED GRIDS C FOR EACH OPERATOR ETC. WOULD TAKE MUCH MORE SPACE. C C THE QUANTITIES XKAPPA, XOMEGA ARE TRANSFERRED FROM THE MATRIX C ELEMENT PROGRAM (M2M-). NGOA ETC. FROM THE MATRIX ELEMENT C PROGRAM ARE CALLED NGOA0, ETC. HERE, AND ARE INDEPENDENT OF C NGOA, ETC. C C C INTERVAL HIERARCHY: C C REGION, SEGMENT, POINT (FOR A, LAMBDA). C INTERVAL GROUP, INTERVAL, SEGMENT, POINT (FOR Z). C C C ARRAY INDEXING FOR CERTAIN ARRAYS (P: POINT, S: SEGMENT, I: C INTERVAL, R: REGION, O: OPERATOR, T: TERM; COMPOSITE INDICES, C WHICH MAY NOT BE CONTIGUOUS, ARE IN BRACKETS): C VARIABLE A: C XA(P,S,R), WA(P,S,R) (P RUNS INSIDE SEGMENT, ETC.); C WAMS(P) (P - GLOBAL POINT COUNT IN SINGULAR REGION). C VARIABLE LAMBDA: C XL(P,S,(R,RA)), WL(P,S,(R,RA)) (RA - A REGION); C WLMS(P,PA,KK)) (PA - A POINT, KK - TYPE OF SINGULARITY). C (WLMS IS STORED WELL FOR GWLMB, BUT BAD FOR AV2QWA.) C VARIABLE Z: C XZ1(P,3), WZ1(P,3); C XZ(P,I), WZ(P,I) (P RUNS ACROSS SEGMENT BOUNDARIES, C I - INTERVAL COUNT WITHIN GROUP). C VARIABLES (A, LAMBDA): C R(K,PL,PA), K = 1,2,3. NOTE THAT PL (LAMBDA-POINT) RUNS C OVER DIFFERENT SETS OF VALUES ACCORDING TO WHETHER C A IS IN NONSINGULAR OR SINGULAR REGION. C WAVE FUNCTION: C DD(NDS,NDKX,NDMA), DDY(NDKX,NDMA,6): THESE TWO ARRAYS C HAVE THE INDEX CORRESPONDING TO THE DIMENSION NDKX C RAISED BY 1 WITH RESPECT TO THE CORRESPONDING ARRAYS C IN HYPWF, TO ACCOMODATE THE Z**0 POWER IN SECOND C DERIVATIVE. (INDEX 1 CORRESPONDS TO POWER 0.) C (THIS APPLIES ALSO TO OTHER ARRAYS WITH DIMENSION NDKX.) C C C C DIMENSIONS AND OTHER PARAMETER CONSTANTS: C NDMU - MAXIMUM K/2+1 IN HH STATES. C ISYM - MUST BE EITHER 0 OR 1; IF 0, DIMENSION NDS WILL BE C DEFINED TO ACCEPT ALL STATES; IF 1, NDS FOR C COSINE-HH STATES ONLY WILL BE DEFINED. NOT THAT IN C EWF2-, ISMN HAS DIFFERENT DIMENSIONS THAN CV ETC., C BECAUSE OF M2WRDA REDUCTION; HERE THE DIMENSIONS MAY C BE THE SAME BECAUSE ARRAYS ARE READ IN FROM FILE. C NDCN - MAX. NUMBER OF SERIES TERMS IN Z (SEE NM, JMAX). C NDGO - MAXIMUM GAUSS ORDER IN SEGMENT. C NDSI - MAXIMUM NUMBER OF SEGMENTS IN A REGION. C NDPA, NDPL - MAX. NUMBERS OF QUADRATURE POINTS IN A AND LAMBDA C VARIABLES. TO SAVE SPACE, THESE PARAMETERS MAY BE C LESS THAN THE SUMS OF DIMENSIONS FOR SEGMENT LENGTHS C (SEE NDGO, NDSI). ALTERNATIVELY, THEY COULD BE C DEFINED AS C NDPA = NDGO * NDSI * 2, C NDPL = NDGO * NDSI * 10. C NDPAS, NDPLS - MAX. NUMBERS OF QUADRATURE POINTS IN SINGULAR C REGIONS. TO SAVE SPACE, THESE PARAMETERS MAY BE LESS C THAN THE SUMS OF DIMENSIONS FOR SEGMENT LENGTHS (SEE C NDGO, NDSI). ALTERNATIVELY, THEY COULD BE DEFINED AS C NDPAS = NDGO * NDSI, C NDPLS = NDGO * NDSI * 6. C NDIGR - MAX. NUMBER OF INTERVALS IN INPUT GROUP. C NDINT - MAX. NUMBER OF INTERVALS. C NDQWF - MAX. NUMBER OF Z VALUES OUTPUT FOR W.F. AT C COALESCENCE POINTS. C NDFPAR, NDVPAR - MAX. NUMBER OF PARAMETER TRIPLES IN C CORRELATION FUNCTION AND POTENTIAL. HAS TO BE C CORRECT. C NDP0 - MAX. NUMBER OF POWERS IN C. F. AND POTENTIAL C EXPANSIONS. ARRAYS F, V ARE NOT READ INTO THIS C PROGRAM BY M1PIO-, BUT M1PIO- TESTS ITS VALUE C INTERNALLY, THEREFORE IT MUST BE SUCH AS IF TO C ACCOMODATE THE F THAT M2M- WOULD CALCULATE. C NOTE THAT F IS CALCULATED BY THIS PROGRAM AFTER C THE M1PIO- CALL IF MODF = 2 (EXACT CUSPS). C NDOPR - MAX. NUMBER OF R(K)**P-TYPE OPERATORS. C NDOPD - MAX. NUMBER OF DELTA(R(K))-TYPE OPERATORS. C NDOPH - MAX. NUMBER OF HAMILTONIAN TERM-TYPE OPERATORS. C NOPR - NUMBER OF R(K)**P-TYPE OPERATORS. C NOPD - NUMBER OF DELTA(R(K))-TYPE OPERATORS. C NOPH - NUMBER OF HAMILTONIAN TERM-TYPE OPERATORS. C C CHARACTER NAME*6, VERS*66 DATA NAME / 'AV3MJ' /, VERS / ' & 2.0, 95/05/16. -I 2.0; -H 3.4C... & ' / C ------------------------------------------------------------------ C C PARAMETER (NIN = 1, NOUT = 2, NOUT1 = 3, NOUT2 = 4, NOUTB = 20, 1 NINT = 11, NOUTP = 12, NOUTP1 = 13) PARAMETER (NDMU = 25, ISYM = 0, 1 NDFPAR = 10, NDVPAR = 10, NDP0 = 104, NDCN = 22, 2 NDGO = 16, NDSI = 4, NDIGR = 11, NDINT = 1000, 3 NDQWF = 40000, 4 NDPL = 640, NDPA = 128, 5 NDPLS = 384, NDPAS = 64, 6 NDOPR = 13, NDOPD = 3, NDOPH = 8) C PARAMETER (NDS = (1 - ISYM) * (NDMU * (NDMU + 1) / 2) 1 + ISYM * (((NDMU + 1) / 2) ** 2), 2 NDMA = NDMU, 3 NDKX = (NDCN - 1) + 2 * (NDMU - 1) + 2 + 1, 4 NDWKV = NDVPAR / 2, 5 NDPJ = (NDMU - 1) / 2 + 1, 6 NDGO1 = NDGO + 1, 7 NDGO2 = (NDGO + 1) / 2, 8 NDGO1Z = NDGO / 2 + 2, 9 NDQSI = NDGO * NDSI, A NDOP = NDOPR + NDOPD + NDOPH, B NDOPRH = NDOPR + NDOPH, C NDOPR1 = NDOPR - 1) C C C ACTUAL NUMBERS OF OPERATORS (USED IN LOOPS): PARAMETER (NOPR = 13, NOPD = 3, NOPH = 8) PARAMETER (NOP = NOPR + NOPD + NOPH) C C C GENERAL: LOGICAL LTEST, LTESTW, LTAB, LRGAUS, LHGAUS, LERROR DIMENSION ITITLE(20) CHARACTER*20 IOPER(NDOP), IOPERD, IOPERT, IOPERH C INPUT PARAMETERS: LOGICAL LPCFC, LPVC, PSYM DIMENSION FPAR(3,NDFPAR), VPAR(3,NDVPAR), F(3,NDP0), V(3,NDP0), 1 FANA(3,3), WKV(3,NDWKV), 2 NGOA0(2), NSUBA0(2), NGOL0(10,2), NSUBL0(10,2), 3 XOMEGA(3), XKAPPA(3), ISMN(2,NDS) C WAVE FUNCTIONS: LOGICAL LTWFIN DIMENSION CVL(NDS), CVR(NDS), PCV(NDS,NDMA), CN(NDS,NDS,NDCN), 1 DD(NDS,NDKX,NDMA), DDY(NDKX,NDMA,6), WFCY(NDCN,6), 2 WFC(NDS,NDCN,NDIGR) C GAUSSIAN QUADRATURE: LOGICAL LPWA, LPWL, LPAL, LPGA, LPGL, LPG, LPZ0, 1 LTESTQ, LTESTR DIMENSION NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2), 1 NGOZ(3), NSUBZ(3), NPLX(2), 2 XA(NDGO,NDSI,2), WA(NDGO,NDSI,2), 3 XL(NDGO,NDSI,20), WL(NDGO,NDSI,20), XSING(3), 4 XAM(NDGO), WAMS(NDPAS), XLM(NDGO), 5 WLMS(NDPLS,NDPAS,2), 6 XZ1(NDQSI,3), WZ1(NDQSI,3), NQZ1(3), 7 XZ(NDQSI,NDIGR), WZ(NDQSI,NDIGR), 8 AG1(NDGO), WG1(NDGO), S(NDGO,NDGO), INDEX(NDGO,2) C ************ REAL*16 P(NDGO1), PZ(NDGO1Z), AG(NDGO2), WG(NDGO2), 1 WK1Q(NDGO,NDGO), WK2Q(NDGO) C ************ C HH: LOGICAL LPJY DIMENSION ARGA(NDPA), ARG1A(NDPA), PJ(NDPA,NDPJ), 1 YA(NDS,NDPA), YAA(NDS,NDPA), 2 ARGL(NDPL,2), YL(NDS,NDPL,2), YLL(NDS,NDPL,2), 3 WK1(NDPL,NDMU,2), WK2(NDPL,NDMU,2), WKY(NDS,4) C AUXILIARY: LOGICAL LPCF, LPVF, LCONVR, LCONVH, LHHQ, LHHQX DIMENSION Z0MX(NDIGR), Z0PX(NDIGR), Z0UG(NDINT), 1 INTA(NDIGR), INTR(NDIGR), INTG(NDINT), 2 ZDP(NDQSI,NDCN), ZDPX(NDCN,2), ZDPL(NDQSI,NDKX,NDMA), 3 WPSZ(NDQSI), RHO(NDQSI), RHOP(NDQSI,4), 4 CF(NDQSI), CFR(NDQSI), CFRR(NDQSI), 5 CFA(NDQSI), CFAA(NDQSI), CFL(NDQSI), CFLL(NDQSI), 6 VF(NDQSI), PSA(NDPA), AUXA(NDPA), AUXL(NDPL,2,6), 7 R(3,NDPL,NDPA), RA(3,NDPL,NDPA), RAA(3,NDPL,NDPA), 8 RL(3,NDPL,NDPA), RLL(3,NDPL,NDPA), 9 RP(9,NDPL,NDPA), RPZ(NDOPR1,NDQSI), A Q(NDOP), QI(NDOP,NDINT), QN(NDOP,NDINT), WAL(NDOPRH), B QD(NDINT), QDN(NDINT), QTN(NDINT), QHN(NDINT), C ZD1(NDQSI), WF(NDQSI), WFD(NDQSI), WFA(NDQSI), D WFL(NDQSI), WFZ(NDQSI), WFZZ(NDQSI), XCUX(NDOP), E HHQ(NDOPR,NDS), HHQ2(NDOPR,NDS) C DELTA FUNCTIONS: LOGICAL UNNDEL, UNNAVE, LTESTD, LPALD, LPJYD DIMENSION ARGLD(3,2), RD(3,3), 1 PJD(NDPJ), YAD(NDS), YAAD(NDS), 2 NPLXD(2), WK1D(3,NDMU,2), WK2D(3,NDMU,2), 3 YLD(NDS,3,2), YLLD(NDS,3,2), 4 RAD(3), RAAD(3), RLD(3), RLLD(3), DC1(3) C NORMALIZED WAVE FUNCTION: LOGICAL LNCOAL DIMENSION XMC(3), RC1(3), QWF(3,NDQWF), QWFR(3,NDQWF), 1 QWFRX(3), QWFW(3,NDQWF), IZXX(3) C TABULATION: DIMENSION XMASS(3) C C ****** COMMON / REFDIM / NRDX COMMON / IO / NINX, NOUTX C ****** C C DATA ZERO, ONE, TWO, EIGHT, HALF, X15, X180 1 / 0.D0, 1.D0, 2.D0, 8.D0, 0.5D0, 1.5D0, 180.D0 / DATA IOPER(1) / ' IDENTITY' /, 1 IOPER(2) / ' R(1)' /, 2 IOPER(3) / ' R(2)' /, 3 IOPER(4) / ' R(3)' /, 4 IOPER(5) / ' R(1)**2' /, 5 IOPER(6) / ' R(2)**2' /, 6 IOPER(7) / ' R(3)**2' /, 7 IOPER(8) / ' R(1)**-1' /, 8 IOPER(9) / ' R(2)**-1' /, 9 IOPER(10) / ' R(3)**-1' /, A IOPER(11) / ' R(1)**-2' /, B IOPER(12) / ' R(2)**-2' /, C IOPER(13) / ' R(3)**-2' / DATA IOPER(14) / ' DELTA(R(1))' /, 1 IOPER(15) / ' DELTA(R(2))' /, 2 IOPER(16) / ' DELTA(R(3))' / DATA IOPER(17) / ' V' /, 1 IOPER(18) / ' -1/2 D**2/DR**2' /, 2 IOPER(19) / ' -1/2R D/DR' /, 3 IOPER(20) / ' 1/(2R**2)(4-DELTA)' /, 4 IOPER(21) / '-1/2DEL(F)+2/R DF/DR' /, 5 IOPER(22) / ' -1/2 GRAD(F)**2' /, 6 IOPER(23) / ' -(GRAD(F),GRAD)' /, 7 IOPER(24) / ' IDENTITY (H)' / DATA IOPERD / ' DISCONTINUITY' /, 1 IOPERT / ' KINETIC ENERGY' /, 2 IOPERH / ' HAMILTONIAN' / C C ****************************************************************** C INITIALIZATION SECTION. C ****************************************************************** C C ================================================================== C STATEMENT FUNCTIONS. C ================================================================== C IZREG(I, INT0) = 1 + MIN(1, I - 1) + MAX(0, MIN(1, I - INT0)) IND2(I, J, ID) = I + (J - 1) * ID C C ================================================================== C INITIALIZE. C ================================================================== C WRITE (NOUT,2000) NAME, VERS CPU0 = ZERO CALL TEMPD(CPU0, CPU1, CPUD, NOUT, .TRUE.) C C PARAMETER TESTS. IF (ISYM .LT. 0 .OR. ISYM .GT. 1) CALL ERR2(NAME, 11, 1, NOUT) IF (NOPR .GT. NDOPR) CALL ERR2(NAME, 12, 1, NOUT) IF (NOPD .GT. NDOPD) CALL ERR2(NAME, 13, 1, NOUT) IF (NOPH .GT. NDOPH) CALL ERR2(NAME, 14, 1, NOUT) IF (NOP .GT. NDOP) CALL ERR2(NAME, 15, 1, NOUT) C C COMMON PARAMETERS (FOR MATIXD). NRDX = NDGO NINX = NIN NOUTX = NOUT C C ================================================================== C INPUT PARAMETERS. C MXPLOG: A-SINGULARITIES AT LEAST X**MXPLOG LOG(X) (HIGHER POWERS C OF X WILL NOT HAVE THE LOG FACTOR). C MXPINV: LAMBDA-SINGULARITIES AT LEAST (AT SMALL Y) C X**MXPINV / SQRT(X**2 + Y**2). C RECOMMENDED VALUES: DAS = 0.1, DLS = 0.03. C XCU CONVERTS TO ANOTHER MASS UNIT: XCU = OLD M / NEW M. C ================================================================== C READ (NIN,1000) ITITLE READ (NIN,1010) LTAB READ (NIN,1010) LRGAUS, LHGAUS READ (NIN,1020) MXPLOG, MXPINV READ (NIN,1020) LGROUP READ (NIN,1040) XCU READ (NIN,1010) LCONVR, LCONVH, LHHQ, LHHQX READ (NIN,1020) (NGOA(I), I = 1,2) READ (NIN,1020) (NSUBA(I), I = 1,2) READ (NIN,1020) (NGOL(I,1), I = 1,10) READ (NIN,1020) (NSUBL(I,1), I = 1,10) READ (NIN,1020) (NGOL(I,2), I = 1,10) READ (NIN,1020) (NSUBL(I,2), I = 1,10) READ (NIN,1020) (NGOZ(I), I = 1,3) READ (NIN,1020) (NSUBZ(I), I = 1,3) READ (NIN,1032) DAS, DLS READ (NIN,1020) IZWFN, IZWFS READ (NIN,1020) IPRAVS, IPRWFS, IPRAVF READ (NIN,1010) UNNDEL, UNNAVE, LNCOAL READ (NIN,1010) LPCFC, LPVC, LPCF, LPVF READ (NIN,1010) LPJY, LPWA, LPWL, LPAL READ (NIN,1010) LPGA, LPGL, LPG READ (NIN,1010) LTEST, LTESTW, LPZ0, LTWFIN READ (NIN,1010) LTESTD, LPALD, LPJYD READ (NIN,1010) LTESTQ, LTESTR READ (NIN,1020) IAXT, IAXTD, ILXT, ILXTD, IIT, IITD, IZT, IZTD READ (NIN,1010) LERROR C IF (LGROUP .GT. NDIGR) CALL ERR2(NAME, 21, 1, NOUT) IF (IZWFN .LE. 0) CALL ERR2(NAME, 22, 1, NOUT) IF (IZWFS .LE. 0) CALL ERR2(NAME, 23, 1, NOUT) C WRITE (NOUT,2100) 1 ITITLE, LTAB, 2 LRGAUS, LHGAUS, MXPLOG, MXPINV, LGROUP, XCU, LCONVR, LCONVH, A LHHQ, LHHQX, 3 (NGOA(I), I = 1,2), 4 (NSUBA(I), I = 1,2), 5 (NGOL(I,1), I = 1,10), 6 (NSUBL(I,1), I = 1,10), 7 (NGOL(I,2), I = 1,10), 8 (NSUBL(I,2), I = 1,10), 9 (NGOZ(I), I = 1,3), A (NSUBZ(I), I = 1,3), B DAS, DLS, IZWFN, IZWFS, IPRAVS, IPRWFS, IPRAVF, C UNNDEL, UNNAVE, LNCOAL WRITE (NOUT,2110) 1 LPCFC, LPVC, LPCF, LPVF, 2 LPJY, LPWA, LPWL, LPAL, 3 LPGA, LPGL, LPG, 4 LTEST, LTESTW, LPZ0, LTWFIN, 5 LTESTD, LPALD, LPJYD, LTESTQ, LTESTR, 6 IAXT, IAXTD, ILXT, ILXTD, IIT, IITD, IZT, IZTD, 7 LERROR CALL TEMPD(CPU1, CPU2, CPUD, NOUT, .TRUE.) C C ================================================================== C INPUT HEADER AND FIRST INTERVAL DATA FROM WAVE FUNCTION FILE. THE C FIRST PART OF THE HEADER CONSISTS OF THE EWF2- PARAMETERS, THE C SECOND PART OF THE M2M- PARAMETERS TRANSFERRED BY EWF2-/MATD-. C WAVE FUNCTION DATA FOR ALL INTERVALS HAVE BEEN WRITTEN BY WFPSD-. C ================================================================== C C ------------------------------------------------------------------ C PARAMETER HEADERS. C ------------------------------------------------------------------ C C ENERGY SEARCH PARAMETERS (SEE EWF2-). EQUALITY OF INUSEL AND ISYM C (PARAMETER STATEMENT) REDUCES DIMENSIONS, BUT IS NOT REQUIRED. WRITE (NOUT,2120) CALL EPIOA(2, 0, NOUT, NOUTB, 0, 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, A, B, EPSP, TOL, DZU, 3 ZM, ZMATCH, ZTOP, NHH, 4 LMOD, ENXL, ENXU, ENXS, 5 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT) JMAX1 = JMAX + 1 IF (JMAX1 .GT. NDCN) CALL ERR2(NAME, 31, 1, NOUT) IF (INUSEL .NE. ISYM) CALL ERR2(NAME, 32, 0, NOUT) C C PASSED HEADER BY MATRIX ELEMENT PROGRAM (SEE MATD-/M1PIO-). C IPOS, PSYM IGNORED (R-BASIS). MUU0 BELONGS TO MATRIX ELEMENTS AND C IS NOT RELEVANT TO THIS PROGRAM. C F IS NOT USED HERE (POWER EXPANSION); TO CALCULATE CORREL. F. C VALUES, FANA IS USED (ANALYTIC COEFFICIENTS). C XINF IS UNDEFINED HERE. WRITE (NOUT,2130) CALL M1PIOH(0, NOUT, NOUTB, 0, 5, LPCFC, LPVC, 1 NDFPAR, NDVPAR, NDP0, NDWKV, 2 XMASS1, XMASS2, XMASS3, XINF, 3 MUU0, IPOS, PSYM, 4 IPFL, IPFU, IPVL, IPVU, IPWU, 5 FPAR, MODF, F, FANA, VPAR, MODV, V, WKV, 6 NGOA0, NSUBA0, NGOL0, NSUBL0, DAS0, DLS0, 7 IP0OFF, IP0XU, IPOFF1, IPXU1) XMASS(1) = XMASS1 XMASS(2) = XMASS2 XMASS(3) = XMASS3 C C XOMEGA, XKAPPA, NUMBER OF STATES (MM), AND MU, NU LABELS C (SEE MATD-). (MU,NU) WILL BE PRINTED OUT LATER. READ (NOUTB) XOMEGA, XKAPPA READ (NOUTB) MM IF (MM .GT. NDS) CALL ERR2(NAME, 41, 1, NOUT) READ (NOUTB) (ISMN(1,I), ISMN(2,I), I = 1,MM) WRITE (NOUT,2140) WRITE (NOUT,2300) XOMEGA, XKAPPA, MM C C ENERGY VALUE (BY EWF2-). READ (NOUTB) ENERGY WRITE (NOUT,2200) ENERGY WRITE (NOUT,2150) C C ------------------------------------------------------------------ C WAVE FUNCTION DATA (SEE WFPSD-). C ------------------------------------------------------------------ C C IINTR IS THE LAST INTERVAL IN EWF2-, IE., THE INTERVAL RIGHT OF C Z = ZMATCH. IINTL IS THE INTERVAL LEFT OF Z = ZMATCH. READ (NOUTB) IINTL, IINTR READ (NOUTB) (CVL(I), I = 1,MM) READ (NOUTB) (CVR(I), I = 1,MM) READ (NOUTB) IINT, Z0M, Z0P IF (IINT .NE. 1) CALL ERR2(NAME, 51, 1, NOUT) IF (IINTL .LT. 2) CALL ERR2(NAME, 52, 1, NOUT) IF (IINTR .LT. 3) CALL ERR2(NAME, 53, 1, NOUT) IF (LPZ0) WRITE (NOUT,2400) IINTL, IINTR IF (LPZ0) WRITE (NOUT,2410) IINT, Z0M, Z0P Z0MX(1) = Z0M Z0PX(1) = Z0P Z0UG(1) = Z0P MA = ISMN(1,MM) + 1 IF (MA .GT. NDMA) CALL ERR2(NAME, 54, 1, NOUT) DO 10 M = 1,MA READ (NOUTB) (PCV(I,M), I = 1,MM) 10 CONTINUE C C NOTE THAT NM1 IS ONLY USED AS INDEX BOUND; THIS IS DIFFERENT C FROM THE VARIABLE NMP1 IN RRLSD- WHERE NM + 2 MAY HAVE TO BE C COMPARED WITH NDCN. NM1 = NM + 1 IF (NM1 .GT. NDCN) CALL ERR2(NAME, 55, 1, NOUT) DO 14 K = 1,NM1 DO 12 J = 1,MM READ (NOUTB) (CN(I,J,K), I = 1,MM) 12 CONTINUE 14 CONTINUE IF (LTWFIN) THEN C TEST PART USED FOR W.F.(Z=0). WRITE (NOUT,8000) (PCV(1,M), M = 1,MA) WRITE (NOUT,8010) (CN(I,1,1), I = 1,MM) ENDIF C C ------------------------------------------------------------------ C CALCULATE COEFFICIENTS OF Z**K LOG(Z)**(M-1) / (M-1)!. C ASSUME THE LARGEST MU IS THE LAST MU. KX IS THE MAXIMUM POWER C OF Z ON THE FIRST INTERVAL. IT IS GIVEN BY THE RANGE OF C EXISTING CN. SECOND INDEX OF DD RAISED BY ONE TO MAKE ROOM FOR C POWER 0. (BELOW, K IS THE TRUE POWER.) C ------------------------------------------------------------------ C IF (ISMN(1,MM) + 1 .GT. NDMU) CALL ERR2(NAME, 61, 1, NOUT) KX = NM + 2 * ISMN(1,MM) + 2 IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 62, 1, NOUT) DO 30 M = 1,MA DO 22 K = 2,KX DO 20 I = 1,MM DD(I,K+1,M) = ZERO 20 CONTINUE 22 CONTINUE DO 23 I = 1,MM DD(I,1,M) = ZERO DD(I,2,M) = ZERO 23 CONTINUE DO 28 L = 1,MM K2 = 2 * ISMN(1,L) + 2 KU = NM + K2 DO 26 K = K2,KU DO 24 I = 1,MM DD(I,K+1,M) = DD(I,K+1,M) + CN(I,L,K+1-K2) * 1 PCV(L,M) 24 CONTINUE 26 CONTINUE 28 CONTINUE 30 CONTINUE CALL TEMPD(CPU2, CPU21, CPUD, NOUT, .TRUE.) C C ================================================================== C BRANCH TO TABULATION AND EXIT (WT3- MAY BRANCH TO CHI OUTPUT). C ================================================================== IF (LTAB) THEN Z0M1 = Z0M Z0P1 = Z0P CALL WT3D(NDMU, NDS, NDKX, NDMA, NDCN, NDPJ, NDVPAR, 1 XMASS, XKAPPA, XOMEGA, ISMN, 2 MM, KX, MA, JMAX, IINTR, Z0M1, Z0P1, ENERGY, 3 PCV(1,1), DD, WFC, WKY, DDY, WFCY, 4 MODF, FANA, MODV, IPVL, IPVU, VPAR, 5 NOUTB, NINT, NOUT, NOUTP, NOUTP1) CALL TEMPD(CPU21, CPU3, CPUD, NOUT, .TRUE.) CALL TEMPD(CPU1, CPUT, CPUD, NOUT, .TRUE.) CALL EXIT STOP ENDIF C C ================================================================== C ABSCISSAS AND WEIGHTS. C ================================================================== C C ------------------------------------------------------------------ C INITIALIZE QUADRATURE PARAMETERS IN THE THREE VARIABLES, C (A, LAMBDA, Z) (NO MODIFICATIONS DUE TO SINGULARITIES). C ABSCISSSAS WILL REMAIN THE SAME THROUGHOUT, WEIGHTS WILL BE C MODIFIED. (A, LAMBDA) PARAMETERS ARE STORED SEGMENT-WISE, REGION- C WISE; Z PARAMETERS ARE STORED CUMULATIVELY INTERVAL-WISE. C (SEGMENTS ARE ALSO CALLED SUBINTERVALS.) C SOME BUT NOT ALL OF NGO- MAY BE 0. C ------------------------------------------------------------------ C C A POINTS. CALL M2ARQB(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 DAS, NGOA, NSUBA, 2 P, PZ, AG, WG, LPGA, LPG, NOUT, 3 XA, WA) C C LAMBDA POINTS, FOR NONSINGULAR AND SINGULAR A-REGIONS. CALL M2LRQB(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 XOMEGA, DLS, NGOL, NSUBL, 2 P, PZ, AG, WG, LPGL, LPG, NOUT, 3 XSING, XL, WL) C C Z POINTS: CALCULATE ONLY THE GAUSSIAN PARAMETERS FOR C THE INTERVAL (-1,1), SUBDIVIDED AS THE Z INTERVALS WILL BE, C SEPARATELY FOR THE THREE Z REGIONS. THE PARAMETERS WILL BE C RESCALED LATER ON EACH INTERVAL (Z0M, Z0P). AZ1 = -ONE BZ1 = ONE DO 40 I = 1,3 CALL M1XGQA(NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 NGOZ(I), NSUBZ(I), AZ1, BZ1, 2 P, PZ, AG, WG, AG1, WG1, LPG, 3 NOUT, 4 NQZ1(I), XZ1(1,I), WZ1(1,I)) IF (LTEST) THEN NZ = NQZ1(I) WRITE (NOUT,7000) NAME, 1 I, NZ, (XZ1(J,I), WZ1(J,I), J = 1,NZ) ENDIF 40 CONTINUE IF (.NOT. (LRGAUS .AND. LHGAUS)) THEN C C -------------------------------------------------------------- C MODIFY WEIGHTS IN SINGULAR REGIONS. ONLY THE DIFFERENT C MODIFIED WEIGHTS ARE STORED, AND POINTERS TO THEM DEPENDING ON C (OPERATOR, TERM, LAMBDA-REGION) WILL BE USED. MODIFIED WEIGHTS C ARE STORED WITH CUMULATIVE (GLOBAL) POINT INDICES. C **** NGO- = 0 NOT IMPLEMENTED. **** C -------------------------------------------------------------- C C SINGULAR A REGION. IRA = 2 C C A SEGMENTS. NSA = NSUBA(IRA) NA = NGOA(IRA) IASL = 1 DO 46 ISA = 1,NSA C C MODIFY A WEIGHTS FOR THIS SEGMENT. A POINTER TABLE IS C NECESSARY TO ADDRESS WAMS. MODIFICATIONS ARE INDEPENDENT C OF LAMBDA. CALL GWAMB(NDGO, NDPAS, NA, 1 XA(1,ISA,IRA), MXPLOG, IASL, LPWA, NOUT, 1 S, INDEX, WK1Q, WK2Q, 2 XAM, WAMS) C C SINGULAR LAMBDA REGIONS. ILSL = 1 DO 44 IRL = 2,9 IF (IRL .EQ. 4 .OR. IRL .EQ. 7) GO TO 44 C C LAMBDA SEGMENTS. NSL = NSUBL(IRL,IRA) NL = NGOL(IRL,IRA) DO 42 ISL = 1,NSL IF (ILSL + NL .GT. NDPLS) 1 CALL ERR2(NAME, 71, 1, NOUT) C C MODIFY LAMBDA WEIGHTS (A IS IN SINGULAR REGION). C THE LOOP OVER A VALUES IS INSIDE GWLMB. NOTE THAT C XAM DEPENDS ON ISA (OUTER LOOP). A POINTER TABLE C IS NECESSARY TO ADDRESS WLMS. CALL GWLMB(NDGO, NDPLS, NDPAS, LPWL, NOUT, 1 NA, NL, 2 XL(1,ISL,IND2(IRL,IRA,10)), 3 MXPINV, IRL, IASL, ILSL, XSING, XAM, 4 S, INDEX, WK1Q, WK2Q, XLM, 5 WLMS) C C GLOBAL LAMBDA POINT COUNT IN SINGULAR LAMBDA C REGIONS. ILSL = ILSL + NL 42 CONTINUE 44 CONTINUE C C GLOBAL A POINT COUNT OF FIRST A POINT IN SEGMENT. IASL = IASL + NA 46 CONTINUE ENDIF CALL TEMPD(CPU3, CPU4, CPUD, NOUT, .TRUE.) C C ================================================================== C SOME FUNCTIONS OF A, LAMBDA, AND (A, LAMBDA). STORED BY GLOBAL C POINT NUMBERS TO KEEP DIMENSIONS AS SMALL AS POSSIBLE. NPA, C NPLX(1), NPLX(2) ARE TOTAL NUMBERS OF POINTS IN A, LAMBDA C VARIABLES (AND THE TWO A REGIONS). C ================================================================== C C ------------------------------------------------------------------ C FUNCTIONS OF A, LAMBDA AND (A, LAMBDA). C PSA: PHASE SPACE FACTOR; ARG*: ARGUMENTS FOR HH. C SOME OF NGO- MAY BE 0. C ------------------------------------------------------------------ C C BASIC FUNCTIONS. CALL AV2ALC(NDGO, NDSI, NDPA, NDPL, NOUT, LPAL, 1 NGOA, NSUBA, NGOL, NSUBL, 2 XA, XL, XKAPPA, XOMEGA, 3 NPA, NPLX, ARGA, ARG1A, PSA, ARGL, 4 AUXA, AUXL, R, RA, RAA, RL, RLL, RP) IF (LTEST) THEN WRITE (NOUT,7008) NAME, (I, ARG1A(I), I = 1,NPA) WRITE (NOUT,7010) NAME, (I, ARGL(I,1), I = 1,NPLX(1)) WRITE (NOUT,7012) NAME, (I, ARGL(I,2), I = 1,NPLX(2)) ENDIF IF (LTESTR) THEN C TEST SUM(M(I)M(J)R(K)**2) = M. CALL AV3RTB(NDPA, NDPL, NOUT, 1 NGOA, NSUBA, XMASS, NPA, NPLX, RP, 2 ZZZMA, ZZZML, ZZZMU) CALL CDXFBO(NOUT) ENDIF C C A-DEPENDENT PARTS AND LAMBDA-DEPENDENT PARTS OF THE REAL HH FOR C ALL STATES, ALL ARGUMENTS. CALL AV2YAB(NDS, NDPA, NDPJ, NOUT, LPJY, 1 MM, ISMN, NPA, ARGA, ARG1A, PJ, YA, YAA) CALL AV2YLD(NDS, NDPL, NDMU, NOUT, LPJY, 1 MM, ISMN, NPLX, ARGL, WK1, WK2, YL, YLL) C C ------------------------------------------------------------------ C HH FOR DELTA-FUNCTION AVERAGES (AFFIX -D). C ------------------------------------------------------------------ C CALL AV3ALA(NOUT, LPALD, 1 XKAPPA, XOMEGA, 2 ARGAD, ARG1AD, PSAD, ARGLD, AUXAD, RD) CALL AV2YAB(NDS, 1, NDPJ, NOUT, LPJYD, 1 MM, ISMN, 1, ARGAD, ARG1AD, PJD, YAD, YAAD) NPLXD(1) = 3 NPLXD(2) = 3 CALL AV2YLB(NDS, 3, NDMU, NOUT, LPJYD, 1 MM, ISMN, NPLXD, ARGLD, WK1D, WK2D, YLD, YLLD) DO 50 I = 1,3 RAD(I) = ZERO RAAD(I) = ZERO RLD(I) = ZERO RLLD(I) = ZERO 50 CONTINUE CALL TEMPD(CPU4, CPU5, CPUD, NOUT, .TRUE.) C C ****************************************************************** C INTEGRATION SECTION. C ****************************************************************** C C ================================================================== C INITIALIZATION. C ================================================================== C C INITIALIZE INTEGRALS. DO 64 I = 1,IINTR DO 62 IOP = 1,NOP QI(IOP,I) = ZERO 62 CONTINUE QD(I) = ZERO 64 CONTINUE KINTX = 0 C C CONVERSION FACTORS. DC1 NORMALIZE DELTA FUNCTION AVERAGES. XCUX C CONVERT AVERAGES TO ANOTHER MASS UNIT. (ZZZRD UNUSED.) C WN0 CONVERTS THE NORMALIZATION INTEGRAL TO GIVE A NORMALIZED C WAVE FUNCTION (SEE ABOVE FOR DEFINITIONS). XCUW CONVERTS THE C NORMALIZED WAVE FUNCTION TO ANOTHER MASS UNIT. RC1 CONVERT C RHO TO THIRD PARTICLE DISTANCE. ZZZRD = X180 / CDXPI() ZTORHO = ONE / (2 * SQRT(2 * ENERGY)) RHOX = ZTORHO * ZMATCH HC0 = 2 * SQRT(2 * ENERGY) HC1 = HC0 ** 2 DC0 = EIGHT / (CDXPI() * TWO * SQRT(TWO)) DC1(1) = DC0 / (XKAPPA(1) * SQRT(XKAPPA(1))) DC1(2) = DC0 / (XKAPPA(2) * SQRT(XKAPPA(2))) DC1(3) = DC0 / (XKAPPA(3) * SQRT(XKAPPA(3))) IF (LCONVR) THEN XCUX(1) = ONE XCUX(2) = ONE / XCU XCUX(3) = ONE / XCU XCUX(4) = ONE / XCU XCUX(5) = ONE / XCU ** 2 XCUX(6) = ONE / XCU ** 2 XCUX(7) = ONE / XCU ** 2 XCUX(8) = XCU XCUX(9) = XCU XCUX(10) = XCU XCUX(11) = XCU ** 2 XCUX(12) = XCU ** 2 XCUX(13) = XCU ** 2 XCUX(14) = XCU ** 3 XCUX(15) = XCU ** 3 XCUX(16) = XCU ** 3 ENDIF IF (LCONVH) THEN XCUX(17) = XCU XCUX(18) = XCU XCUX(19) = XCU XCUX(20) = XCU XCUX(21) = XCU XCUX(22) = XCU XCUX(23) = XCU XCUX(24) = XCU ENDIF CALL AVMMA(XMASS1, XMASS2, XMASS3, XKAPPA, XMM, XMC, NOUT) WN0 = HALF * CDXPI() ** 2 * ZTORHO ** 2 / (XMM ** X15) XCUW = XCU ** 3 XCUR = ONE / XCU DO 66 I = 1,3 RC1(I) = ONE / SQRT(XMC(I)) 66 CONTINUE C C INITIALIZE HH QUADRATURE TEST (TEST AT THE FIRST Z VALUE ONLY, C FOR ALL (MU,NU), ALL OPERATORS (WEIGHTS). IF (LHHQ) THEN HHQ0 = TWO / SQRT(CDXPI() ** 7) HHQN = TWO / CDXPI() ** 2 DO 70 I = 1,MM DO 68 J = 1,NOPR HHQ(J,I) = ZERO HHQ2(J,I) = ZERO 68 CONTINUE 70 CONTINUE ENDIF C C ================================================================== C LOOP OVER INTERVAL GROUPS. EXACT NUMBER UNKNOWN BECAUSE THE GROUP C CONTAINING Z = ZMATCH MAY HAVE TO BE SPLIT IN TWO. C ================================================================== C C JINT: COUNTER OF INTERVALS / READ OPERATIONS. C IGROUP: GROUP COUNTER. JINT = 0 IGROUP = 0 IZXX(1) = 0 IZXX(2) = 0 IZXX(3) = 0 72 CONTINUE IGROUP = IGROUP + 1 IF (LPZ0) WRITE (NOUT,2420) IGROUP C C -------------------------------------------------------------- C READ WAVE FUNCTION DATA AND REORDER WITH INCREASING Z. C (ALTERNATIVELY, DATA COULD BE IN A DIRECT ACCESS FILE.) C DATA FOR INTERVAL 1 HAVE BEEN READ IN ALREADY. C -------------------------------------------------------------- C JINTR = 0 KINTL = LGROUP KINTU = 1 IF (JINT .EQ. 0) THEN C C FIRST INTERVAL; REINITIALIZE TO FORCE KINT = 1 POINT TO C THE DATA FOR INTERVAL 1 WHICH HAVE BEEN READ IN ALREADY. C THESE DATA ARE NOT IN ARRAY WFC. C FINISH GROUP IF GROUP LENGTH IS 1. JINT = 1 JINTR = 1 KINTL = 1 INTA(1) = 1 INTG(1) = 1 INTR(1) = 1 IF (JINTR .EQ. LGROUP) GO TO 82 ENDIF 74 CONTINUE C C JINT, JINTR: ABSOLUTE AND RELATIVE INTERVAL NUMBERS. JINT = JINT + 1 JINTR = JINTR + 1 IF (JINT .GT. NDINT) CALL ERR2(NAME, 81, 1, NOUT) READ (NOUTB,ERR=76,END=76) IINT, Z0M, Z0P IF (IINT .NE. JINT) CALL ERR2(NAME, 82, 1, NOUT) GO TO 78 76 CONTINUE CALL ERR2(NAME, 83, 1, NOUT) 78 CONTINUE C C KINT: STORAGE INDEX SUCH THAT Z0M IS INCREASING WITHIN C GROUP; INTG: GLOBAL INTERVAL INDEX SUCH THAT Z0M IS C INCREASING; Z0UG: UPPER BOUND OF INTERVAL, USED AS C Z-INTEGRATION UPPER BOUND IN OUTPUT. IF (JINT .GT. IINTL) THEN KINT = LGROUP - JINTR + 1 INTG(KINT) = IINTL + IINTR - JINT + 1 L = INTG(KINT) Z0UG(L) = Z0M ELSE KINT = JINTR INTG(KINT) = JINT L = INTG(KINT) Z0UG(L) = Z0P ENDIF C C Z0M, Z0P, WFC; ABSOLUTE INTERVAL INDEX, REGION NUMBER. Z0MX(KINT) = Z0M Z0PX(KINT) = Z0P DO 80 J = 1,JMAX1 READ (NOUTB) (WFC(I,J,KINT), I = 1,MM) 80 CONTINUE INTA(KINT) = JINT INTR(KINT) = IZREG(JINT, IINTL) C C UPDATE THE RANGE OF KINT CONTAINING READ-IN DATA. IF (KINT .GT. KINTU) KINTU = KINT IF (KINT .LT. KINTL) KINTL = KINT IF (LPZ0) WRITE (NOUT,2430) 1 INTG(KINT), JINT, JINTR, Z0M, Z0P, KINT, KINTL, KINTU IF (JINTR .LT. LGROUP .AND. 1 IINT .NE. IINTL .AND. IINT .NE. IINTR) GO TO 74 82 CONTINUE C C -------------------------------------------------------------- C BY RESCALING ALREADY CALCULATED VALUES, CALCULATE THE GAUSSIAN C Z-INTEGRATION PARAMETERS FOR ALL INTERVALS IN THE GROUP. C INTEGRATION IS ALWAYS IN THE DIRECTION OF INCREASING Z; C QAWT CHECKS THAT FACT AND THUS PROVIDES AN ADDITIONAL CHECK OF C Z0M, Z0P. INTEGRATION IS DONE ONE INTERVAL AT A TIME. C -------------------------------------------------------------- C DO 84 KINT = KINTL,KINTU C C Z REGION OF THE INTERVAL. K = INTR(KINT) IF (K .LE. 2) THEN ZL = Z0MX(KINT) ZU = Z0PX(KINT) ELSE ZL = Z0PX(KINT) ZU = Z0MX(KINT) ENDIF CALL QAWT(NDQSI, NQZ1(K), XZ1(1,K), WZ1(1,K), ZL, ZU, 1 XZ(1,KINT), WZ(1,KINT), NOUT) 84 CONTINUE C C -------------------------------------------------------------- C LOOP OVER INTERVALS IN THE GROUP. FOR EACH INTERVAL, THE C INTEGRATION IS DONE OVER ALL A, LAMBDA POINTS, AND NOT C SEGMENT-WISE AS IN HYPWF (SEGMENT LOOPS ARE OUTERMOST THERE, C CAUSING REPETITION IN WEIGHT COMPUTATIONS ETC.) C -------------------------------------------------------------- C DO 230 KINT = KINTL,KINTU C C NUMBER OF Z QUADRATURE POINTS. K = INTR(KINT) NZ = NQZ1(K) L = INTG(KINT) IF (LPZ0) WRITE (NOUT,2440) KINT, K, NZ, L C C ---------------------------------------------------------- C FUNCTIONS OF Z (Z INSIDE THE INTERVAL). C ---------------------------------------------------------- C IF (INTA(KINT) .EQ. 1) THEN IF (Z0MX(KINT) .NE. ZERO) CALL ERR2(NAME, 91, 1, NOUT) CALL AVZP0A(NDQSI, NDKX, NDMA, NZ, KX, MA, 1 XZ(1,KINT), ZD1, ZDPL, NOUT) ELSE CALL AVZP1A(NDQSI, NDCN, NZ, JMAX, Z0MX(KINT), 1 XZ(1,KINT), ZDP, NOUT) C C ADDITIONAL POWERS FOR DISCONTINUITY, AT Z = ZMATCH. IF (INTA(KINT) .EQ. IINTL .OR. 1 INTA(KINT) .EQ. IINTR ) THEN IF (Z0PX(KINT) .NE. ZMATCH) 1 CALL ERR2(NAME, 92, 1, NOUT) KINTX = KINTX + 1 CALL AVZPDA(NDCN, JMAX, Z0MX(KINT), Z0PX(KINT), 1 ZDPX(1,KINTX), NOUT) WRITE (NOUT,2610) KINTX ENDIF ENDIF C C Z-WEIGHT TIMES Z-VOLUME ELEMENT DIVIDED BY Z**4: Z DZ; C RHO AND POWERS OF RHO. DO 110 IZ = 1,NZ WPSZ(IZ) = WZ(IZ,KINT) * XZ(IZ,KINT) RHO(IZ) = ZTORHO * XZ(IZ,KINT) RHOP(IZ,1) = RHO(IZ) ** 2 RHOP(IZ,2) = (ONE / RHO(IZ)) RHOP(IZ,3) = (ONE / RHO(IZ)) ** 2 RHOP(IZ,4) = (ONE / RHO(IZ)) ** 3 110 CONTINUE IF (LTEST) WRITE (NOUT,7006) NAME, 1 (IZ, WPSZ(IZ), RHO(IZ), IZ = 1,NZ) C C ========================================================== C INTEGRATE OVER A, LAMBDA, Z AT FIXED Z-INTERVAL. REGION C AND SEGMENT LOOPS APPEAR BECAUSE OF EASIER ADDRESSING OF C POINTS; INTEGRATION IS OVER ENTIRE GRID. C ========================================================== C IAS = 0 IAX = 0 DO 194 IRA = 1,2 NSA = NSUBA(IRA) NA = NGOA(IRA) IF (NA .EQ. 0) GO TO 194 DO 192 ISA = 1,NSA DO 190 IA = 1,NA C C GLOBAL A POINT COUNTS. IAX = IAX + 1 IF (IRA .EQ. 2) IAS = IAS + 1 C C AUXILIARY FUNCTION (2 COT(2A)). AUXA1 = 2 * ARGA(IAX) / PSA(IAX) C ILS = 0 ILX = 0 DO 184 IRL = 1,10 NSL = NSUBL(IRL,IRA) NL = NGOL(IRL,IRA) IF (NL .EQ. 0) GO TO 184 DO 182 ISL = 1,NSL DO 180 IL = 1,NL C C GLOBAL LAMBDA POINT COUNTS. ILX = ILX + 1 IF (MOD(IRL, 3) .NE. 1) ILS = ILS + 1 C C -------------------------------------------------- C WEIGHTS AND PHASE SPACE FACTORS. POINTER TABLES C ARE USED ON (OPERATOR, A-REGION, LAMBDA-REGION) C TRIPLES. SOME REPETITION HERE BECAUSE OF NO C Z-DEPENDENCE. POINTER TABLES ARE IGNORED IF GAUSS C QUADRATURE IS REQUIRED IN SINGULAR REGIONS. C -------------------------------------------------- C ZZZ = ZERO IF (IAS .GT. 0) ZZZ = WAMS(IAS) CALL AV2QWA(NDOPRH, NDPAS, NDPLS, NOUT, 1 NOPR, LRGAUS, LHGAUS, 2 IRA, IRL, IAS, ILS, 3 WA(IA,ISA,IRA), ZZZ, 4 WL(IL,ISL,IND2(IRL,IRA,10)), 5 WLMS, PSA(IAX), WAL, WALH) C C -------------------------------------------------- C TEST QUADRATURE OF HH, HH**2 FOR ALL STATES (FIRST C Z ONLY); WAL(J) FOR ALL OPERATORS ARE USED. C -------------------------------------------------- C IF (LHHQ) THEN DO 122 I = 1,MM DO 120 J = 1,NOPR HHQ(J,I) = HHQ(J,I) + WAL(J) 1 * (YA(I,IAX) * YL(I,ILX,IRA)) HHQ2(J,I) = HHQ2(J,I) + WAL(J) 1 * (YA(I,IAX) * YL(I,ILX,IRA))**2 120 CONTINUE 122 CONTINUE ENDIF C C -------------------------------------------------- C FUNCTIONS OF (A, LAMBDA, Z0M). C -------------------------------------------------- C C CALCULATE SERIES COEFFICIENTS OF HH PART OF THE C WAVE FUNCTION (SUM OF W. F. SERIES COEFFICIENTS C TIMES Y(A,LAMBDA)). NO REPETITION. IF (INTA(KINT) .EQ. 1) THEN CALL AV2W0A(NDS, NDKX, NDMA, NOUT, 1 MM, ISMN, YA(1,IAX), YAA(1,IAX), 2 YL(1,ILX,IRA), YLL(1,ILX,IRA), 3 KX, MA, DD, WKY, DDY) IF (ILX .EQ. 1 .AND. IAX .EQ. 1 .AND. 1 IRA .EQ. 1) THEN C WAVE FUNCTION EXP(F) WF / RHO**2 AT C RHO = 0 (NORMALIZED AS ARRAY QWF). QWF0 = DDY(3,1,1) / ZTORHO ** 2 IF (LERROR) WRITE (NOUT,9000) 1 DDY(3,1,1), ZTORHO, ENERGY, QWF0 ENDIF ELSE CALL AV2W1A(NDS, NDCN, NOUT, 1 MM, ISMN, YA(1,IAX), YAA(1,IAX), 2 YL(1,ILX,IRA), YLL(1,ILX,IRA), 3 JMAX, WFC(1,1,KINT), WKY, WFCY) ENDIF C C -------------------------------------------------- C FUNCTIONS OF (A, LAMBDA, Z), ALL Z. C -------------------------------------------------- C C CORRELATION FUNCTION F AND ITS DERIVATIVES. CALL AV2CFD(NDQSI, NOUT, LPCF, 1 FANA, 2 R(1,ILX,IAX), 3 RA(1,ILX,IAX), RAA(1,ILX,IAX), 4 RL(1,ILX,IAX), RLL(1,ILX,IAX), 5 ARG1A(IAX), 6 MODF, NZ, RHO, 7 CF, CFR, CFRR, CFA, CFAA, CFL, CFLL) C C POTENTIAL V. CALL AV2VA(NDVPAR, NDQSI, NOUT, LPVF, 1 MODV, IPVL, IPVU, VPAR, 2 R(1,ILX,IAX), RP(4,ILX,IAX), 3 NZ, RHO, RHOP(1,2), VF) C C POWERS OF INTERPARTICLE RADII. DO 144 IZ = 1,NZ C RHO. RPZ(1,IZ) = R(1,ILX,IAX) * RHO(IZ) RPZ(2,IZ) = R(2,ILX,IAX) * RHO(IZ) RPZ(3,IZ) = R(3,ILX,IAX) * RHO(IZ) C RHO**2. RPZ(4,IZ) = RP(1,ILX,IAX) * RHOP(IZ,1) RPZ(5,IZ) = RP(2,ILX,IAX) * RHOP(IZ,1) RPZ(6,IZ) = RP(3,ILX,IAX) * RHOP(IZ,1) C RHO**-1. RPZ(7,IZ) = RP(4,ILX,IAX) * RHOP(IZ,2) RPZ(8,IZ) = RP(5,ILX,IAX) * RHOP(IZ,2) RPZ(9,IZ) = RP(6,ILX,IAX) * RHOP(IZ,2) C RHO**-2. RPZ(10,IZ) = RP(7,ILX,IAX) * RHOP(IZ,3) RPZ(11,IZ) = RP(8,ILX,IAX) * RHOP(IZ,3) RPZ(12,IZ) = RP(9,ILX,IAX) * RHOP(IZ,3) 144 CONTINUE C C -------------------------------------------------- C HH-EXPANDED PART OF WAVE FUNCTION. (INDEX ORDER C MAY NOT BE BEST IN DDY.) CHANGE Z-DERIVATIVES TO C RHO-DERIVATIVES. C THE SUMS OVER HH COMPONENTS HAVE BEEN DONE. SUMS C OVER A, LAMBDA ARE OUTSIDE; HERE WE SUM OVER C POWERS OF (Z - Z0M). C -------------------------------------------------- C IF (INTA(KINT) .EQ. 1) THEN CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,1), ZDPL, NOUT, WF) CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,2), ZDPL, NOUT, WFD) CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,3), ZDPL, NOUT, WFA) CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,4), ZDPL, NOUT, WFL) CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,5), ZDPL, NOUT, WFZ) CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,6), ZDPL, NOUT, WFZZ) ELSE CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,1), ZDP, NOUT, WF) CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,2), ZDP, NOUT, WFD) CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,3), ZDP, NOUT, WFA) CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,4), ZDP, NOUT, WFL) CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,5), ZDP, NOUT, WFZ) CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,6), ZDP, NOUT, WFZZ) ENDIF C C ================================================== C Z INTEGRATION INSIDE INTERVAL, AT FIXED A, LAMBDA, C FOR GLOBAL OPERATORS. C ================================================== C CALL A5QZB(NDQSI, NDOP, NDOPRH, NDOPR1, 1 NZ, NOPR, NOPD, HC0, HC1, LTESTQ, 2 RHOP, RPZ, WPSZ, WAL, WALH, AUXA1, 3 ARG1A(IAX), 4 WF, WFD, WFA, WFL, WFZ, WFZZ, 5 CF, CFR, CFRR, CFA, CFAA, CFL, CFLL, 6 VF, NOUT, QI(1,L)) IF (LTESTW .AND. ABS(L - IIT) .LE. IITD) THEN C C OUTPUT WAVE FUNCTION VALUES. THESE ARE C SUPPLEMENTED BY VALUES AT COALESCENCE POINTS C (SEE BELOW), IF IZT, IZWFS ETC. ARE CHOSEN C CONSISTENTLY. IF (ABS(IAX - IAXT) .LE. IAXTD .AND. 1 ABS(ILX - ILXT) .LE. ILXTD ) THEN DO 172 IZ = 1,NZ IF (ABS(IZ - IZT) .LE. IZTD) THEN ZZZ1 = EXP(CF(IZ)) ZZZ2 = 1 WF(IZ) * EXP(CF(IZ)) * RHOP(IZ,3) WRITE (NOUT,7004) IAX, ILX, IZ, 1 RPZ(1,IZ), RPZ(2,IZ), RPZ(3,IZ), 2 ZZZ1, ZZZ2, IRA, ISA, IA, IAS, 3 IRL, ISL, IL, ILS ENDIF 172 CONTINUE ENDIF ENDIF C C ================================================== C DISCONTINUITY INTEGRAL. C ================================================== C IF (INTA(KINT) .EQ. IINTL .OR. 1 INTA(KINT) .EQ. IINTR ) THEN C C CORRELATION FUNCTION AT Z = ZMATCH. CALL AV2CFD(1, NOUT, LPCF, 1 FANA, 2 R(1,ILX,IAX), 3 RA(1,ILX,IAX), RAA(1,ILX,IAX), 4 RL(1,ILX,IAX), RLL(1,ILX,IAX), 5 ARG1A(IAX), 6 MODF, 1, RHOX, 7 CFX, CFRX, CFRRX, CFAX, CFAAX, 8 CFLX, CFLLX) C C WAVE FUNCTION AND DERIVATIVE. WFX = ZERO WFZX = ZERO DO 174 IP = 1,JMAX1 WFX = WFX + WFCY(IP,1) * ZDPX(IP,KINTX) WFZX = WFZX + WFCY(IP,5) * ZDPX(IP,KINTX) 174 CONTINUE WFRX = HC0 * WFZX C C INTEGRAL ON ONE OF THE TWO INTERVALS. QD(L) = (- HALF * RHOX) 1 * (2 * KINTX - 3) 2 * WALH * EXP(2 * CFX) 3 * WFX * WFRX ENDIF C 180 CONTINUE 182 CONTINUE 184 CONTINUE C 190 CONTINUE 192 CONTINUE 194 CONTINUE C C ---------------------------------------------------------- C RENORMALIZE, PRINT TEST INTEGRALS. IF (LHHQ) THEN DO 200 J = 1,NOPR HHQ(J,1) = 1 LOG10(MAX(CDXEPS(), ABS(HHQ(J,1) - HHQ0))) HHQ2(J,1) = 1 LOG10(MAX(CDXEPS(), ABS(HHQ2(J,1) - HHQN))) 200 CONTINUE IF (MM .GE. 2) THEN DO 204 I = 2,MM DO 202 J = 1,NOPR HHQ(J,I) = 1 LOG10(MAX(ABS(HHQ(J,I)), CDXEPS())) HHQ2(J,I) = 1 LOG10(MAX(CDXEPS(), 2 ABS(HHQ2(J,I) - HHQN))) 202 CONTINUE 204 CONTINUE ENDIF WRITE (NOUT,7500) DO 206 I = 1,MM WRITE (NOUT,7502) 1 I, ISMN(1,I), ISMN(2,I), 2 (HHQ(J,I), HHQ2(J,I), J = 1,NOPR) 206 CONTINUE CALL CDXFBO(NOUT) IF (LHHQX) THEN CALL TEMPD(CPU1, CPUT, CPUD, NOUT, .TRUE.) STOP ENDIF LHHQ = .FALSE. ENDIF C C PRINT UNORDERED NORM. AND DISC. INTEGRALS. WRITE (NOUT,2600) L, Z0UG(L), QI(1,L), QD(L) C ---------------------------------------------------------- C C ========================================================== C COALESCENCE POINTS. C ========================================================== C C LOOP OVER COALESCENCE POINTS. DO 226 J = 1,3 QWFRX(1) = ZERO QWFRX(2) = ZERO QWFRX(3) = ZERO C C ------------------------------------------------------ C DELTA(R(K)) INTEGRATION.. C ------------------------------------------------------ C C CALCULATE SERIES COEFFICIENTS OF HH PART OF THE WAVE C FUNCTION (SUM OF W. F. SERIES COEFFICIENTS TIMES C Y(PI/2,LAMBDA(J))). IF (INTA(KINT) .EQ. 1) THEN CALL AV2W0A(NDS, NDKX, NDMA, NOUT, 1 MM, ISMN, YAD, YAAD, 2 YLD(1,J,2), YLLD(1,J,2), 3 KX, MA, DD, WKY, DDY) ELSE CALL AV2W1A(NDS, NDCN, NOUT, 1 MM, ISMN, YAD, YAAD, 2 YLD(1,J,2), YLLD(1,J,2), 3 JMAX, WFC(1,1,KINT), WKY, WFCY) ENDIF C C HH-EXPANDED PART OF WAVE FUNCTION. IF (INTA(KINT) .EQ. 1) THEN CALL AVWF0A(NDQSI, NDMA, NDKX, NZ, MA, KX, 1 DDY(1,1,1), ZDPL, NOUT, WF) ELSE CALL AVWF1A(NDQSI, NDCN, NZ, JMAX, 1 WFCY(1,1), ZDP, NOUT, WF) ENDIF C C CORRELATION FUNCTION F (DERIVATIVES DUMMY). CALL AV2CFD(NDQSI, NOUT, LPCF, 1 FANA, 2 RD(1,J), 3 RAD, RAAD, RLD, RLLD, 4 ARG1AD, 5 MODF, NZ, RHO, 6 CF, CFR, CFRR, CFA, CFAA, CFL, CFLL) C C CONTRIBUTION OF THE POINT TO ITS OPERATOR. DO 220 IZ = 1,NZ QI(NOPR+J,L) = QI(NOPR+J,L) + 1 WPSZ(IZ) * EXP(2 * CF(IZ)) * 2 WF(IZ) ** 2 * RHOP(IZ,4) * DC1(J) 220 CONTINUE IF ((LTEST .OR. LTESTD) .AND. 1 ABS(L - IIT) .LE. IITD ) THEN DO 222 IZ = 1,NZ IF (ABS(IZ - IZT) .LE. IZTD) THEN ZZZ1 = EXP(2 * CF(IZ)) WRITE (NOUT,7300) IZ, WF(IZ), CF(IZ), ZZZ1 ENDIF 222 CONTINUE ENDIF C C ------------------------------------------------------ C WAVE FUNCTION AT COALESCENCE POINT; DEFINED AS C EXP(F) WF / RHO**2. TAKE SELECTED Z VALUES ONLY. QWFR C ARE THE DISTANCES OF THE THIRD PARTICLE IN A.U. QWFR, C QWF ARE NOT ORDERED (NO INDEX L). STORE Z-WEIGHTS. C ------------------------------------------------------ C NZX = MIN(NZ, IZWFN) DO 224 I = 1,NZX,IZWFS IF (IZXX(J) + 1 .GT. NDQWF) 1 CALL ERR2(NAME, 95, 1, NOUT) IZXX(J) = IZXX(J) + 1 IZX = IZXX(J) QWF(J,IZX) = EXP(CF(I)) * WF(I) * RHOP(I,3) QWFR(J,IZX) = RC1(J) * RHO(I) QWFW(J,IZX) = WZ(I,KINT) IF (.NOT. LTESTW) GO TO 224 C C PRINT (ORIGINAL UNITS; SEE W.F. OUTPUT ABOVE; C THE PRESENT OUTPUT IS USEFUL IF ABOVE THE W.F. C IN THE VICINITY OF A COALESCENCE POINT WAS C OUTPUT). IF (ABS(L - IIT) .LE. IITD .AND. 1 ABS(I - IZT) .LE. IZTD ) THEN ZZZ1 = EXP(CF(I)) QWFRX(J) = QWFR(J,IZX) WRITE (NOUT,7024) QWFRX, ZZZ1, QWF(J,IZX) ENDIF 224 CONTINUE 226 CONTINUE IF (LTESTD) WRITE (NOUT,7302) 1 L, Z0UG(L), (QI(NOPR+J,L), J = 1,3) 230 CONTINUE IF (JINT .LT. IINTR) GO TO 72 IF (IZXX(1) .NE. IZXX(2)) CALL ERR2(NAME, 100, 1, NOUT) IF (IZXX(1) .NE. IZXX(3)) CALL ERR2(NAME, 101, 1, NOUT) IZWFT = IZXX(1) WRITE (NOUT,7400) IZWFT CALL TEMPD(CPU5, CPU6, CPUD, NOUT, .TRUE.) C C ****************************************************************** C NORMALIZATION AND OUTPUT SECTION. C ****************************************************************** C C ================================================================== C NORMALIZE INTEGRALS ON ORDERED Z-INTERVALS. C ================================================================== C WRITE (NOUT,2500) C C INITIALIZE INTEGRALS SUMMED UP TO L-TH INTERVAL. DO 240 I = 1,NOP Q(I) = ZERO 240 CONTINUE QDISC = ZERO IF (UNNDEL) THEN WRITE (NOUT,2700) IOPL = NOPR + 1 IOPU = NOPR + 3 WRITE (NOUT,2504) (IOPER(I), I = IOPL,IOPU) ENDIF DO 250 L = 1,IINTR C C -------------------------------------------------------------- C SUMS OF INTEGRALS UP TO L-TH INTERVAL, ALL OPERATORS. C -------------------------------------------------------------- C DO 242 IOP = 1,NOP Q(IOP) = Q(IOP) + QI(IOP,L) 242 CONTINUE QDISC = QDISC + QD(L) C C -------------------------------------------------------------- C NORMALIZE INTEGRALS AT FIXED UPPER Z BOUND (Q(1) UNCHANGED), C EXCEPT IF UNNAVE = .TRUE.. C -------------------------------------------------------------- C IF (UNNAVE) THEN ZZZRN = ONE ZZZHN = ONE ELSE ZZZRN = Q(1) ZZZHN = Q(NOP) ENDIF C C R(K)**P-TYPE NORMALIZATION. QN(1,L) = Q(1) C C NORMALIZE R(K)**P-TYPE AVERAGES. DO 244 IOP = 2,NOPR QN(IOP,L) = Q(IOP) / ZZZRN 244 CONTINUE C C NORMALIZE DELTA(R(K))-TYPE AVERAGES, USING ABOVE NORM. C OPTIONALLY PRINT THE UNNORMALIZED AVERAGES. DO 245 IOP = 1,3 QN(NOPR+IOP,L) = Q(NOPR+IOP) / ZZZRN 245 CONTINUE IF (UNNDEL) THEN WRITE (NOUT,2506) L, Z0UG(L), (Q(NOPR+IOP), IOP = 1,3) ENDIF C C H-TYPE NORMALIZATION (WEIGHTS MODIFIED IN A DIFFERENT WAY). QN(NOP,L) = Q(NOP) C C NORMALIZE H-TYPE AVERAGES AND DISCONTINUITY. IOPL = NOPR + NOPD + 1 IOPU = NOP - 1 DO 246 IOP = IOPL,IOPU QN(IOP,L) = Q(IOP) / ZZZHN 246 CONTINUE QDN(L) = QDISC / ZZZHN C C -------------------------------------------------------------- C CALCULATE T AND H (INCLUDE DISCONTINUITY IN T). C -------------------------------------------------------------- C IOPL = NOPR + NOPD + 2 IOPU = NOP - 1 QTN(L) = QDN(L) DO 248 IOP = IOPL,IOPU QTN(L) = QTN(L) + QN(IOP,L) 248 CONTINUE QHN(L) = QTN(L) + QN(NOPR+NOPD+1,L) 250 CONTINUE IF (LNCOAL) THEN C C -------------------------------------------------------------- C NORMALIZE WAVE FUNCTION AT COALESCENCE POINTS, USING Q(1) FROM C PREVIOUS (COMPLETED) LOOP OVER INTERVALS. THIS IS MEANINGLESS C IF Q(1) DOES NOT CONVERGE WITH Z OR HAS PLATEAUX. IN THAT CASE C THE NORMALIZATION FROM A PLATEAU SHOULD BE USED IN A C SUBSEQUENT PROGRAM. C -------------------------------------------------------------- C WN1 = ONE / SQRT(WN0 * Q(1)) DO 252 L = 1,IZWFT DO 249 J = 1,3 QWF(J,L) = QWF(J,L) * WN1 249 CONTINUE 252 CONTINUE C AT RHO = 0. QWF0 = QWF0 * WN1 IF (LERROR) WRITE (NOUT,9100) WN1, QWF0 ENDIF C C ================================================================== C CONVERT TO ANOTHER MASS UNIT. C ================================================================== C IF (LCONVR) THEN IOPU = NOPR + NOPD DO 253 L = 1,IINTR DO 251 IOP = 2,IOPU QN(IOP,L) = QN(IOP,L) * XCUX(IOP) 251 CONTINUE 253 CONTINUE C Z-WEIGHTS TO R-WEIGHTS. DO 255 L = 1,IZWFT DO 254 J = 1,3 QWF(J,L) = QWF(J,L) * XCUW QWFR(J,L) = QWFR(J,L) * XCUR QWFW(J,L) = QWFW(J,L) * RC1(J) * (XCUR * ZTORHO) 254 CONTINUE 255 CONTINUE QWF0 = QWF0 * XCUW IF (LERROR) WRITE (NOUT,9200) XCUW, QWF0 ENDIF IF (LCONVH) THEN IOPL = NOPR + NOPD + 1 DO 257 L = 1,IINTR DO 256 IOP = IOPL,NOP QN(IOP,L) = QN(IOP,L) * XCUX(IOP) 256 CONTINUE QTN(L) = QTN(L) * XCU QDN(L) = QDN(L) * XCU QHN(L) = QHN(L) * XCU 257 CONTINUE ENDIF C C ================================================================== C OUTPUT. C ================================================================== C C ------------------------------------------------------------------ C FORMATTED. C ------------------------------------------------------------------ C IF (NOPR .NE. 13 .AND. NOPD .NE. 3 .AND. NOPH .NE. 8) 1 CALL ERR2(NAME, 99, 0, NOUT) C C R**P-TYPE AVERAGES. WRITE (NOUT,2502) IOPER(1), (L, Z0UG(L), QN(1,L), L = 1,IINTR) DO 262 J = 1,4 IOPL = (J - 1) * 3 + 2 IOPU = MIN(NOPR, IOPL + 2) WRITE (NOUT,2504) (IOPER(I), I = IOPL,IOPU) DO 260 L = 1,IINTR,IPRAVS WRITE (NOUT,2506) L, Z0UG(L), (QN(I,L), I = IOPL,IOPU) 260 CONTINUE 262 CONTINUE C C DELTA(R)-TYPE AVERAGES. IOPL = NOPR + 1 IOPU = NOPR + 3 WRITE (NOUT,2504) (IOPER(I), I = IOPL,IOPU) DO 263 L = 1,IINTR,IPRAVS WRITE (NOUT,2506) L, Z0UG(L), (QN(I,L), I = IOPL,IOPU) 263 CONTINUE C C H TERMS. DO 266 J = 1,3 IOPL = (J - 1) * 3 + NOPR + NOPD + 1 IOPU = MIN(NOP, IOPL + 2) WRITE (NOUT,2504) (IOPER(I), I = IOPL,IOPU) DO 264 L = 1,IINTR,IPRAVS WRITE (NOUT,2506) L, Z0UG(L), (QN(I,L), I = IOPL,IOPU) 264 CONTINUE 266 CONTINUE C C DISCONTINUITY, T, H. WRITE (NOUT,2504) IOPERD, IOPERT, IOPERH DO 268 L = 1,IINTR,IPRAVS WRITE (NOUT,2507) L, Z0UG(L), QDN(L), QTN(L), QHN(L) 268 CONTINUE C C WAVE FUNCTION AT COALESCENCE POINTS. DO 269 J = 1,3 WRITE (NOUT,2800) J, J WRITE (NOUT,2802) (L, QWFR(J,L), QWF(J,L), L = 1,IZWFT,IPRWFS) 269 CONTINUE WRITE (NOUT,8200) QWF0 C C OUTPUT INTEGRALS ON INTERVAL NUMBER IPRAVF . C THIS INTERVAL SHOULD BE THE ONE WHERE ALL EXPECTATION VALUES C ARE APPROXIMATELY CONVERGED (OR HAVE PLATEAUX); IT IS DIFFICULT C TO GUESS; A LARGE NUMBER MAKES IT THE LAST INTERVAL WHICH USUALLY C CONTAINS BAD RESULTS. PLATEAUX SHOULD BE SEARCHED WITH ANOTHER C PROGRAM. WRITE (NOUT,2508) L = MIN(IINTR, IPRAVF) L = MAX(L, 1) DO 270 I = 1,NOP WRITE (NOUT,2510) IOPER(I), L, Z0UG(L), QN(I,L) 270 CONTINUE WRITE (NOUT,2512) ZMATCH, QDN(L) WRITE (NOUT,2514) QTN(L) WRITE (NOUT,2516) QHN(L) C C ------------------------------------------------------------------ C UNFORMATTED. C ------------------------------------------------------------------ C C EXPECTATION VALUES AND NORMALIZATION INTEGRALS. WRITE (NOUT1) NOP, IINTR DO 280 L = 1,IINTR WRITE (NOUT1) L, Z0UG(L), 1 (QN(I,L), I = 1,NOP), 2 QDN(L), QTN(L), QHN(L) 280 CONTINUE C C WAVE FUNCTION AT COALESCENCE POINTS. OTHER PARAMETERS ALLOW THE C CALCULATION OF COULOMB PARAMETERS IN SUBSEQUENT PROGRAMS. WN0 C IS USED TO NORMALIZE WAVE FUNCTION OVER ALL SPACE; Q(1) MUST C USUALLY BE EXTRACTED FROM PLATEAU-LIKE CURVES. WRITE (NOUT2) 1 ZTORHO, XCUR, (RC1(J), J = 1,3), (V(J,-1+IP0OFF), J = 1,3), 2 WN0, IZWFT, IZWFS, IZWFN WRITE (NOUT2) QWF0 DO 282 L = 1,IZWFT WRITE (NOUT2) L, (QWFR(J,L), QWFW(J,L), QWF(J,L), J = 1,3) 282 CONTINUE CALL TEMPD(CPU6, CPU7, CPUD, NOUT, .TRUE.) CALL TEMPD(CPU1, CPUT, CPUD, NOUT, .TRUE.) CALL EXIT STOP C 1000 FORMAT (20A4) 1010 FORMAT (20L1) 1020 FORMAT (20I4) 1032 FORMAT (2F16.8) 1040 FORMAT (F40.20) C 2000 FORMAT ( A 5H1 , A6, A66) 2100 FORMAT (//, 1 1H , 20A4, //, 2 1H , 32H*** LTAB *** , L4, /, A 1H , 32HLRGAUS, LHGAUS , 2L4, /, B 1H , 32HMXPLOG, MXPINV , 2I4, /, C 1H , 32HLGROUP , I4, /, D 1H , 32HXCU (UNIT CONV.), LCONVR, LCONVH, E24.16, 2L4, /, 3 1H , 32HLHHQ, LHHQX , 2L4, /, E 1H , 32HINTEGRATION PARAMETERS , /, F 1H , 32HNGOA , 2I4, /, G 1H , 32HNSUBA , 2I4, /, H 1H , 32HNGOL(.,1) , 10I4, /, I 1H , 32HNSUBL(.,1) , 10I4, /, J 1H , 32HNGOL(.,2) , 10I4, /, K 1H , 32HNSUBL(.,2) , 10I4, /, L 1H , 32HNGOZ , 3I4, /, M 1H , 32HNSUBZ , 3I4, /, N 1H , 32HDAS, DLS , 2E12.4, / O 1H , 32HIZWFN,IZWFS,IPRAVS,IPRWFS,IPRAVF, 5I4, /, P 1H , 32HUNNDEL, UNNAVE, LNCOAL , 3L4, /) 2110 FORMAT ( A 1H , 32HLPCFC, LPVC, LPCF, LPVF , 4L2, /, B 1H , 32HLPJY, LPWA, LPWL, LPAL , 4L2, /, C 1H , 32HLPGA, LPGL, LPG , 3L2, /, D 1H , 32HLTEST, LTESTW, LPZ0, LTWFIN , 4L2, /, E 1H , 32HLTESTD, LPALD, LPJYD , 3L2, /, F 1H , 32HLTESTQ, LTESTR , 2L2, /, G 1H , 32HIAXT, IAXTD; ILXT, ILXTD , 4I4, /, H 1H , 32HIIT, IITD; IZT, IZTD , 4I4, /, I 1H , 32HLERROR , L4, //) 2120 FORMAT (//, A 1H , 8X, 32H ENERGY SEARCH PARAMETERS, /) 2130 FORMAT (//, A 1H , 8X, 36H MATRIX ELEMENT PARAMETERS , /) 2140 FORMAT (//, A 1H , 8X, 36H CONSTANTS, STATES, ENERGY , /) 2150 FORMAT (//, A 1H , 8X, 32H END OF HEADER , //) 2200 FORMAT (/, A 1H , 32HENERGY , F24.16, /) 2300 FORMAT ( A 1H , 32HXOMEGA, XKAPPA: , /, B 1H , 4X, 3F24.16, /, C 1H , 4X, 3F24.16, //, D 1H , 20HNUMBER OF STATES , I8) 2400 FORMAT ( A 1H , 32HIINTL, IINTR , 2I4) 2410 FORMAT ( A 1H , 32H IINT, Z0M, Z0P , 4X, I4, 2F12.6) 2420 FORMAT ( A 1H , 12H---- GROUP , I4, 6H ----) 2430 FORMAT ( A 1H , 28HINT:G/IN/R;Z0M,Z0P;KINT/L/U , 3I4, 2F12.6, 3I4) 2440 FORMAT ( A 1H , 20H KINT, K, NZ, L , 4I4) 2500 FORMAT (//, A 1H , 36HINTEGRALS ON ORDERED Z INTERVALS ) 2502 FORMAT (/, A 1H , 4X, 8X, A22, /, B (1H , I4, F8.2, E22.14)) 2504 FORMAT (/, A 1H , 4X, 8X, 3A22) 2506 FORMAT ( A 1H , I4, F8.2, 3E22.14) 2507 FORMAT ( A 1H , I4, F8.2, E22.12, 2E22.14) 2508 FORMAT (//, A 1H , 36HINTEGRALS AT Z = ZTOP , /) 2510 FORMAT ( A 1H , 4X, A22, I4, F8.2, E22.14) 2512 FORMAT ( A 1H , 4X, 26HDISCONTINUITY AT ZMATCH = , F8.2, E22.6) 2514 FORMAT ( A 1H , 4X, 26HKINETIC ENERGY , 8X, E22.14) 2516 FORMAT ( A 1H , 4X, 26HHAMILTONIAN , 8X, E22.14, /) 2600 FORMAT ( A 1H , 8HQI, QD , I4, F8.2, 2E24.16) 2610 FORMAT ( A 1H , 12H KINTX = , I2) 2700 FORMAT (/, A 1H , 40HUNNORMALIZED DELTA(R(K)) AVERAGES: ) 2800 FORMAT (/, A 1H , 8X, 12X, 2HS(, I1, 1H), 18H W. FUNCTION, R(, I1, 5H) = 0) 2802 FORMAT ( A 1H , I8, F16.6, E24.16) 7000 FORMAT (/, A 2H -, A6, 1H-, 32HZ POINTS ON (-1,1). REGION, NZ: , 2I4, /, B (1H , 8X, 2F12.6)) 7004 FORMAT (1H , 2HWF, 3I3, 3E10.3, 2E19.12, 1X, 4I2, 1X, 4I2) 7024 FORMAT (1H , 2HWF, 9X, 3E10.3, 2E19.12) 7006 FORMAT (2H -, A6, 1H-, 12HWPSZ, RHO , /, A (1H , I3, 2F8.2)) 7008 FORMAT (2H -, A6, 1H-, 12HSIN(A) , /, A (1H , I3, F8.5)) 7010 FORMAT (2H -, A6, 1H-, 12HLAMBDA(1) , /, A (1H , I3, F8.5)) 7012 FORMAT (2H -, A6, 1H-, 12HLAMBDA(2) , /, A (1H , I3, F8.5)) 7300 FORMAT (1H , 6HI-TEST, 8X, I4, E12.4, F16.6, E12.4) 7302 FORMAT (1H , 6HDELTA , I4, F8.2, 3E20.12) 7400 FORMAT (1H , 8HIZWFT , I8) 7500 FORMAT (/, 1H , 20HTEST HH INTEGRALS , /, A 1H , 8H STATE, 8H MU NU, 12H HH, HH**2 ) 7502 FORMAT (1H , I8, 2I4, 7(F5.0, F4.0), /, A (1H , 16X, 9X, 6(F5.0, F4.0))) 8000 FORMAT (1H , 12HPCV(1,M) , /, (1H , 5E12.4)) 8010 FORMAT (1H , 12HCN(I,1,1) , /, (1H , 5E12.4)) 8200 FORMAT (1H , 24HW.F. AT RHO = 0 , E24.16) 9000 FORMAT (1H , 12HERR-DDY(3,) , 4E16.8) 9100 FORMAT (1H , 12HERR-WN1-QWF0, 2E16.8) 9200 FORMAT (1H , 12HERR-XCUW-WF0, 2E16.8) END cdxeps.f000644 000311 000121 00000000557 05306654433 012344 0ustar00krivecf1000000 000000 FUNCTION CDXEPS() REAL * 8 CDXEPS C C ** MACHINE DEPENDENT ** C EPS (SMALLEST REAL * 8 NUMBER SUCH THAT (1.D0 + EPS) .GT. 1.D0). C C* CDXEPS = 2.D0 ** (-52) C* IBM C* CDXEPS = 2.D0 ** (-56) C* VAX CDXEPS = 2.D0 ** (-52) C* CONVEX C220 RETURN END cdxfbo.f000644 000311 000121 00000000313 05307356415 012311 0ustar00krivecf1000000 000000 SUBROUTINE CDXFBO(NOUT) C C ** MACHINE DEPENDENT ** C FLUSHES BUFFER CONTENTS ON UNIT NOUT TO OUTPUT FILE. C CALL FLUSH(NOUT) C* CONVEX C220 RETURN END cdxmax.f000644 000311 000121 00000000437 05306654640 012337 0ustar00krivecf1000000 000000 FUNCTION CDXMAX() REAL * 8 CDXMAX C C ** MACHINE DEPENDENT ** C MAXIMUM REAL * 8 NUMBER REPRESENTABLE. C C* CDXMAX = 2.D0 ** (+251) C* IBM CDXMAX = 2.D0 ** (+1022) C* CONVEX C220 RETURN END cdxpi.f000644 000311 000121 00000000155 05305157757 012165 0ustar00krivecf1000000 000000 FUNCTION CDXPI() REAL * 8 CDXPI CDXPI = 3.14159265358979323846D00 RETURN END cdxtol.f000644 000311 000121 00000000537 05306654743 012355 0ustar00krivecf1000000 000000 FUNCTION CDXTOL() REAL * 8 CDXTOL C C ** MACHINE DEPENDENT ** C TOL (SMALLEST REPRESENATBLE REAL * 8 NUMBER). C CDXTOL = 2.D0 ** (-1024) C* C220 C* CDXTOL = 2.D0 ** (-126) C* VAX C* CDXTOL = 2.D0 ** (-260) C* IBM RETURN END cfc000.f000644 000311 000121 00000003074 06067231550 012022 0ustar00krivecf1000000 000000 SUBROUTINE CFC000(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), F(3,NDP0), FANA(3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC000' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 F(I,IP0X) = -ALPHA(I) FANA(I) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 2.1, 95/12/24. 2.0, 92/05/22. (1.1) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc001.f000644 000311 000121 00000004214 06067231703 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), BETA(3), GAMMA(3), F(3,NDP0), 1 FANA(3,3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) C -( ALPHA(I) + BETA(I)*EXP(-GAMMA(I)*R(I)) ) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C C C LOGICAL LCALL0 DIMENSION W(3) CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC001' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -(ALPHA(I) + BETA(I)) FANA(I,1) = -ALPHA(I) FANA(I,2) = -BETA(I) FANA(I,3) = GAMMA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 1) RETURN C C C FURTHER POWERS. DO 30 IP0 = 2,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * GAMMA(I) / DFLOAT(IP0 - 1) F(I,IP0X) = -BETA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 3.1, 95/12/24. 3.0, 92/05/22. (2.2) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc002.f000644 000311 000121 00000004452 06067232004 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC002(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, ZZ, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ZZ(3), F(3,NDP0), FANA(3) C C C C C CUSP COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C INPUT ARE MASSES AND PRODUCTS OF CHARGES (ZZ) (THIS IS C NECESSARY, FOR EXAMPLE, IF SOME PAIR INTERACTION IS TO BE PUT C TO ZERO; THEN THE CORRELATION PARAMETER IS ZERO, TOO; C THIS WOULD NOT BE POSSIBLE IF THE CHARGES THEMSELVES WERE C INPUT). C THIS PROGRAM CALCULATES CUSP COEFFICIENTS TO FULL PRECISION, C WHICH IS BETTER THAN IF THE MAIN PROGRAM WOULD READ THEM IN C AND CALL CFC000. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC002' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF C IF (XM1 .LT. 0.D0) CALL ERR2(NAME, 4, 1, NOUT) IF (XM2 .LT. 0.D0) CALL ERR2(NAME, 5, 1, NOUT) IF (XM3 .LT. 0.D0) CALL ERR2(NAME, 6, 1, NOUT) C F(1,IP0X) = ZZ(1) * XM2 * XM3 / (XM2 + XM3) F(2,IP0X) = ZZ(2) * XM3 * XM1 / (XM3 + XM1) F(3,IP0X) = ZZ(3) * XM1 * XM2 / (XM1 + XM2) FANA(1) = F(1,IP0X) FANA(2) = F(2,IP0X) FANA(3) = F(3,IP0X) C IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 5.1, 95/12/24. 5.0, 92/05/22. (4.0) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc003.f000644 000311 000121 00000004037 06067230136 012024 0ustar00krivecf1000000 000000 SUBROUTINE CFC003(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, F) IMPLICIT REAL*8 (A - H, O - Z) LOGICAL LPR DIMENSION ALPHA(3), BETA(3), F(3,NDP0) C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * EXP(-BETA(I) * R(I)), C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 0,..., IPFU (ABORTING IF IPFL .GT. 0). C C CHARACTER*6 NAME DATA NAME / 'CFC003' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/05/11. O: CFC001 2.2, 91/01/16. ' / C ------------------------------------------------------------ C C LOGICAL LCALL0 DIMENSION W(3) DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 0 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 0) RETURN C C C FURTHER POWERS. DO 30 IP0 = 1,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * BETA(I) / DFLOAT(IP0) F(I,IP0X) = -ALPHA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc004.f000644 000311 000121 00000014105 06067230137 012023 0ustar00krivecf1000000 000000 SUBROUTINE CFC004(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XE, XA, XR, XN, 3 D1, D2, D, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XE(3), XA(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE. C XE(1-3) = (E1, E2, C). E1: BINDING ENERGY OF PARTICLE 1,...; C C: ASYMPTOTIC CONSTANT IN PHI = EXP(C * RHO) FOR C THE CFHHM SMOOTH HH-EXPANED PART OF W.F. C DEPENDS C ON THE CORREL. FUNCTION AND CAN ONLY BE OBTAINED A C POSTERIORI FROM THE MATRIX ELEMENTS OF THE C EFFECTIVE POTENTIAL W, CALCULATED FROM THE OUTPUT C OF THIS ROUTINE. ONE WAY TO DO IT IS TO SEE IF C THE SAME C IS OBTAINED AS WAS INPUT TO THIS C ROUTINE, AND THUS ACHIEVE SELF-CONSISTENCY. C C CAN ALSO BE PUT TO 0, IN WHICH CASE THE C OUTPUT OF THIS ROUTINE WILL BE AS IN THE CASE C OF E+E-E- (C WAS NOT TAKEN INTO ACCOUNT). C XA(1-3) VALUES OF PARAMETERS A(I). A3 IS A FREE PARAMETER, C AND XA(1), XA(2) ARE IGNORED (RESERVED FOR FUTURE C USE). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C A(I) = (A1, A2, A3); C B(I) = (B1, B2, B3); C C(I) = (C1, C2, C3); C D1, D2, D, C WHERE C A3 = XA(3) C A1 = - ROOT(2 M2 E2) - C ROOT(M2) - A3, C A2 = - ROOT(2 M1 E1) - C ROOT(M1) - A3, C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3), C D1 = A1 + A2, D2 = ROOT(M3), C D = D1 + C D2 C (D SHOULD BE NEGATIVE IF THE TRUE C IS INPUT; IF C = 0, D MAKES C NO SENSE; D ONLY SERVES AS A CHECK; HOWEVER, FROM D1 AND D2, C THE VALUE OF D WITH C FROM THE KM = 0 EQUATION USING THE C MATRIX ELEMENTS OUTPUT FROM THIS PROGRAM, CAN BE CALCULATED). C HERE M1 IS THE REDUCED MASS OF THE PARTICLE 1 WITH RESPECT TO C THE PAIR (2,3), ETC. C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION XM(3), A(3), ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC004' / CHARACTER*60 VERS DATA VERS */ ' 2.2, 92/11/26. (1.2) ' / C ------------------------------------------------------------ C DATA ZERO, ONE, TWO / 0.D0, 1.D0, 2.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XE, XA, XR, XN ENDIF C C CALCULATE B AND A, AND D. C RESULT (B) TEMPORARILY IN F(.,1+IP0OFF). XM(1) = XM1 XM(2) = XM2 XM(3) = XM3 IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM(1), XM(2), XM(3), XZ, F, FANA) XMM1 = XM(1) * (XM(2) + XM(3)) / (XM(1) + XM(2) + XM(3)) XMM2 = XM(2) * (XM(3) + XM(1)) / (XM(1) + XM(2) + XM(3)) XMM3 = XM(3) * (XM(1) + XM(2)) / (XM(1) + XM(2) + XM(3)) A(1) = - SQRT(TWO * XMM2 * XE(2)) - XE(3) * SQRT(XMM2) - XA(3) A(2) = - SQRT(TWO * XMM1 * XE(1)) - XE(3) * SQRT(XMM1) - XA(3) A(3) = XA(3) D1 = A(1) + A(2) D2 = SQRT(XMM3) D = D1 + XE(3) * D2 C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 ALPHA(I) = - A(I) BETA(I) = - (F(I,1+IP0OFF) - A(I)) GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, D1, D2, D ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HEPS., C , 3E22.14, /, E 1H , 8HA(I) , 3E22.14, /, F 1H , 8HAV. R(I), 3E22.14, /, G 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HD1,D2, D, 3E22.14) END cfc005.f000644 000311 000121 00000011466 06067230141 012026 0ustar00krivecf1000000 000000 SUBROUTINE CFC005(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XA, XAL, XR, XN, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XA(3), XAL(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C B(I) ARE PRECISE CUSP PARAMETERS CALULATED IN THIS ROUTINE. C IT IS ALSO POSSIBLE TO REQUIRE THAT A(I) EQUAL THE CUSP PARAMETER C FOR SOME I; THEN B(I) = A(I) AND F IS LINEAR IN R(I). C BUT A(I) ARE INDEPENDENT OF EACH OTHER; NO AYMPTOTIC C CONDITIONS ARE IMPOSED. (INTENDED FOR IMPROVING ON THE LINEAR C CORRELATION FUNCTION IN CASES LIKE MU-D-T IN WHICH ASYMPTOTICS C SEEM TO BE DIFFICULT TO IMPLEMENT IN CORRELATION FUNCTION.) C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V HERE, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE (NON-FATAL CHECKS CAN C BE DONE BY THE CALLING PROGRAM). C XA(1-3) = VALUES OF PARAMETERS A(I). C XAL(1-3): IF XAL(I) = 0.0, A(I) = XA(I), AS IT IS INPUT; C ELSE A(I) IS EQUATED TO B(I). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C B1, B2, B3; C C1, C2, C3, C WHERE C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3). C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE OF F EXPANSION: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC005' / CHARACTER*60 VERS DATA VERS */ ' 2.4, 93/03/16. (1.0) ' / C ------------------------------------------------------------ C DATA ZERO, ONE / 0.D0, 1.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XA, XR, XN ENDIF C C CALCULATE B (TEMPORARILY IN F(.,1+IP0OFF)). IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM1, XM2, XM3, XZ, F, FANA) C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 IF (XAL(I) .EQ. ZERO) THEN C NONLINEAR, WITH INPUT A. ALPHA(I) = - XA(I) BETA(I) = - (F(I,1+IP0OFF) - XA(I)) ELSE C LINEAR, WITH CALCULATED A = B. ALPHA(I) = - F(I,1+IP0OFF) BETA(I) = ZERO ENDIF GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, FANA ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HA(I) , 3E22.14, /, E 1H , 8HAV. R(I), 3E22.14, /, F 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END cqxeps.f000644 000311 000121 00000000465 05306655000 012346 0ustar00krivecf1000000 000000 FUNCTION CQXEPS() REAL*16 CQXEPS C C ** MACHINE DEPENDENT ** C EPS (SMALLEST REAL*16 NUMBER SUCH THAT (1.Q0 + EPS) .GT. 1.Q0). C CQXEPS = 2.Q0 ** (-112) C* CONVEX C220 C* CQXEPS = 2.Q0 ** (-108) C* IBM RETURN END cqxtol.f000644 000311 000121 00000000450 05306655102 012352 0ustar00krivecf1000000 000000 FUNCTION CQXTOL() REAL*16 CQXTOL C C ** MACHINE DEPENDENT ** C TOL (SMALLEST REPRESENATBLE REAL*16 NUMBER). C CQXTOL = 2.Q0 ** (-16385) C* CONVEX C220 C* CQXTOL = 2.Q0 ** (-260) C* IBM RETURN END err2.f000644 000311 000121 00000000641 05213131662 011711 0ustar00krivecf1000000 000000 SUBROUTINE ERR2(NAME, NERR, ISTOP, NOUT) CHARACTER*6 NAME INTEGER NERR, ISTOP, NOUT C IF (ISTOP .NE. 1) WRITE (NOUT,1000) NERR, NAME IF (ISTOP .EQ. 1) WRITE (NOUT,1010) NERR, NAME IF (ISTOP .EQ. 1) CALL EXIT C 1000 FORMAT (1H , 16H** ERROR (W) , I16, 6H IN , A6, 5H **) 1010 FORMAT (1H , 16H**** ERROR (F) , I16, 6H IN , A6, 5H ****) RETURN END gauscq.f000644 000311 000121 00000003431 06067230162 012325 0ustar00krivecf1000000 000000 SUBROUTINE GAUSCQ(NDG, NDN, NDNZ, N, Z, P, AG, WG, NOUT, LPR) IMPLICIT REAL*16 (A-H, O-Z) LOGICAL LPR DIMENSION Z(NDNZ), P(NDN), AG(NDG), WG(NDG) C C C ABSCISSAS AND WEIGHTS FOR GAUSS INTEGRATION. C THE POSITIVE ABSCISSAS ARE GIVEN ONLY. C C CHARACTER*6 NAME DATA NAME / 'GAUSCQ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: CGAUSS 3.1, 90/04/07. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO, ONE, TWO / 0.Q0, 1.Q0, 2.Q0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N .LT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF ((N + 1) / 2 .GT. NDG) CALL ERR2(NAME, 2, 1, NOUT) IF (N + 1 .GT. NDN) CALL ERR2(NAME, 3, 1, NOUT) IF (N / 2 + 2 .GT. NDNZ) CALL ERR2(NAME, 4, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C IF (LPR) WRITE (NOUT,100) NAME, N, NDG, NDN, NDNZ CALL LP0ZQ(NDN, NDNZ, N, NZ, P, Z, NOUT) IF (LPR) WRITE (NOUT,102) NAME, N, NZ, NDN, NDNZ FN = TWO / (N * N) IP = 1 IF (MOD(N, 2) .EQ. 0) GO TO 10 CALL LP0Q(NDN, N - 1, ZERO, P, NOUT) WG(1) = FN / (P(N) * P(N)) AG(1) = ZERO IP = 2 10 CONTINUE DO 12 I = 1,NZ IF (LPR) WRITE (NOUT,104) NAME, I CALL LP0Q(NDN, N - 1, Z(I), P, NOUT) WG(IP) = FN * (ONE - Z(I) * Z(I)) / (P(N) * P(N)) AG(IP) = Z(I) IP = IP + 1 12 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 100 FORMAT ( A 2H -, A6, 1H-, 16H N NDG NDN NDNZ, 4I4) 102 FORMAT ( A 2H -, A6, 1H-, 16H N NZ NDN NDNZ, 4I4) 104 FORMAT ( A 2H -, A6, 1H-, 4H I, I4) END gausq.f000644 000311 000121 00000002650 06067230164 012166 0ustar00krivecf1000000 000000 SUBROUTINE GAUSQ(NDA, NDB, AG, WG, N, A, B, AG1, WG1, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION AG1(NDB), WG1(NDB) C ********** REAL*16 AG(NDA), WG(NDA) C ********** C C C ABSCISSAS AND WEIGHTS OF GAUSSIAN INTEGRATION FOR THE INTERVAL C (A, B). THE ORDER OF INTEGRATION IS N. C INPUT: THE POSITIVE ABSCISSAS AND THEIR WEIGHTS IN EXTENDED C PRECISION. C THIS ROUTINE DOES NOT TEST N AGAINST INPUT VALUES OF AG, WG. C C CHARACTER*6 NAME DATA NAME / 'GAUSQ ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: GAUSSA 2.0, 05.10.85. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, HALF / 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N .GT. NDB) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C ZA = HALF * (B - A) ZB = HALF * (B + A) N2 = N / 2 N12 = (N + 1) / 2 N21 = N2 + 1 NM2 = MOD(N, 2) IF (NM2 .EQ. 0) GO TO 10 AG1(N2+1) = ZB WG1(N2+1) = WG(1) 10 CONTINUE DO 12 I = 1,N2 AG1(N12+I) = ZA * AG(I+NM2) + ZB WG1(N12+I) = ZA * WG(I+NM2) AG1(N21-I) = - ZA * AG(I+NM2) + ZB WG1(N21-I) = WG1(N12+I) 12 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END lp0q.f000644 000311 000121 00000002031 06067230205 011707 0ustar00krivecf1000000 000000 SUBROUTINE LP0Q(NDN, NU, X, P, NOUT) IMPLICIT REAL*16 (A-H, O-Z) DIMENSION P(NDN) C C C VALUES OF LEGENDRE POLYNOMIALS P (X), N = 0, ..., NU. C N C P(N + 1) = P (X). C N C CHARACTER*6 NAME DATA NAME / 'LP0Q ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: PNVAL 1.1, 20.9.85. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE / 1.Q0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (NU + 1 .GT. NDN) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C P(1) = ONE IF (NU .EQ. 0) RETURN P(2) = X IF (NU .EQ. 1) RETURN N1U = NU + 1 DO 10 N1 = 3,N1U P(N1) = ((N1 + N1 - 3) * X * P(N1-1) - 1 (N1 - 2) * P(N1-2)) 2 / (N1 - 1) 10 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END lp0zq.f000644 000311 000121 00000004274 06067230206 012115 0ustar00krivecf1000000 000000 SUBROUTINE LP0ZQ(NDN, NDNZ, N, NZ, P, Z, NOUT) IMPLICIT REAL*16 (A-H, O-Z) DIMENSION P(NDN), Z(NDNZ) C C C ZEROS OF P (X) IN THE (OPEN) INTERVAL (0, 1). C N C CHARACTER*6 NAME DATA NAME / 'LP0ZQ ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: PNZERC 1.0C, 90/04/18. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TWO, ONE4 / 0.Q0, 1.Q0, 2.Q0, 0.25Q0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N + 1 .GT. NDN) CALL ERR2(NAME, 1, 1, NOUT) IF (N / 2 + 2 .GT. NDNZ) CALL ERR2(NAME, 2, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C EPS = CQXEPS() TOL = TWO ** 8 * CQXTOL() C NZ = N / 2 IF (NZ .EQ. 0) RETURN NZ2 = NZ + 2 N1 = N + 1 Z(1) = - ONE / NZ Z(2) = ZERO DO 20 I = 3,NZ2 H = ONE4 * (Z(I-1) - Z(I-2)) X0 = Z(I-1) + H CALL LP0Q(NDN, N, X0, P, NOUT) F0 = P(N1) S0 = SIGN(ONE, F0) X1 = X0 X2 = X0 10 CONTINUE X1 = X1 + H CALL LP0Q(NDN, N, X1, P, NOUT) IF (ABS(P(N1)) .LT. EPS) GO TO 18 IF (SIGN(ONE, P(N1)) .EQ. S0) GO TO 10 F1 = P(N1) DNEW = ABS(X1 - X0) 12 CONTINUE DOLD = DNEW X2 = (X0 * F1 - X1 * F0) / (F1 - F0) CALL LP0Q(NDN, N, X2, P, NOUT) IF (ABS(P(N1)) .LT. EPS) GO TO 18 F2 = P(N1) IF (SIGN(ONE, F2) .EQ. S0) GO TO 14 X1 = X2 F1 = F2 GO TO 16 14 CONTINUE X0 = X2 F0 = F2 S0 = SIGN(ONE, F2) 16 CONTINUE DNEW = ABS(X1 - X0) IF (DNEW .GE. DOLD) GO TO 18 IF (ABS(F1 - F0) .LT. TOL) GO TO 18 GO TO 12 18 CONTINUE Z(I) = X2 20 CONTINUE DO 22 I = 1,NZ Z(I) = Z(I+2) 22 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m1pioh.f000644 000311 000121 00000043507 06067230216 012247 0ustar00krivecf1000000 000000 SUBROUTINE M1PIOH(NIN, NOUT, NIN1, NOUT1, MODE, LCFC, LVC, 1 NDFPAR, NDVPAR, NDP0, NDWK, 2 XMASS1, XMASS2, XMASS3, XINF, 3 MUU, IPOS, PSYM, 4 IPFL, IPFU, IPVL, IPVU, IPWU, 5 FPAR, MODF, F, FANA, VPAR, MODV, V, WK, 6 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 7 IP0OFF, IP0XU, IPOFF, IPXU) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LCFC, LVC, PSYM DIMENSION FPAR(3,NDFPAR), F(3,NDP0), FANA(3,3), 1 VPAR(3,NDVPAR), V(3,NDP0), WK(3,NDWK), 2 NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2) C C C PARAMETER INPUT/OUTPUT ROUTINE FOR MATRIX ELEMENTS. C C THIS ROUTINE PERFORMS FORMATTED AND UNFORMATTED INPUT/OUTPUT C OF PARAMETERS, NOT MATRIX ELEMENTS. IT HAS TWO INPUT AND C TWO OUTPUT CHANNELS WHICH ARE ACTIVATED ACCORDING TO THE C VALUE OF MODE. C C EXAMPLE: THE FIRST PROGRAM IN THE CHAIN USES THIS ROUTINE TO C READ PARAMETERS AND STORE THEM IN AN UNFORMATTED FILE; C THE NEXT PROGRAM USES THIS ROUTINE TO READ THOSE PARAMETERS C FROM THAT UNFORMATTED FILE, AND STORE THEM IN THE NEXT FILE, C ETC. EACH TIME THE PARAMETERS ARE ALSO PRINTED. C C C CHANNEL FILE TYPE C (UNIT NUMBER) (NO OPEN STAT. NEEDED) C C NIN FORMATTED (F), SEQUENTIAL C NOUT FORMATTED, SEQUENTIAL C NIN1 UNFORMATTED (U/F), SEQUENTIAL C NOUT1 UNFORMATTED, SEQUENTIAL C C C MODE ACTION COMMENT C C 1 F IN, F OUT USED IN M2M- C 2 F IN, F OUT, U/F OUT USED IN M2M- C 3 U/F IN, F OUT USED IN SCH. EQ. SOL. PROG. C 4 U/F IN, F OUT, U/F OUT USED IN SCH. EQ. SOL. PROG. C 5 U/F IN, F OUT AS 3, BUT CALCULATES FANA; C USED IN AVERAGES PROGRAM C C C NOTE THAT IP0OFF , IP0XU , IPOFF , IPXU ARE CALCULATED IN C THIS ROUTINE IF NECESSARY. FANA , F , V ARE CALCULATED IF C MODE = 1, 2, OR 5. C C C NEGATIVE MASSES ARE CHANGED TO XINF ("INFINITE") IMMEDIATELY C AFTER FIRST FORMATTED READ, SO THAT THEY NEVER REAPPEAR C IN ANY SUBSEQUENT FILE. C C CHARACTER*6 NAME DATA NAME / 'M1PIOH' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 92/11/26 (MODE = 5 (FANA); CFC004; 5) (M1PIOG 2.1) ' / C ------------------------------------------------------------ C C LOGICAL LCALL0, LIF, LIU, LOF, LOU, LFV DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C DEFINE ACTIONS. C --------------- C IF (MODE .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (MODE .GT. 5) CALL ERR2(NAME, 2, 1, NOUT) C LIF = MODE .EQ. 1 .OR. MODE .EQ. 2 LIU = MODE .EQ. 3 .OR. MODE .EQ. 4 .OR. MODE .EQ. 5 LOF = .TRUE. LOU = MODE .EQ. 2 .OR. MODE .EQ. 4 LFV = MODE .EQ. 1 .OR. MODE .EQ. 2 .OR. MODE .EQ. 5 C C C MASSES OF PARTICLES. C ==================== C C A NEGATIVE MASS IS PUT EQUAL TO XINF WHEN FIRST INPUT C ("INFINITE," INPUT, SEE DEFINITION ELSEWHERE). C IF (LIF) READ (NIN,1012) XMASS1, XMASS2, XMASS3 IF (LIF) THEN IF (XMASS1 .LE. 0.D0) CALL ERR2(NAME, 11, 0, NOUT) IF (XMASS2 .LE. 0.D0) CALL ERR2(NAME, 12, 0, NOUT) IF (XMASS3 .LE. 0.D0) CALL ERR2(NAME, 13, 0, NOUT) IF (XMASS1 .LT. 0.D0) XMASS1 = XINF IF (XMASS2 .LT. 0.D0) XMASS2 = XINF IF (XMASS3 .LT. 0.D0) XMASS3 = XINF ENDIF IF (LIU) READ (NIN1) XMASS1, XMASS2, XMASS3 IF (LOF) WRITE (NOUT,2020) XMASS1, XMASS2, XMASS3 IF (LOU) WRITE (NOUT1) XMASS1, XMASS2, XMASS3 C C C MAX. MU (MATRIX), IPOS, PSYM FOR STATES. C ======================================== C IF (LIF) READ (NIN,1014) MUU, IPOS, PSYM IF (LIU) READ (NIN1) MUU, IPOS, PSYM IF (LOF) WRITE (NOUT,2030) MUU, IPOS, PSYM IF (LOU) WRITE (NOUT1) MUU, IPOS, PSYM C C C F, V POWER RANGES AND MATRIX ELEMENT POWER CUTOFF ( IPWU ). C =========================================================== C C F POWERS: (IPFL,..., IPFU). C V POWERS: (IPVL,..., IPVU). C IF (LIF) READ (NIN,1010) IPFL, IPFU, IPVL, IPVU, IPWU IF (LIU) READ (NIN1) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOF) WRITE (NOUT,2040) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOU) WRITE (NOUT1) IPFL, IPFU, IPVL, IPVU, IPWU C C C STORAGE OFFSET AND NUMBER OF POWERS IN THE COMMON RANGE C OF POWERS FOR F, V (UNION OF RANGES OF F AND V). C ------------------------------------------------------- C IP0OFF = 1 - MIN(IPFL, IPVL) IP0XU = MAX(IPFU, IPVU) - MIN(IPFL, IPVL) + 1 IF (IP0XU .GT. NDP0) CALL ERR2(NAME, 21, 1, NOUT) IF (LOF) WRITE (NOUT,2042) IP0OFF, IP0XU C C STORAGE OFFSET AND NUMBER OF POWERS FOR THE HH EXPANSION C COEFFICIENTS AND FINAL MATRIX ELEMENTS. C -------------------------------------------------------- C IPOFF = -999 IPXU = -999 IF (LIF) THEN C SMALLEST AND LARGEST POWERS ( IPL , IPU ). C IPWU IS THE MAXIMUM REQUIRED POWER IN THE MATRIX ELEMENTS C OF W . C IF THE SERIES FOR F IS FINITE, THE MAXIMUM POWER, IPU0 , C IS GIVEN BY THE FORMULA BELOW. C IF THE SERIES FOR F IS INFINITE, IT CAN BE SHOWN THAT C THE HIGHEST POWER IN W WHICH IS NOT AFFECTED BY THE C CUTOFF OF POWERS IN F IS IPFU - 2 WHERE IPFU IS C THE LARGEST POWER OF F USED. C WARNING 22 APPLIES TO FINITE SERIES AND WARNS THAT NOT C ALL EXISTING POWERS IN W WILL BE CALCULATED (IGNORE C IN CASE OF INFINITE SERIES). C WARNING 23 APPLIES TO INFINITE SERIES AND WARNS THAT C MORE POWERS IN W WILL BE CALCULATED THAN ARE C UNAFFECTED BY THE CUTOFF IN F (IGNORE FOR FINITE C SERIES). C DIMENSION TESTS COME LATER IN MATRIX ELEMENT ROUTINES. C OFFSET: ARRAY INDEX = POWER + OFFSET. C IPL = MIN(IPVL, IPFL-2, 2*IPFL-2, IPFL-1) IPU0 = MAX(IPVU, IPFU-2, 2*IPFU-2, IPFU-1) IPU = MIN(IPU0, IPWU) IF (IPWU .LT. IPU0) CALL ERR2(NAME, 22, 0, NOUT) IF (IPWU .GT. MAX(IPVU, IPFU-2)) CALL ERR2(NAME, 23, 0, NOUT) IPOFF = 1 - IPL IPXU = IPU + IPOFF IF (LOF) WRITE (NOUT,2044) IPOFF, IPXU ENDIF C C C PARAMETERS OF THE CORRELATION FUNCTION. C ======================================= C C THE PROCEDURE: C (1) READ PARAMETERS USUALLY CALLED ALPHA(I), C BETA(I),..., I = 1,2,3, INTO THE ARRAY FPAR(I,K) , C K = 1,..., NFPAR . C (2) READ A MODE SWITCH ( MODF ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING FPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPFL , IPFU . C (THERE HAVE TO BE SOME BOUNDS IF THE CORRELATION C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN F(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NFPAR IF (LIU) READ (NIN1) NFPAR IF (LOF) WRITE (NOUT,2050) NFPAR IF (LOU) WRITE (NOUT1) NFPAR C IF (NFPAR .LT. 1) CALL ERR2(NAME, 31, 1, NOUT) IF (NFPAR .GT. NDFPAR) CALL ERR2(NAME, 32, 1, NOUT) C DO 30 K = 1,NFPAR C IF (LIF) READ (NIN,1100) J, (FPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (FPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2060) J, (FPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (FPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 33, 1, NOUT) IF (J .GT. NDFPAR) CALL ERR2(NAME, 34, 1, NOUT) 30 CONTINUE C IF (LIF) READ (NIN,1010) MODF IF (LIU) READ (NIN1) MODF IF (LOF) WRITE (NOUT,2062) MODF IF (LOU) WRITE (NOUT1) MODF C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE CORRELATION FUNCTION. C ---------------------------------------------------------- C C CUSP PARAMETRIZATION IS DONE BY CFC002. NOTE THAT THE C INPUT USED BY CFC002 (MASSES, CHARGES) IS INDEPENDENT OF C THE V COEFFICIENTS READ IN BELOW. THE CONSISTENCY TEST C IS DONE AFTER READING IN THE V COEFFICIENTS. C C IF (MODF.LT.0 .OR. MODF.GT.5) CALL ERR2(NAME, 35, 1, NOUT) IF (MODF .EQ. 0) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 36, 1, NOUT) CALL CFC000(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), F, FANA) ENDIF IF (MODF .EQ. 1) THEN IF (NFPAR .NE. 3) CALL ERR2(NAME, 37, 1, NOUT) CALL CFC001(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), FPAR(1,3), F, FANA) ENDIF IF (MODF .EQ. 2) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 38, 1, NOUT) CALL CFC002(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, FPAR(1,1), 3 F, FANA) ENDIF IF (MODF .EQ. 3) THEN IF (NFPAR .NE. 2) CALL ERR2(NAME, 39, 1, NOUT) CALL CFC003(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), F) ENDIF IF (MODF .EQ. 4) THEN C FPAR: XZ, XE, XA, XR, XN (SEE CFC004). IF (NFPAR .NE. 5) CALL ERR2(NAME, 40, 1, NOUT) CALL CFC004(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), D1, D2, D, F, FANA) ENDIF IF (MODF .EQ. 5) THEN IF (NFPAR .NE. 5) CALL ERR2(NAME, 41, 1, NOUT) CALL CFC005(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), F, FANA) ENDIF IF (LCFC) WRITE (NOUT,2200) NAME, FANA ENDIF C C C PARAMETERS OF THE POTENTIAL V. C ============================== C C THE PROCEDURE: C (1) READ PARAMETERS INTO THE ARRAY VPAR(I,K) , C K = 1,..., NVPAR . C (2) READ A MODE SWITCH ( MODV ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING VPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPVL , IPVU . C (THERE HAVE TO BE SOME BOUNDS IF THE POTENTIAL C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN V(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NVPAR IF (LIU) READ (NIN1) NVPAR IF (LOF) WRITE (NOUT,2070) NVPAR IF (LOU) WRITE (NOUT1) NVPAR C IF (NVPAR .LT. 1) CALL ERR2(NAME, 51, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 52, 1, NOUT) C DO 40 K = 1,NVPAR C IF (LIF) READ (NIN,1100) J, (VPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (VPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2080) J, (VPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (VPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 53, 1, NOUT) IF (J .GT. NDVPAR) CALL ERR2(NAME, 54, 1, NOUT) 40 CONTINUE C IF (LIF) READ (NIN,1010) MODV IF (LIU) READ (NIN1) MODV IF (LOF) WRITE (NOUT,2082) MODV IF (LOU) WRITE (NOUT1) MODV C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE POTENTIAL. C ----------------------------------------------- C IF (MODV.LT.0 .OR. MODV.GT.1) CALL ERR2(NAME, 55, 1, NOUT) IF (MODV .EQ. 0) THEN CALL VC000(NDVPAR, NDP0, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) ENDIF IF (MODV .EQ. 1) THEN CALL VC001(NDVPAR, NDP0, NDWK, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) ENDIF ENDIF C C IF (LIF .AND. (MODF .EQ. 2 .OR. MODF .EQ. 4 .OR. MODF .EQ. 5)) 1 THEN C C CONSISTENCY CHECK, TRUE CUSPS (ANY MODV ). C ------------------------------------------- C C TEST CUSP PARAMETERS VS. V PARAMETERS: FPAR ARE PRODUCTS C OF CHARGES IN THIS CASE (SEE CFC002), AND MUST BE EQUAL C TO THE V-COEFFICIENTS OF POWER -1. (FATAL ERRORS ONLY IF C MODF = 2 TO ENABLE FLEXIBILITY IN F.) C IF (MODF .EQ. 2) THEN ZZZ0 = 100 * CDXEPS() IERR = 1 ELSE ZZZ0 = 10 * CDXEPS() IERR = 0 ENDIF IF (IPVL .GT. -1 .OR. IPVU .LT. -1) 1 CALL ERR2(NAME, 60, 1, NOUT) ZZZ1 = V(1,-1+IP0OFF) ZZZ2 = V(2,-1+IP0OFF) ZZZ3 = V(3,-1+IP0OFF) IF (ABS(ZZZ1 - FPAR(1,1)) .GT. ABS(ZZZ0 * ZZZ1)) 1 CALL ERR2(NAME, 61, IERR, NOUT) IF (ABS(ZZZ2 - FPAR(2,1)) .GT. ABS(ZZZ0 * ZZZ2)) 1 CALL ERR2(NAME, 62, IERR, NOUT) IF (ABS(ZZZ3 - FPAR(3,1)) .GT. ABS(ZZZ0 * ZZZ3)) 1 CALL ERR2(NAME, 63, IERR, NOUT) ENDIF C C C GAUSSIAN INTEGRATION PARAMETERS. C ================================ C IF (LIF) READ (NIN,1010) (NGOA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NSUBA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NGOL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NGOL(I,2), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,2), I = 1,10) IF (LIF) READ (NIN,1030) DAS, DLS C IF (LIU) READ (NIN1) (NGOA(I), I = 1,2) IF (LIU) READ (NIN1) (NSUBA(I), I = 1,2) IF (LIU) READ (NIN1) (NGOL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NGOL(I,2), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,2), I = 1,10) IF (LIU) READ (NIN1) DAS, DLS C IF (LOF) WRITE (NOUT,2120) (NGOA(I), I = 1,2), 1 (NSUBA(I), I = 1,2), 2 (NGOL(I,1), I = 1,10), 3 (NSUBL(I,1), I = 1,10), 4 (NGOL(I,2), I = 1,10), 5 (NSUBL(I,2), I = 1,10), 6 DAS, DLS C IF (LOU) WRITE (NOUT1) (NGOA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NSUBA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NGOL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NGOL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) DAS, DLS C RETURN C C 1010 FORMAT (20I4) 1012 FORMAT (3F20.6) 1014 FORMAT (2I4, L4) 1030 FORMAT (10F8.2) 1100 FORMAT (I4, 3F20.16) C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2020 FORMAT (//, A 1H , 40HMASS1 , D28.16, /, B 1H , 40HMASS2 , D28.16, /, C 1H , 40HMASS3 , D28.16) 2030 FORMAT ( A 1H , 40HMUU; IPOS, PSYM (IGNORED) , 2I4, L4) 2040 FORMAT ( A 1H , 40HIPFL, IPFU , 2I4, /, B 1H , 40HIPVL, IPVU , 2I4, /, C 1H , 40HIPWU (CUTOFF) , I4) 2042 FORMAT ( A 1H , 40H CALCULATED: IP0OFF, IP0XU , 2I4) 2044 FORMAT ( A 1H , 40H CALCULATED: IPOFF, IPXU , 2I4) 2050 FORMAT ( A 1H , 32HNFPAR , I4) 2060 FORMAT ( A 1H , 36HJ, FPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2062 FORMAT ( A 1H , 32HMODF (F FORMULA SELECTOR) , I4) 2070 FORMAT ( A 1H , 32HNVPAR , I4) 2080 FORMAT ( A 1H , 36HJ, VPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2082 FORMAT ( A 1H , 32HMODV (V FORMULA SELECTOR) , I4) 2120 FORMAT (//, A 1H , 32HINTEGRATION PARAMETERS , /, B 1H , 32HNGOA , 2I4, /, C 1H , 32HNSUBA , 2I4, /, D 1H , 32HNGOL(.,1) , 10I4, /, E 1H , 32HNSUBL(.,1) , 10I4, /, F 1H , 32HNGOL(.,2) , 10I4, /, G 1H , 32HNSUBL(.,2) , 10I4, /, H 1H , 32HDAS, DLS , 2F12.6) 2200 FORMAT (1H , 1H-, A6, 1H-, /, A 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END m1pjxa.f000644 000311 000121 00000004432 06067233046 012250 0ustar00krivecf1000000 000000 SUBROUTINE M1PJXA(NDX, NDPJ, N, K, NX, XX, NOUT, PTEST, PJ) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL PTEST DIMENSION PJ(NDX,NDPJ), XX(NDX) C C C C (K,0) C CALCULATES JACOBI POLYNOMIALS P (X(I)), M, K INTEGER, C M C C M = 0, 1,..., N, I = 1,..., NX, BY THE STABLE UPWARD RECURSION. C THE ABOVE POLYNOMIAL VALUE IS IN THE LOCATION PJ(I,M+1). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M1PJXA' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (K .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (N .LT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (N+1 .GT. NDPJ) CALL ERR2(NAME, 3, 1, NOUT) IF (NX .LT. 1) CALL ERR2(NAME, 4, 1, NOUT) IF (NX .GT. NDX) CALL ERR2(NAME, 5, 1, NOUT) C C C N = 0. DO 20 J = 1,NX PJ(J,1) = 1.D0 20 CONTINUE IF (PTEST) WRITE (NOUT,2100) NAME, 1 K, (J, XX(J), PJ(J,1), J = 1,NX) IF (N .EQ. 0) RETURN C C C N = 1. DO 30 J = 1,NX PJ(J,2) = 0.5D0 * (DFLOAT(K + 2) * XX(J) + K) 30 CONTINUE IF (PTEST) WRITE (NOUT,2110) NAME, 1 K, (J, XX(J), PJ(J,2), J = 1,NX) IF (N .EQ. 1) RETURN C C C N = 2,.... DO 50 I = 2,N ZZ1 = ((K + 2*I) - 1) * ((K + 2*I) - 2) * (K + 2*I) ZZ2 = ((K + 2*I) - 1) * K * K ZZ3 = -2*(K + I - 1) * (I - 1) * (K + 2*I) ZZ4 = 2 * I * (K + I) * ((K + 2*I) - 2) DO 40 J = 1,NX PJ(J,I+1) = ( (ZZ1 * XX(J) + ZZ2) * PJ(J,I) + 1 ZZ3 * PJ(J,I-1) ) / ZZ4 40 CONTINUE IF (PTEST) WRITE (NOUT,2120) NAME, 1 I, K, (J, XX(J), PJ(J,I+1), J = 1,NX) 50 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.2, 95/12/24. 1.1, 90/03/01. ) C ======================================== 2100 FORMAT ( A 1H , A6, 16H PJ, N = 0, K =, I4, /, B (1H , I4, 2F24.16)) 2110 FORMAT ( A 1H , A6, 16H PJ, N = 1, K =, I4, /, B (1H , I4, 2F24.16)) 2120 FORMAT ( A 1H , A6, 12H PJ, N =, I4, 6H, K =, I4, /, B (1H , I4, 2F24.16)) END m1xgqa.f000644 000311 000121 00000005261 06067230220 012236 0ustar00krivecf1000000 000000 SUBROUTINE M1XGQA(NDQ, NDGO, NDGO1, NDGO2, NDGO1Z, 1 N, NSI, A, B, 2 P, Z, AG, WG, AG1, WG1, PTESTG, 3 NOUT, 4 NQ, X, W) IMPLICIT REAL * 8 (A-H, O-Z) LOGICAL PTESTG DIMENSION AG1(NDGO), WG1(NDGO), X(NDQ), W(NDQ) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C MULTIPLE GAUSSIAN QUADRATURE POINTS AND WEIGHTS ON (A, B). C PRIMARY ABSCISSAS/WEIGHTS ARE CALCULATED IN EXTENDED PRECISION. C VALUES AGREE WITH THOSE OF ABRAMOWITZ/STEGUN EVEN FOR N = 96, C EXCEPT IN TWO INSTANCES WHERE THE 21-ST DIGIT AFTER COMMA C DIFFERS (MAYBE THE A/S BOOK HAS ERROS). C C ON ENTRY C N GAUSSIAN ORDER C NSI NUMBER OF SUBDIVISIONS OF (A, B) C A, B BOUNDS OF (A, B) C PTESTG TEST OUTPUT BY CGAUSS. C C ON EXIT C NQ FINAL NUMBER OF QUADRATURE POINTS. C X(I) I = 1,..., NQ, QUADRATURE POINTS. C W(I) I = 1,..., NQ, QUADRATURE WEIGHTS. C C THE REST ARE WORKING ARRAYS. C C CHARACTER*6 NAME DATA NAME / 'M1XGQA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: M1XGA 1.0, 90/02/26. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, XTOL / 1.0D-10 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (N .LT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. NDGO) CALL ERR2(NAME, 2, 1, NOUT) IF (N+1 .GT. NDGO1) CALL ERR2(NAME, 3, 1, NOUT) IF ((N+1)/2 .GT. NDGO2) CALL ERR2(NAME, 4, 1, NOUT) IF (N/2+2 .GT. NDGO1Z) CALL ERR2(NAME, 5, 1, NOUT) IF (N*NSI .GT. NDQ) CALL ERR2(NAME, 6, 1, NOUT) IF (NSI .LT. 1) CALL ERR2(NAME, 7, 1, NOUT) IF (B - A .LT. XTOL) CALL ERR2(NAME, 8, 1, NOUT) C C HALF OF GAUSSIAN POINTS FOR ORDER N. CALL GAUSCQ(NDGO2, NDGO1, NDGO1Z, 1 N, Z, P, AG, WG, NOUT, PTESTG) C C LOOP OVER SUBINTERVALS. H = (B - A) / NSI NQ = 0 DO 22 I = 1,NSI ASI = A + H * (I - 1) BSI = A + H * I IF (I .EQ. NSI) BSI = B CALL GAUSQ(NDGO2, NDGO, AG, WG, N, ASI, BSI, AG1, WG1, NOUT) C C ADD POINTS TO GRID. DO 20 J = 1,N NQ = NQ + 1 X(NQ) = AG1(J) W(NQ) = WG1(J) 20 CONTINUE 22 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END tempd.f000644 000311 000121 00000002513 05575327000 012154 0ustar00krivecf1000000 000000 SUBROUTINE TEMPD(TOLD, TNEW, TDIF, NOUT, LPR) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LPR C C CONVEX TIMING ROUTINE, USING CPUTIME(), WALLTIME(). C REASON: OLD TEMPD USED ETIME(,) WHICH RETURNS STRANGE VALUES C UPON -O3. TESTING 93/04/07... C PRINTS THE CURRENT CPU TIME, THE DIFFERENCE FROM THE C REFERENCE TIME (TOLD), AND TOLD. WALLTIME FROM ZERO IS PRINTED C ONLY, ALSO ON THE FIRST CALL. C NOUT IS THE OUTPUT UNIT NUMBER. C LOGICAL INIT REAL*4 CPUTIME, WALLTIME, SZERO, X DATA INIT / .TRUE. /, SZERO / 0.0 / C IF (.NOT. INIT) GO TO 10 WRITE (NOUT,2000) INIT = .FALSE. X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2200) WALL RETURN 10 CONTINUE X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2100) TNEW, TDIF, TOLD, WALL RETURN C 2000 FORMAT (1H , 48H-TEMPD- 2.0C, 94/06/08. CONVEX TIMING ROUTINE. ) 2100 FORMAT (1H , 2X, 4HCPU , F12.2, A 8H DIF, F12.2, B 8H REF, F12.2, C 8H WALL, F12.2) 2200 FORMAT (1H , 2X, 16X, 40X, A 8H WALL, F12.2) END vc000.f000644 000311 000121 00000003315 06067230324 011673 0ustar00krivecf1000000 000000 SUBROUTINE VC000(NDVPAR, NDP0, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C R(I) POWER SERIES COEFFICIENTS OF THE POTENTIAL C C V = SUM(I=1...3) SUM(J=1...NVPAR) VPAR(I,J) * R(I)**(IPVL-1+J) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: V(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C C CHARACTER*6 NAME DATA NAME / 'VC000 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. O: CFC000 1.1, 90/03/28. ' / C ------------------------------------------------------------ LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C CHECK NUMBER OF PARAMETERS. (IT MAY NOT EXCEED THE REQUIRED C NUMBER OF POWERS AS GIVEN BY (IPVL, IPVU).) IF (NVPAR .GT. IPVU - IPVL + 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 2, 1, NOUT) C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C DO 12 J = 1,NVPAR IP0 = (IPVL - 1) + J IP0X = IP0 + IP0OFF DO 10 I = 1,3 V(I,IP0X) = VPAR(I,J) 10 CONTINUE 12 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END vc001.f000644 000311 000121 00000005470 06067230326 011702 0ustar00krivecf1000000 000000 SUBROUTINE VC001(NDVPAR, NDP0, NDWK, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WK(3,NDWK), VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C THE INPUT ARRAY VPAR IS INTERPRETED SUCH THAT C THE POTENTIAL IS A SUM OF YUKAWA TERMS: C C V = SUM(I=1...3) SUM(K=1...NVPAR/2) C VPAR(I,2*K-1) * EXP(-VPAR(I,2*K) * R(I)) / R(I) C C NVPAR MUST BE EVEN AND NDWK .GE. NVPAR / 2. C C CHARACTER*6 NAME DATA NAME / 'VC001 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. ' / C ------------------------------------------------------------ C DIMENSION S(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPVL .NE. -1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU .LT. IPVL) CALL ERR2(NAME, 2, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 3, 1, NOUT) C ZERO = 0.0D0 ONE = 1.0D0 C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C C NUMBER OF YUKAWA TERMS, FROM NUMBER OF INPUT TERMS. IF (MOD(NVPAR, 2) .NE. 0) CALL ERR2(NAME, 11, 1, NOUT) NET = NVPAR / 2 IF (NET .GT. NDWK) CALL ERR2(NAME, 12, 1, NOUT) C C NUMBER OF POWERS TO BE GENERATED. NEP = IPVU - IPVL + 1 IF (NEP .GT. NDP0) CALL ERR2(NAME, 13, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 14, 1, NOUT) C C INITIALIZE. P = ONE DO 12 K = 1,NET DO 10 I = 1,3 WK(I,K) = VPAR(I,2*K-1) 10 CONTINUE 12 CONTINUE C C LOOP OVER POWERS. DO 40 J = 1,NEP C C POWER AND ITS INDEX. IP0 = J - 2 IP0X = IP0 + IP0OFF C S(1) = ZERO S(2) = ZERO S(3) = ZERO DO 22 K = 1,NET DO 20 I = 1,3 S(I) = S(I) + WK(I,K) 20 CONTINUE 22 CONTINUE C C CALCULATE THE V COEFFICIENTS. V(1,IP0X) = P * S(1) V(2,IP0X) = P * S(2) V(3,IP0X) = P * S(3) C C UPDATE FOR THE NEXT POWER (IP0 + 1). P = P / DFLOAT(IP0 + 2) DO 32 K = 1,NET DO 30 I = 1,3 WK(I,K) = WK(I,K) * (- VPAR(I,2*K)) 30 CONTINUE 32 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) 40 CONTINUE RETURN C 2000 FORMAT (2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END epioa.f000644 000311 000121 00000010225 06067230153 012136 0ustar00krivecf1000000 000000 SUBROUTINE EPIOA(MODE, NIN, NOUT, NIN1, NOUT1, 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, A, B, EPSP, TOL, DZU, 3 ZM, ZMATCH, ZTOP, NHH, 4 LMOD, ENXL, ENXU, ENXS, 5 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT) IMPLICIT REAL*8 (A-H, O-Z) C C READS / WRITES PARAMETERS FOR THE ENERGY SEARCH. C MODE = 1 USED IN COULDR, MODE = 2 USED IN AVERAGES PROGRAM. C CHARACTER*6 NAME DATA NAME / 'EPIOA ' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/10/24. ' / C ------------------------------------------------------------ C LOGICAL LCALL0, LIF, LIU, LOF, LOU DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MODE .LT. 1 .OR. MODE .GT. 2) CALL ERR2(NAME, 1, 1, NOUT) C LIF = MODE .EQ. 1 LOF = MODE .EQ. 1 .OR. MODE .EQ. 2 LIU = MODE .EQ. 2 LOU = MODE .EQ. 1 C IF (LIF) THEN READ (NIN,1020) IPWUU, NSU, INUSEL READ (NIN,1020) NM, JMAX READ (NIN,1030) BC0, BC1, RHOUW READ (NIN,1032) A, B READ (NIN,1040) EPSP, TOL, DZU READ (NIN,1030) ZM, ZMATCH, ZTOP READ (NIN,1020) NHH READ (NIN,1020) LMOD READ (NIN,1032) ENXL, ENXU, ENXS READ (NIN,1020) IPIO READ (NIN,1034) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF C IF (LIU) THEN READ (NIN1) IPWUU, NSU, INUSEL READ (NIN1) NM, JMAX READ (NIN1) BC0, BC1, RHOUW READ (NIN1) A, B READ (NIN1) EPSP, TOL, DZU READ (NIN1) ZM, ZMATCH, ZTOP READ (NIN1) NHH READ (NIN1) LMOD READ (NIN1) ENXL, ENXU, ENXS READ (NIN1) IPIO READ (NIN1) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF C IF (LOF) WRITE (NOUT,4100) 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, 3 A, B, 4 EPSP, TOL, DZU, 5 ZM, ZMATCH, ZTOP, 6 NHH, 7 LMOD, ENXL, ENXU, ENXS, 8 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT C IF (LOU) THEN WRITE (NOUT1) IPWUU, NSU, INUSEL WRITE (NOUT1) NM, JMAX WRITE (NOUT1) BC0, BC1, RHOUW WRITE (NOUT1) A, B WRITE (NOUT1) EPSP, TOL, DZU WRITE (NOUT1) ZM, ZMATCH, ZTOP WRITE (NOUT1) NHH WRITE (NOUT1) LMOD WRITE (NOUT1) ENXL, ENXU, ENXS WRITE (NOUT1) IPIO WRITE (NOUT1) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF RETURN C 1020 FORMAT (20I4) 1030 FORMAT (10F8.2) 1032 FORMAT (4F16.12) 1034 FORMAT (2F8.2, 2I4) 1040 FORMAT (5D16.7) C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 4100 FORMAT ( 1 1H , 20HIPWUU, NSU, INUSEL , 2I8, I4, /, 2 1H , 20HNM, JMAX , 2I4, /, 3 1H , 20HBC0, BC1, RHOUW , 2F12.4, F12.2, /, 4 1H , 20HA, B , 2F20.12, /, 5 1H , 20HEPSP, TOL, DZU , D16.4, F12.6, F12.2, //, 6 1H , 20HZM, ZMATCH, ZTOP , F12.4, 2F12.2, /, 7 1H , 20HNHH , I8, //, 8 1H , 20HLMOD , I4, /, 9 1H , 20HENXL, ENXU, ENXS , 3F18.12, /, A 1H , 20HIPIO , I4, /, B 1H , 20H(Z0MTTT, Z0MTTD),R,C, 2F12.6, 2I4) END a5qzb.f000644 000311 000121 00000010302 06067227764 012075 0ustar00krivecf1000000 000000 SUBROUTINE A5QZB(NDZ, NDOP, NDOPRH, NDOPR1, 1 NZ, NOPR, NOPD, HC0, HC1, LTESTQ, 2 RHOP, RPZ, WPSZ, WAL, WALH, AUXA1, ARG1A, 3 WF, WFD, WFA, WFL, WFZ, WFZZ, 4 CF, CFR, CFRR, CFA, CFAA, CFL, CFLL, VF, 5 NOUT, QI) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION RHOP(NDZ,4), RPZ(NDOPR1,NDZ), WPSZ(NDZ), WAL(NDOPRH), 1 WF(NDZ), WFD(NDZ), WFA(NDZ), 2 WFL(NDZ), WFZ(NDZ), WFZZ(NDZ), 3 CF(NDZ), CFR(NDZ), CFRR(NDZ), 4 CFA(NDZ), CFAA(NDZ), CFL(NDZ), CFLL(NDZ), 5 VF(NDZ), QI(NDOP) LOGICAL LTESTQ C C Z QUADRATURE OVER A Z INTERVAL (SUBDIVIDED IN SEGMENTS), WITH C FIXED A, LAMBDA. C LTESTQ: TEST QUADRATURE AT DEEP LEVEL. CALCULATES ONLY THE C INTEGRALS QI(1) AND QI(NOPR+NOPD+8), BUT WITHOUT THE EXPRESSION C EXP(2 * CF(IZ)) * WF(IZ) ** 2, C I.E., INTEGRATING ONLY THE Z, A, LAMBDA WEIGHTS. THE RESULT C DEPENDS ON THE NORMALIZATION OF WEIGHTS. IN AV3MG NORMALIZATION, C THE RESULT SHOULD BE (ZTOP**2/2)(2 PI). C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'A5QZB ' / CHARACTER*60 VERS DATA VERS */ '1.1, 93/12/06. -A 1.0. TEST ' / C ............................................................ DATA LCALL0 / .TRUE. /, HALF / 0.5D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C DO 20 IZ = 1,NZ WFR = HC0 * WFZ(IZ) WFRR = HC1 * WFZZ(IZ) C C Z-DEPENDENT FACTOR. RHO2I4 = 4 * RHOP(IZ,3) C C ADD CONTRIBUTIONS TO OPERATOR AVERAGES, C STORE WITH ORDERED Z INTERVALS. QX = WPSZ(IZ) * EXP(2 * CF(IZ)) * WF(IZ) QXX = QX * WF(IZ) C C R(K)**P-TYPE OPERATORS; IDENTITY SEPARATE. C -------------------------------------------------------------- C IF (LTESTQ) THEN C TEST MODE. QI(1) = QI(1) + WPSZ(IZ) * WAL(1) QI(NOPR+NOPD+8) = QI(NOPR+NOPD+8) + WPSZ(IZ) * WALH GO TO 20 ELSE C IDENTITY INTEGRAL. QI(1) = QI(1) + QXX * WAL(1) ENDIF DO 10 IOP = 2,NOPR QI(IOP) = QI(IOP) + QXX * WAL(IOP) * RPZ(IOP-1,IZ) 10 CONTINUE C C H-TYPE OPERATORS (RHS W.F. MODIFIED). C SOME OVERALL FACTORS MAY BE POSTPONED. C -------------------------------------------------------------- C QHX = QX * WALH QHXX = QXX * WALH C C V. QI(NOPR+NOPD+1) = QI(NOPR+NOPD+1) 1 + QHXX * VF(IZ) C C -1/2 D**2/D(RHO)**2. QI(NOPR+NOPD+2) = QI(NOPR+NOPD+2) 1 - (QHX * HALF) * WFRR C C -1/(2 RHO) D/D(RHO). QI(NOPR+NOPD+3) = QI(NOPR+NOPD+3) 1 - (QHX * HALF) * RHOP(IZ,2) * WFR C C 1/(2 RHO**2) (4 - DELTA(*)). QI(NOPR+NOPD+4) = QI(NOPR+NOPD+4) 1 + (QHX * HALF) * RHOP(IZ,3) * WFD(IZ) C C -1/2 DELTA(F) + (2/RHO) D(F)/D(RHO). QI(NOPR+NOPD+5) = QI(NOPR+NOPD+5) - 1 (QHXX * HALF) * 2 (CFRR(IZ) + CFR(IZ) * RHOP(IZ,2) + 3 RHO2I4 * 4 (CFAA(IZ) + AUXA1 * CFA(IZ) + CFLL(IZ))) C C -1/2 GRAD(F)**2. QI(NOPR+NOPD+6) = QI(NOPR+NOPD+6) - 1 (QHXX * HALF) * 2 (CFR(IZ) ** 2 + 3 RHO2I4 * 4 (CFA(IZ) ** 2 + 5 (ARG1A * CFL(IZ)) ** 2)) C C - (GRAD(F), GRAD). QI(NOPR+NOPD+7) = QI(NOPR+NOPD+7) - 1 QHX * 2 (CFR(IZ) * WFR + 3 RHO2I4 * (CFA(IZ) * WFA(IZ) + 4 CFL(IZ) * WFL(IZ) )) C C IDENTITY (FOR NORMALIZATION - DIFFERENT WEIGHTS). QI(NOPR+NOPD+8) = QI(NOPR+NOPD+8) + QHXX 20 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END abasi1.f000644 000311 000121 00000003400 06067230011 012167 0ustar00krivecf1000000 000000 SUBROUTINE ABASI1(ND, X, N, MXPLOG, MLMIN, B, S, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION X(ND), S(ND,ND) C C C COMPUTES N BASIS FUNCTIONS OF X AT N POINTS X(J), J = 1,N; C THEY ARE STORED IN S(I,J) = F(I;X(J)); THE BASIS FUNCTIONS ARE: C F(I;X) = X**I (I = 0,MLMIN-1); C X**I * LN(B*X), X**I (I = MLMIN, MXPLOG); C X**I (I = MXPLOG+1...) C (THE FIRST N OF THESE FUNCTIONS ARE COMPUTED.) C C CHARACTER*6 NAME DATA NAME / 'ABASI1' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/07/26. O: ABASIS (M. HAFTEL) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) C C FIX X DO 1 J = 1,N C C INITIALIZE NUMBER OF FUNCTIONS COMPUTED I = 0 C C FIX POWER OF X DO 2 M1 = 1,N M = M1-1 C C COMPUTE NUMBER OF FUNCTIONS WHICH INCLUDE PRESENT POWER OF X KPMAX = 1 IF (M .GE. MLMIN .AND. M .LE. MXPLOG) KPMAX = 2 C C LOOP OVER THESE FUNCTIONS DO 3 KP = 1,KPMAX C C COMPUTE POWER OF LN(B*X) K = KPMAX - KP C C INCREMENT FUNCTION NUMBER I = I + 1 C C COMPUTE F(I;X) S(I,J) = X(J) ** M IF (K .EQ. 1) S(I,J) = S(I,J) * LOG(B * X(J)) C C QUIT WHEN N FUNCTIONS HAVE BEEN COMPUTED IF (I .EQ. N) GO TO 1 3 CONTINUE 2 CONTINUE 1 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END ainte1.f000644 000311 000121 00000003576 06067230020 012226 0ustar00krivecf1000000 000000 SUBROUTINE AINTE1(ND, X1, X2, N, MXPLOG, MLMIN, B, AINT, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION AINT(ND) C C C COMPUTES INT(X1,X2)(DX*F(I;X)) AND STORES IN AINT(I). C THE F(I;X) ARE GIVEN BY SUBROUTINE ABASI1. C C CHARACTER*6 NAME DATA NAME / 'AINTE1' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/07/26. O: AINTEG (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE / 0.D0, 1.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) C C INITIALIZE NUMBER OF FUNCTIONS J = 0 C C COMPUTE LN(X) AT LIMITS OF INTEGRATION DL2 = LOG(B * X2) C C IF LOWER LIMIT IS ZERO, CONTRIBUTION HERE WILL BE ZERO, SO IT DOES C NOT HURT TO SET LN(B*X1) = 1 DL1 = ONE IF (X1 .GT. ZERO) DL1 = LOG(B * X1) C C FIX POWER OF X DO 1 M1 = 1,N M = M1 - 1 C C COMPUTE NUMBER OF FUNCTIONS WITH THIS POWER OF X KPMAX = 1 IF (M .GE. MLMIN .AND. M .LE. MXPLOG) KPMAX = 2 C C LOOP OVER FUNCTIONS FOR PRESENT POWER OF X DO 2 KP = 1,KPMAX C C COMPUTE POWER OF LN(B*X) K = KPMAX - KP C C COMPUTE FUNCTION NUMBER J = J + 1 C C COMPUTE INTEGRAL - C FOR X**M IF (K .EQ. 0) AINT(J) = (X2 ** M1 - X1 ** M1) / M1 C C FOR X**M*LN(B*X) IF (K .EQ. 1) 1 AINT(J) = (X2 ** M1 * (DL2 - ONE / M1) 2 - X1 ** M1 * (DL1 - ONE / M1)) / M1 C C QUIT IF N INTEGRALS HAVE BEEN COMPUTED IF (J .EQ. N) RETURN 2 CONTINUE 1 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END av2cfd.f000644 000311 000121 00000005022 06067230034 012203 0ustar00krivecf1000000 000000 SUBROUTINE AV2CFD(NDRHO, NOUT, LP, 1 FANA, R, RA, RAA, RL, RLL, SA, 2 MODF, NRHO, RHO, 3 CF, CFR, CFRR, CFA, CFAA, CFL, CFLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION FANA(3,3), 1 R(3), RA(3), RAA(3), RL(3), RLL(3), RHO(NDRHO), 2 CF(NDRHO), CFR(NDRHO), CFRR(NDRHO), 3 CFA(NDRHO), CFAA(NDRHO), CFL(NDRHO), CFLL(NDRHO) LOGICAL LP C C C CORRELATION FUNCTION F AND ITS FIRST AND SECOND DERIVATIVES C (NOTATION SEE CF---B ). BOTH LAMBDA DERIVATIVES ARE MULTIPLIED C BY 1/SIN(A)**2. C OUTPUT FOR A FIXED (A, LAMBDA) POINT, AND FOR A SET OF RHO VALUES. C CONTENTS OF FANA ARE NOT TESTED. C SA: SIN(A). C C CHARACTER*6 NAME DATA NAME / 'AV2CFD' / CHARACTER*60 VERS DATA VERS */ ' 2.2, 92/11/26 (FANA; MODF = 4, 5) (1.1) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE / 1.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MODF .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (MODF .GT. 5) CALL ERR2(NAME, 2, 1, NOUT) IF (MODF .EQ. 3) CALL ERR2(NAME, 3, 1, NOUT) C IF (MODF .EQ. 0 .OR. MODF .EQ. 2) THEN C C LINEAR F. CALL CF000C(NDRHO, NOUT, 1 FANA(1,1), R, RA, RAA, RL, RLL, 2 NRHO, RHO, CF, CFR, CFRR, CFA, CFAA, CFL, CFLL) ELSE IF (MODF .EQ. 1 .OR. MODF .EQ. 4 .OR. MODF .EQ. 5) THEN C C NONLINEAR (POWER SERIES) F, THREE ANALYTIC COEFFICIENTS. CALL CF001C(NDRHO, NOUT, 1 FANA(1,1), FANA(1,2), FANA(1,3), 2 R, RA, RAA, RL, RLL, 3 NRHO, RHO, CF, CFR, CFRR, CFA, CFAA, CFL, CFLL) ENDIF C C MULTIPLY BY 1/SIN(A)**2. DO 10 I = 1,NRHO CFL(I) = CFL(I) * ((ONE / SA) ** 2) CFLL(I) = CFLL(I) * ((ONE / SA) ** 2) 10 CONTINUE C IF (LP) THEN WRITE (NOUT,2100) NAME WRITE (NOUT,2102) 1 (I, CF(I), CFR(I), CFRR(I), CFA(I), CFAA(I), CFL(I), CFLL(I), 2 I = 1,NRHO) WRITE (NOUT,2104) FANA ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 40HCF, CFR, CFRR, CFA, CFAA, CFL, CFLL: ) 2102 FORMAT ( A 1H , I2, 7E11.4) 2104 FORMAT (1H , 4HFANA, 3E12.4, /, (1H , 4X, 3E12.4)) END av2qwa.f000644 000311 000121 00000004710 06067230041 012240 0ustar00krivecf1000000 000000 SUBROUTINE AV2QWA(NDOPR, NDPAS, NDPLS, NOUT, 1 NOPR, LRGAUS, LHGAUS, 2 IRA, IRL, IAS, ILS, 3 WA, WAMS, WL, WLMS, PSA, WAL, WALH) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LRGAUS, LHGAUS DIMENSION WLMS(NDPLS,NDPAS,2), WAL(NDOPR) C C C WEIGHTS AND PHASE SPACE FACTORS FOR ALL OPERATORS. C POINTER TABLES ARE USED ON (OPERATOR, A-REGION, LAMBDA-REGION) C TRIPLES. SOME REPETITION (AS VIEWED FORM THE CALLING PROGRAM) C BECAUSE OF NO Z-DEPENDENCE. POINTER TABLES ARE IGNORED IF GAUSS C QUADRATURE IS REQUIRED IN SINGULAR REGIONS. C C CHARACTER*6 NAME DATA NAME / 'AV2QWA' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 91/08/02. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NOPR .GT. NDOPR) CALL ERR2(NAME, 1, 1, NOUT) C (OTHER DIMENSIONS NOT TESTED.) C C R(K)**P-TYPE OPERATORS. IOPRA = 0 IOPRL = 0 DO 20 IOP = 1,NOPR IF (.NOT. LRGAUS) THEN IOPRA = IOTAA(IOP, IRA, IRL, NOUT) IOPRL = IOTLA(IOP, IRA, IRL, NOUT) ENDIF IF (IOPRA .EQ. 0) THEN IF (IOPRL .EQ. 0) THEN WAL(IOP) = WA * PSA * WL ELSE WAL(IOP) = WA * PSA * WLMS(ILS,IAS,IOPRL) ENDIF ELSE IF (IOPRL .EQ. 0) THEN WAL(IOP) = WAMS * PSA * WL ELSE WAL(IOP) = WAMS * PSA * WLMS(ILS,IAS,IOPRL) ENDIF ENDIF 20 CONTINUE C C H-TYPE OPERATORS: ALL USE THE SAME WEIGHTS, TO PRESERVE THE C VARIATIONAL PROPERTY OF H. IOPHA = 0 IOPHL = 0 IF (.NOT. LHGAUS) THEN IOPHA = IOHTAA(IRA, NOUT) IOPHL = IOHTLA(IRA, IRL, NOUT) ENDIF IF (IOPHA .EQ. 0) THEN IF (IOPHL .EQ. 0) THEN WALH = WA * PSA * WL ELSE WALH = WA * PSA * WLMS(ILS,IAS,IOPHL) ENDIF ELSE IF (IOPHL .EQ. 0) THEN WALH = WAMS * PSA * WL ELSE WALH = WAMS * PSA * WLMS(ILS,IAS,IOPHL) ENDIF ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END av2va.f000644 000311 000121 00000003665 06067230051 012067 0ustar00krivecf1000000 000000 SUBROUTINE AV2VA(NDVPAR, NDRHO, NOUT, LP, 1 MODV, IPVL, IPVU, VPAR, 2 R, RI, NRHO, RHO, RHOI, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION VPAR(3,NDVPAR), R(3), RI(3), 1 RHO(NDRHO), RHOI(NDRHO), V(NDRHO) LOGICAL LP C C C POTENTIAL V FOR A FIXED (A, LAMBDA) POINT, AND FOR A SET C OF RHO VALUES. C CONTENTS OF VPAR ARE NOT TESTED. C COULOMB POTENTIAL IS TREATED SEPARATELY (FOR SPEED) UNDER C MODV = 0. NOTE THAT THE CRITERION TO SIGNIFY COULOMB POTENTIAL C INTERPRETATION OF VPAR IS: IPVL = IPVU = -1. (IN THE ENERGY C PROGRAM, ROUTINE VC000 TREATS ANY SERIES FOR V, INCLUDING THE C COULOMB TERMS.) FOR THIS OPTION, INVERSE RADII AND RHO ARE C ALSO INPUT. C C CHARACTER*6 NAME DATA NAME / 'AV2VA ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/29. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MODV .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (MODV .GT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (NDVPAR .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (IPVL .NE. -1) CALL ERR2(NAME, 4, 1, NOUT) IF (IPVU .NE. -1) CALL ERR2(NAME, 5, 1, NOUT) C C CALCULATE V. IF (MODV .EQ. 0) THEN IF (IPVL .EQ. -1 .AND. IPVU .EQ. -1) THEN C C ASSUME: COULOMB POTENTIAL. CALL V000(NDRHO, NOUT, VPAR(1,1), RI, NRHO, RHOI, V) ENDIF ENDIF C IF (LP) THEN WRITE (NOUT,2100) NAME WRITE (NOUT,2102) (I, V(I), I = 1,NRHO) ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 4HV: ) 2102 FORMAT ( A 1H , I4, E12.4) END av2w0a.f000644 000311 000121 00000013704 06067230061 012144 0ustar00krivecf1000000 000000 SUBROUTINE AV2W0A(NDS, NDKX, NDMA, NOUT, 1 MM, ISMN, YA, YAA, YL, YLL, KX, MA, DD, 2 WKY, DDY) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ISMN(2,NDS), YA(NDS), YAA(NDS), YL(NDS), YLL(NDS), 1 DD(NDS,NDKX,NDMA), WKY(NDS,4), DDY(NDKX,NDMA,6) C C C SERIES COEFFICIENTS OF THE HH PART OF THE WAVE FUNCTION C AND ITS DERIVATIVES (SUM OVER HH FOR FIXED POWERS OF Z, LOG(Z)), C ON THE FIRST INTERVAL. C OUTPUT: C DDY(K+1,M,1) - WAVE FUNCTION; C DDY(K+1,M,2) - (4 - DELTA(*)) * WAVE FUNCTION; C DDY(K+1,M,3) - A DERIVATIVE; C DDY(K+1,M,4) - LAMBDA DERIVATIVE; C DDY(K+1,M,5) - Z (NOT RHO) DERIVATIVE; C DDY(K+1,M,6) - SECOND Z DERIVATIVE. C ALL THE COMPONENTS OF DDY BELONG TO THE SAME TERM, C Z**K LOG(Z)**(M - 1) / (M - 1)!, C WHERE K = 0,..., KX, M = 1,..., MA. KX IS ALWAYS AT LEAST 2. C TO FURTHER SIMPLIFY SUMMATION OF SERIES, THE ELEMENTS OF DDY C OTHERWISE UNDEFINED ARE EXPLICITLY PUT TO ZERO, SO THAT IN C SUMMATIONS, THE BOUNDS NEED NOT BE CHECKED. C NOTE THAT THE DD, DDY FIRST INDEX IS RAISED BY 1 WITH RESPECT TO C THE USAGE IN HYPWF. THIS IS NECESSARY TO ACCOMODATE THE LOWERING C OF POWERS IN THE Z DERIVATIVES; WAVE FUNCTION SERIES STARTS C WITH Z**2, BUT THE SECOND DERIVATIVE STARTS WITH Z**0. C C CHARACTER*6 NAME DATA NAME / 'AV2W0A' / CHARACTER*60 VERS DATA VERS */ ' 1.1C, 94/10/07; 1.1, 91/08/01. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MM .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (MM .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (KX .LT. 2) CALL ERR2(NAME, 3, 1, NOUT) IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 4, 1, NOUT) IF (MA .LT. 1) CALL ERR2(NAME, 5, 1, NOUT) IF (MA .GT. NDMA) CALL ERR2(NAME, 6, 1, NOUT) C C ANGULAR FUNCTIONS (HH AND THEIR DERIVATIVES). DO 10 I = 1,MM WKY(I,1) = (YA(I) * YL(I)) WKY(I,2) = (YA(I) * YL(I)) * (2 * ISMN(1,I) + 2) ** 2 WKY(I,3) = YAA(I) * YL(I) WKY(I,4) = YA(I) * YLL(I) 10 CONTINUE C C COEFFICIENTS OF THE WAVE FUNCTION AND ITS ANGULAR DERIVATIVES. KX1 = KX + 1 DO 30 M = 1,MA DO 28 K1 = 3,KX1 K = K1 - 1 C C WAVE FUNCTION. DDY(K1,M,1) = ZERO DO 20 I = 1,MM DDY(K1,M,1) = DDY(K1,M,1) + DD(I,K1,M) * WKY(I,1) 20 CONTINUE C C (4 - DELTA(*)) TIMES WAVE FUNCTION (PART OF K. E.). DDY(K1,M,2) = ZERO DO 22 I = 1,MM DDY(K1,M,2) = DDY(K1,M,2) + DD(I,K1,M) * WKY(I,2) 22 CONTINUE C C A DERIVATIVE OF WAVE FUNCTION. DDY(K1,M,3) = ZERO DO 24 I = 1,MM DDY(K1,M,3) = DDY(K1,M,3) + DD(I,K1,M) * WKY(I,3) 24 CONTINUE C C LAMBDA DERIVATIVE OF WAVE FUNCTION. DDY(K1,M,4) = ZERO DO 26 I = 1,MM DDY(K1,M,4) = DDY(K1,M,4) + DD(I,K1,M) * WKY(I,4) 26 CONTINUE 28 CONTINUE DDY(1,M,1) = ZERO DDY(2,M,1) = ZERO DDY(1,M,2) = ZERO DDY(2,M,2) = ZERO DDY(1,M,3) = ZERO DDY(2,M,3) = ZERO DDY(1,M,4) = ZERO DDY(2,M,4) = ZERO 30 CONTINUE C C COEFFICIENTS OF THE Z DERIVATIVES OF WAVE FUNCTION. C C Z DERIVATIVE. KX2 = KX C C FIRST PART. DO 44 M = 1,MA DO 42 K1 = 2,KX2 K = K1 - 1 DDY(K1,M,5) = ZERO DO 40 I = 1,MM DDY(K1,M,5) = DDY(K1,M,5) + DD(I,K1+1,M) * (K + 1) * 1 WKY(I,1) 40 CONTINUE 42 CONTINUE DDY(1,M,5) = ZERO DDY(KX2+1,M,5) = ZERO 44 CONTINUE IF (MA .GE. 2) THEN C C SECOND PART. MA1 = MA - 1 DO 54 M = 1,MA1 DO 52 K1 = 2,KX2 K = K1 - 1 DO 50 I = 1,MM DDY(K1,M,5) = DDY(K1,M,5) + DD(I,K1+1,M+1) * 1 WKY(I,1) 50 CONTINUE 52 CONTINUE 54 CONTINUE ENDIF C C SECOND Z DERIVATIVE. KX3 = KX - 1 C C FIRST PART. DO 64 M = 1,MA DO 62 K1 = 1,KX3 K = K1 - 1 DDY(K1,M,6) = ZERO DO 60 I = 1,MM DDY(K1,M,6) = DDY(K1,M,6) + DD(I,K1+2,M) * 1 ((K + 2) * (K + 1)) * 2 WKY(I,1) 60 CONTINUE 62 CONTINUE DDY(KX3+1,M,6) = ZERO DDY(KX3+2,M,6) = ZERO 64 CONTINUE IF (MA .GE. 2) THEN C C SECOND PART. MA1 = MA - 1 DO 74 M = 1,MA1 DO 72 K1 = 1,KX3 K = K1 - 1 DO 70 I = 1,MM DDY(K1,M,6) = DDY(K1,M,6) + DD(I,K1+2,M+1) * 1 (2 * K + 3) * 2 WKY(I,1) 70 CONTINUE 72 CONTINUE 74 CONTINUE ENDIF IF (MA .GE. 3) THEN C C THIRD PART. MA2 = MA - 2 DO 84 M = 1,MA2 DO 82 K1 = 1,KX3 K = K1 - 1 DO 80 I = 1,MM DDY(K1,M,6) = DDY(K1,M,6) + DD(I,K1+2,M+2) * 1 WKY(I,1) 80 CONTINUE 82 CONTINUE 84 CONTINUE ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END av2w1a.f000644 000311 000121 00000007610 06067230070 012144 0ustar00krivecf1000000 000000 SUBROUTINE AV2W1A(NDS, NDP, NOUT, 1 MM, ISMN, YA, YAA, YL, YLL, JMAX, WFC, 2 WKY, WFCY) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ISMN(2,NDS), YA(NDS), YAA(NDS), YL(NDS), YLL(NDS), 1 WFC(NDS,NDP), WKY(NDS,4), WFCY(NDP,6) C C C POWER SERIES COEFFICIENTS OF THE HH PART OF THE WAVE FUNCTION C AND ITS DERIVATIVES (SUM OVER HH FOR FIXED POWERS OF (Z - Z0)), C ON INTERVALS BEYOND THE FIRST. C OUTPUT: C WFCY(POWER+1,1) - WAVE FUNCTION; C WFCY(POWER+1,2) - (4 - DELTA(*)) * WAVE FUNCTION; C WFCY(POWER+1,3) - A DERIVATIVE; C WFCY(POWER+1,4) - LAMBDA DERIVATIVE; C WFCY(POWER+1,5) - Z (NOT RHO) DERIVATIVE; C WFCY(POWER+1,6) - SECOND Z DERIVATIVE. C THE FIRST INDEX OF WFCY CORRESPONDS TO THE SAME POWER, FOR C ALL WFCY COMPONENTS, WHICH ENABLES SIMPLE SUMMATION. ALSO, C IN Z DERIVATIVES, THE COEFFICIENTS OF THE HIGHEST POWERS ARE C EXPLICITLY PUT TO ZERO, SO THAT WHEN SUMMING THE POWER SERIES, C ONE NEED NOT ASK FOR TRUE BOUNDS ON POWERS BUT SUM UP TO JMAX1 C FOR ALL COMPONENTS OF WFCY. C C CHARACTER*6 NAME DATA NAME / 'AV2W1A' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/08/01. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MM .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (MM .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (JMAX .LT. 0) CALL ERR2(NAME, 3, 1, NOUT) IF (JMAX + 1 .GT. NDP) CALL ERR2(NAME, 4, 1, NOUT) C C ANGULAR FUNCTIONS (HH AND THEIR DERIVATIVES). THIS PART IS C BEING REPEATED FOR EACH Z INTERVAL, AS VIEWED FROM THE CALLING C PROGRAM, BUT MAY AVOID LARGER STORAGE. DO 10 I = 1,MM WKY(I,1) = (YA(I) * YL(I)) WKY(I,2) = (YA(I) * YL(I)) * (2 * ISMN(1,I) + 2) ** 2 WKY(I,3) = YAA(I) * YL(I) WKY(I,4) = YA(I) * YLL(I) 10 CONTINUE C C COEFFICIENTS OF THE WAVE FUNCTION AND ITS ANGULAR DERIVATIVES. JMAX1 = JMAX + 1 DO 60 IP = 1,JMAX1 C C WAVE FUNCTION. WFCY(IP,1) = ZERO DO 20 I = 1,MM WFCY(IP,1) = WFCY(IP,1) + WFC(I,IP) * WKY(I,1) 20 CONTINUE C C (4 - DELTA(*)) TIMES WAVE FUNCTION (PART OF KINETIC ENERGY). WFCY(IP,2) = ZERO DO 30 I = 1,MM WFCY(IP,2) = WFCY(IP,2) + WFC(I,IP) * WKY(I,2) 30 CONTINUE C C A DERIVATIVE OF WAVE FUNCTION. WFCY(IP,3) = ZERO DO 40 I = 1,MM WFCY(IP,3) = WFCY(IP,3) + WFC(I,IP) * WKY(I,3) 40 CONTINUE C C LAMBDA DERIVATIVE OF WAVE FUNCTION. WFCY(IP,4) = ZERO DO 50 I = 1,MM WFCY(IP,4) = WFCY(IP,4) + WFC(I,IP) * WKY(I,4) 50 CONTINUE 60 CONTINUE C C COEFFICIENTS OF THE Z DERIVATIVES OF WAVE FUNCTION. C C Z DERIVATIVE. JMAX2 = JMAX WFCY(JMAX2+1,5) = ZERO IF (JMAX2 .GE. 1) THEN DO 80 IP = 1,JMAX2 WFCY(IP,5) = ZERO DO 70 I = 1,MM WFCY(IP,5) = WFCY(IP,5) + WFC(I,IP+1) * IP * WKY(I,1) 70 CONTINUE 80 CONTINUE ENDIF C C SECOND Z DERIVATIVE. JMAX3 = JMAX - 1 WFCY(JMAX3+1,6) = ZERO WFCY(JMAX3+2,6) = ZERO IF (JMAX3 .GE. 1) THEN DO 100 IP = 1,JMAX3 WFCY(IP,6) = ZERO DO 90 I = 1,MM WFCY(IP,6) = WFCY(IP,6) + WFC(I,IP+2) * IP * (IP + 1) 1 * WKY(I,1) 90 CONTINUE 100 CONTINUE ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END av2yab.f000644 000311 000121 00000014031 06067230072 012224 0ustar00krivecf1000000 000000 SUBROUTINE AV2YAB(NDS, NDA, NDPJ, NOUT, LPJ, 1 NS, ISMN, NA, ARG, ARG1, PJ, YA, YAA) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LPJ DIMENSION ISMN(2,NDS), ARG(NDA), ARG1(NDA), PJ(NDA,NDPJ), 1 YA(NDS,NDA), YAA(NDS,NDA) C C C A-DEPENDENT PARTS OF THE REAL HH AND THEIR A-DERIVATIVES, FOR C ALL STATES, ALL ARGUMENTS. C LOOP IS OVER NONNEGATIVE NU; AT EACH NU ALL JACOBI POLYNOMIALS C FOR MU .GE. NU ARE CALCULATED BY RECURSION. DERIVATIVES ARE C EXPRESSED BY THE POLYNOMIALS THEMSELVES. THE POSITIVE AND C NEGATIVE NU STATES ARE DEALT WITH USING SYMMETRY (YA, YAA DEPEND C ON ABS(NU) ONLY). JACOBI POLYNOMIALS ARE MULTIPLIED BY C (2/(1+DELTA(NU,0)))**1/2 ((MU + 1)/PI**3)**1/2 (SIN A)**NU, C TO GET YA SUCH THAT C R(MU,NU,A,LAMBDA) = COS(LAMBDA NU) YA(MU,NU,A) C R(MU,-NU,A,LAMBDA) = SIN(LAMBDA NU) YA(MU,NU,A). C INPUT: C ISMN - MU, NU PAIRS. NOTE THAT ISMN MAY HAVE BEEN ADJUSTED C BY M2WRDA (COULDR). THEREFORE ONLY ISMN IS RELIED ON, C AND NOT ISIS OR ISN WHICH ARE NOT CHANGED BY M2WRDA. C ARG - ARGUMENTS OF JACOBI POLYNOMIALS (COS(2A)). C ARG1 - VALUES OF SIN(A). ARG, ARG1 ARE NOT TESTED HERE. C C CHARACTER*6 NAME DATA NAME / 'AV2YAB' / CHARACTER*60 VERS DATA VERS */ ' 1.8, 91/12/10. O: M2OFQB. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TWO, HALF / 0.D0, 1.D0, 2.D0, 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (NA .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (NA .GT. NDA) CALL ERR2(NAME, 4, 1, NOUT) C ZZZA = SQRT(TWO / CDXPI() ** 3) C C FIND MAX. MU, ABS(NU) BY DIRECT SEARCH (TO MAKE IT INDEPENDENT C OF THE STATE SEQUENCE). MUU = 0 NUU = 0 DO 10 IY = 1,NS IF (ISMN(1,IY) .GT. MUU) MUU = ISMN(1,IY) IF (ABS(ISMN(2,IY)) .GT. NUU) NUU = ABS(ISMN(2,IY)) 10 CONTINUE C C RESET YA, YAA. DO 22 I = 1,NA DO 20 IY = 1,NS YA(IY,I) = ZERO YAA(IY,I) = ZERO 20 CONTINUE 22 CONTINUE C C LOOP OVER ALL CONTIGUOUS NONNEGATIVE NU. NU1U = NUU + 1 DO 46 NU1 = 1,NU1U NU = NU1 - 1 C C KRONECKER DELTA IN NORMALIZATION FACTOR. IF (NU .EQ. 0) THEN ZZZB = SQRT(HALF) * ZZZA ELSE ZZZB = ZZZA ENDIF C C LARGEST POLYNOMIAL ORDER (MU - NU) / 2 FOR GIVEN NU (VALID FOR C ODD AND EVEN MU, NU). NJ = (MUU - NU) / 2 CALL M1PJXA(NDA, NDPJ, NJ, NU, NA, ARG, NOUT, LPJ, PJ) C C LOOP OVER POLYNOMIAL ORDERS. NJ1 = NJ + 1 DO 44 J = 1,NJ1 C C ORDER. N = J - 1 C C MU (OF THE SAME PARITY AS NU); NORMALIZATION FACTOR. MU = 2 * N + NU ZZZC = SQRT(DBLE(MU + 1)) * ZZZB IYX = 0 C C SEARCH FOR THE FIRST (MU,+-NU) STATE. C ---------------------------------------------------------- C C SEARCH IS DONE THIS WAY TO BE ABLE TO HANDLE ANY C INPUT STATE SEQUENCE. DO 30 IY = 1,NS IF (ISMN(1,IY) .EQ. MU .AND. 1 ABS(ISMN(2,IY)) .EQ. NU ) GO TO 32 30 CONTINUE C C SEARCH NOT SUCCESSFUL; NO MORE SUCH STATES. CALL ERR2(NAME, (1000000+1000*MU+NU), 0, NOUT) GO TO 44 32 CONTINUE C C SEARCH SUCCESSFUL; STORE STATE NUMBER. IYX = IY C C CALCULATE YA. DO 34 I = 1,NA YA(IY,I) = PJ(I,J) * ZZZC * ARG1(I) ** NU 34 CONTINUE C C CALCULATE YAA (DERIVATIVES). X2: SEE Y1. X1 = ZERO IF (N .GT. 0) X1 = DBLE(N) / DBLE(2 * N + NU) X2 = (2 * N + NU) X3 = 2 * (N + NU) DO 36 I = 1,NA C C DERIVATIVE OF JACOBI POLYNOMIAL, TIMES (1 - ARG**2). PJD = ZERO IF (N .GT. 0) PJD = ((NU - X2 * ARG(I)) * PJ(I,J) 1 + X3 * PJ(I,J-1) ) 2 * X1 C C DERIVATIVE OF YA. YAA(IY,I) = ZERO IF ((ONE - ARG1(I) ** 2) .GT. ZERO) 1 YAA(IY,I) = ZZZC * ARG1(I) ** NU / ARG1(I) 2 * SQRT(ONE - ARG1(I) ** 2) 3 * (NU * PJ(I,J) 4 - PJD / (ONE - ARG1(I) ** 2)) 36 CONTINUE C C FINISH IF NU = 0. IF (NU .EQ. 0) GO TO 44 C C SEARCH FOR THE (MU,+-NU) STATE WITH THE OTHER NU SIGN. C ---------------------------------------------------------- C DO 38 IY = 1,NS IF (ISMN(1,IY) .EQ. MU .AND. 1 ISMN(2,IY) .EQ. -ISMN(2,IYX) ) GO TO 40 38 CONTINUE IF (LPJ) CALL ERR2(NAME, (2000000+1000*MU+NU), 0, NOUT) GO TO 44 40 CONTINUE C C SEARCH SUCCESSFUL; COPY YA, YAA. DO 42 I = 1,NA YA(IY,I) = YA(IYX,I) YAA(IY,I) = YAA(IYX,I) 42 CONTINUE 44 CONTINUE 46 CONTINUE IF (.NOT. LPJ) RETURN C C TEST OUTPUT. WRITE (NOUT,2100) NAME DO 50 I = 1,NA WRITE (NOUT,2102) 1 I, ARG(I), ARG1(I), 2 (IY, ISMN(1,IY), ISMN(2,IY), YA(IY,I), YAA(IY,I), IY = 1,NS) 50 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT (/, A 2H -, A6, 1H-, 8HYA, YAA ) 2102 FORMAT ( A 1H , I4, 2F12.6, /, B (1H , I4, 4X, 2I4, 2F12.6)) END av2ylb.f000644 000311 000121 00000007143 06067230074 012247 0ustar00krivecf1000000 000000 SUBROUTINE AV2YLB(NDS, NDL, NDMU, NOUT, LP, 1 NS, ISMN, NLX, ARG, WK1, WK2, YL, YLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ISMN(2,NDS), NLX(2), ARG(NDL,2), 1 WK1(NDL,NDMU,2), WK2(NDL,NDMU,2), 2 YL(NDS,NDL,2), YLL(NDS,NDL,2) LOGICAL LP C C C LAMBDA-DEPENDENT PARTS OF THE REAL HH, AND THEIR DERIVATIVES, FOR C ALL STATES, ALL ARGUMENTS. FOR NONNEGATIVE NU, C YL(MU,NU,LAMBDA) = COS(LAMBDA NU), C YL(MU,-NU,A,LAMBDA) = SIN(LAMBDA NU).. C INPUT: C ISMN - MU, NU PAIRS. NOTE THAT ISMN MAY HAVE BEEN ADJUSTED C BY M2WRDA (COULDR). THEREFORE ONLY ISMN IS RELIED ON, C AND NOT ISIS OR ISN WHICH ARE NOT CHANGED BY M2WRDA. C ARG - VALUES OF LAMBDA, FOR THE TWO A REGIONS. C C CHARACTER*6 NAME DATA NAME / 'AV2YLB' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/08/28. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (NLX(1) .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (NLX(1) .GT. NDL) CALL ERR2(NAME, 4, 1, NOUT) IF (NLX(2) .LT. 1) CALL ERR2(NAME, 5, 1, NOUT) IF (NLX(2) .GT. NDL) CALL ERR2(NAME, 6, 1, NOUT) C C FIND MAX. MU, NU BY DIRECT SEARCH (TO MAKE IT INDEPENDENT OF THE C STATE SEQUENCE). NUU = 0 DO 10 I = 1,NS IF (ABS(ISMN(2,I)) .GT. NUU) NUU = ISMN(2,I) 10 CONTINUE IF (NUU + 1 .GT. NDMU) CALL ERR2(NAME, 5, 1, NOUT) C C RESET YL, YLL. DO 24 J = 1,2 NL = NLX(J) DO 22 I = 1,NL DO 20 IY = 1,NS YL(IY,I,J) = ZERO YLL(IY,I,J) = ZERO 20 CONTINUE 22 CONTINUE 24 CONTINUE C C LOOP OVER ALL CONTIGUOUS NONNEGATIVE NU. NU1U = NUU + 1 DO 34 J = 1,2 NL = NLX(J) DO 32 NU1 = 1,NU1U DO 30 I = 1,NL WK1(I,NU1,J) = COS((NU1 - 1) * ARG(I,J)) WK2(I,NU1,J) = SIN((NU1 - 1) * ARG(I,J)) 30 CONTINUE 32 CONTINUE 34 CONTINUE C C LOOP OVER STATES. DO 48 IY = 1,NS NU = ISMN(2,IY) IF (NU .GE. 0) THEN DO 42 J = 1,2 NL = NLX(J) DO 40 I = 1,NL YL(IY,I,J) = WK1(I,NU+1,J) YLL(IY,I,J) = - NU * WK2(I,NU+1,J) 40 CONTINUE 42 CONTINUE ELSE DO 46 J = 1,2 NL = NLX(J) DO 44 I = 1,NL YL(IY,I,J) = WK2(I,-NU+1,J) YLL(IY,I,J) = (-NU) * WK1(I,-NU+1,J) 44 CONTINUE 46 CONTINUE ENDIF 48 CONTINUE IF (.NOT. LP) RETURN C C TEST OUTPUT. WRITE (NOUT,2100) NAME DO 52 J = 1,2 NL = NLX(J) DO 50 I = 1,NL WRITE (NOUT,2102) 1 I, J, ARG(I,J), 2 (IY, ISMN(1,IY), ISMN(2,IY), YL(IY,I,J), YLL(IY,I,J), 3 IY = 1,NS) 50 CONTINUE 52 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT (/, A 2H -, A6, 1H-, 8HYL, YLL ) 2102 FORMAT ( A 1H , 2I4, F12.6, /, B (1H , I4, 4X, 2I4, 2F12.6)) END av2ylc.f000644 000311 000121 00000005760 06067230076 012255 0ustar00krivecf1000000 000000 SUBROUTINE AV2YLC(NDS, NDL, NDMU, NOUT, LP, 1 NS, ISMN, NL, ARG, WK1, WK2, YL, YLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ISMN(2,NDS), ARG(NDL), 1 WK1(NDL,NDMU), WK2(NDL,NDMU), 2 YL(NDS,NDL), YLL(NDS,NDL) LOGICAL LP C C C LAMBDA-DEPENDENT PARTS OF THE REAL HH, AND THEIR DERIVATIVES, FOR C ALL STATES, ALL ARGUMENTS. FOR NONNEGATIVE NU, C YL(MU,NU,LAMBDA) = COS(LAMBDA NU), C YL(MU,-NU,A,LAMBDA) = SIN(LAMBDA NU).. C INPUT: C ISMN - MU, NU PAIRS. NOTE THAT ISMN MAY HAVE BEEN ADJUSTED C BY M2WRDA (COULDR). THEREFORE ONLY ISMN IS RELIED ON, C AND NOT ISIS OR ISN WHICH ARE NOT CHANGED BY M2WRDA. C ARG - VALUES OF LAMBDA, FOR THE TWO A REGIONS. C C CHARACTER*6 NAME DATA NAME / 'AV2YLC' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 93/01/25 (AV2YLB 1.1-REMOVED J-LOOPS) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (NL .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (NL .GT. NDL) CALL ERR2(NAME, 4, 1, NOUT) C C FIND MAX. MU, NU BY DIRECT SEARCH (TO MAKE IT INDEPENDENT OF THE C STATE SEQUENCE). NUU = 0 DO 10 I = 1,NS IF (ABS(ISMN(2,I)) .GT. NUU) NUU = ISMN(2,I) 10 CONTINUE IF (NUU + 1 .GT. NDMU) CALL ERR2(NAME, 5, 1, NOUT) C C RESET YL, YLL. DO 22 I = 1,NL DO 20 IY = 1,NS YL(IY,I) = ZERO YLL(IY,I) = ZERO 20 CONTINUE 22 CONTINUE C C LOOP OVER ALL CONTIGUOUS NONNEGATIVE NU. NU1U = NUU + 1 DO 32 NU1 = 1,NU1U DO 30 I = 1,NL WK1(I,NU1) = COS((NU1 - 1) * ARG(I)) WK2(I,NU1) = SIN((NU1 - 1) * ARG(I)) 30 CONTINUE 32 CONTINUE C C LOOP OVER STATES. DO 48 IY = 1,NS NU = ISMN(2,IY) IF (NU .GE. 0) THEN DO 40 I = 1,NL YL(IY,I) = WK1(I,NU+1) YLL(IY,I) = - NU * WK2(I,NU+1) 40 CONTINUE ELSE DO 44 I = 1,NL YL(IY,I) = WK2(I,-NU+1) YLL(IY,I) = (-NU) * WK1(I,-NU+1) 44 CONTINUE ENDIF 48 CONTINUE IF (.NOT. LP) RETURN C C TEST OUTPUT. WRITE (NOUT,2100) NAME DO 50 I = 1,NL WRITE (NOUT,2102) 1 I, ARG(I), 2 (IY, ISMN(1,IY), ISMN(2,IY), YL(IY,I), YLL(IY,I), IY = 1,NS) 50 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT (/, A 2H -, A6, 1H-, 8HYL, YLL ) 2102 FORMAT ( A 1H , I4, F12.6, /, B (1H , I4, 4X, 2I4, 2F12.6)) END av3ala.f000644 000311 000121 00000003303 06067230107 012206 0ustar00krivecf1000000 000000 SUBROUTINE AV3ALA(NOUT, LP, 1 XKAPPA, XOMEGA, 2 ARGA, ARG1A, PSA, ARGL, AUXA, R) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XKAPPA(3), XOMEGA(3), ARGL(3,2), R(3,3) LOGICAL LP C C C RHO-INDEPENDENT FUNCTIONS OF (A, LAMBDA), INCLUDING THE VALUES OF C RADII DIVIDED BY RHO, AT THE TWO-PARTICLE COALESCENCE POINTS. C C OUTPUT: C R - INTERPARTICLE RADIUS / RHO. C C CHARACTER*6 NAME DATA NAME / 'AV3ALA' / CHARACTER*60 VERS DATA VERS */ ' 2.0, 91/12/10. O: AV2ALB 1.2, 91/08/02. ' / C ------------------------------------------------------------ C DIMENSION AUXL(3,3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE / 0.D0, 1.D0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C FUNCTIONS OF A, AT A = PI/2. PSA = ZERO ARGA = - ONE ARG1A = ONE AUXA = ZERO C C FUNCTIONS OF LAMBDA. DO 12 J = 1,3 ARGL(J,1) = ZERO ARGL(J,2) = CDXPI() - XOMEGA(J) DO 10 I = 1,3 AUXL(I,J) = COS(ARGL(J,2) + XOMEGA(I)) 10 CONTINUE 12 CONTINUE C C FUNCTIONS OF (A, LAMBDA). C INTERPARTICLE RADII R(I), DIVIDED BY HYPERRADIUS. DO 22 J = 1,3 DO 20 I = 1,3 R(I,J) = SQRT(XKAPPA(I) * 1 (ONE + ARG1A * AUXL(I,J))) IF (LP) WRITE (NOUT,2122) I, J, R(I,J) 20 CONTINUE 22 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2122 FORMAT ( A 1H , 3H R, I1, I4, F12.6) END avmma.f000644 000311 000121 00000003106 06067230114 012137 0ustar00krivecf1000000 000000 SUBROUTINE AVMMA(XMASS1, XMASS2, XMASS3, XKAPPA, XMM, XMC, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XKAPPA(3), XMC(3) C C SOME MASS FACTORS FOR CFHHM WAVE FUNCTION NORMALIZATION. C XMM - PRODUCT OF PAIR REDUCED MASS TIMES THIRD-PARTICLE-AND- C PAIR REDUCED MASS. INVARIANT TO PAIR NUMBER. C XMC - THIRD-PARTICLE-AND-PAIR REDUCED MASSES. C IT IS ASSUMED THE KAPPAS ARE CALCULATED IN A STABLE WAY (EVEN C IF ONE MASS IS INFINITE). C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVMMA ' / CHARACTER*60 VERS DATA VERS */ '1.0, 92/04/03. ' / C ............................................................ DATA LCALL0 / .TRUE. /, ZERO, TWO / 0.D+0, 2.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (XMASS1 .LE. ZERO) CALL ERR2(NAME, 1, 1, NOUT) IF (XMASS2 .LE. ZERO) CALL ERR2(NAME, 2, 1, NOUT) IF (XMASS3 .LE. ZERO) CALL ERR2(NAME, 3, 1, NOUT) C C THE FOLLOWING CAN HANDLE ONLY ONE INFINITE MASS. IF (XMASS1 .GE. CDXMAX()) THEN XMM = XMASS2 * XMASS3 ELSE IF (XMASS2 .GE. CDXMAX()) THEN XMM = XMASS3 * XMASS1 ELSE IF (XMASS3 .GE. CDXMAX()) THEN XMM = XMASS1 * XMASS2 ELSE XMM = XMASS1 * XMASS2 * XMASS3 / (XMASS1 + XMASS2 + XMASS3) ENDIF DO 10 I = 1,3 XMC(I) = TWO * XKAPPA(I) * XMM 10 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END avwf0a.f000644 000311 000121 00000002456 06067230116 012233 0ustar00krivecf1000000 000000 SUBROUTINE AVWF0A(NDZ, NDMA, NDKX, NZ, MA, KX, DDY, ZDPL, 1 NOUT, WF) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION DDY(NDKX,NDMA), ZDPL(NDZ,NDKX,NDMA), WF(NDZ) C C HH-EXPANDED PART OF THE WAVE FUNCTION OR ONE OF ITS DERIVATIVES, C ON THE FIRST INTERVAL (CONTAINING THE ORIGIN). C THE QUANTITY DESIRED DEPENDS ON CONTENTS OF ARRAY DDY . C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVWF0A' / CHARACTER*60 VERS DATA VERS */ '1.0, 92/04/02. (AV3MB 1.1) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NZ .GT. NDZ) CALL ERR2(NAME, 1, 1, NOUT) IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 2, 1, NOUT) IF (MA .GT. NDMA) CALL ERR2(NAME, 3, 1, NOUT) DO 10 IZ = 1,NZ WF(IZ) = ZERO 10 CONTINUE KX1 = KX + 1 DO 24 M = 1,MA DO 22 K1 = 1,KX1 DO 20 IZ = 1,NZ WF(IZ) = WF(IZ) + DDY(K1,M) * ZDPL(IZ,K1,M) 20 CONTINUE 22 CONTINUE 24 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END avwf1a.f000644 000311 000121 00000002220 06067230120 012214 0ustar00krivecf1000000 000000 SUBROUTINE AVWF1A(NDZ, NDCN, NZ, JMAX, WFCY, ZDP, NOUT, WF) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WFCY(NDCN), ZDP(NDZ,NDCN), WF(NDZ) C C HH-EXPANDED PART OF THE WAVE FUNCTION OR ONE OF ITS DERIVATIVES, C ON INTERVALS NOT CONTAINING THE ORIGIN. C THE QUANTITY DESIRED DEPENDS ON CONTENTS OF ARRAY WFCY . C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVWF1A' / CHARACTER*60 VERS DATA VERS */ '1.0, 92/04/02. (AV3MB 1.1) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NZ .GT. NDZ) CALL ERR2(NAME, 1, 1, NOUT) IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) DO 10 IZ = 1,NZ WF(IZ) = ZERO 10 CONTINUE JMAX1 = JMAX + 1 DO 22 IP = 1,JMAX1 DO 20 IZ = 1,NZ WF(IZ) = WF(IZ) + WFCY(IP) * ZDP(IZ,IP) 20 CONTINUE 22 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END avzp0a.f000644 000311 000121 00000002552 06067230122 012242 0ustar00krivecf1000000 000000 SUBROUTINE AVZP0A(NDZ, NDKX, NDMA, NZ, KX, MA, 1 XZ, ZD1, ZDPL, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XZ(NDZ), ZDPL(NDZ,NDKX,NDMA), ZD1(NDZ) C C POWERS OF Z AND LOG(Z). (START FROM K = 0.) C ZDPL(.,K+1,M) = Z**K LOG(Z)**(M-1) / (M-1)!. C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVZP0A' / CHARACTER*60 VERS DATA VERS */ '1.0, 92/04/03. (AV3MB 1.1) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ONE / 1.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NZ .GT. NDZ) CALL ERR2(NAME, 1, 1, NOUT) IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 2, 1, NOUT) IF (MA .GT. NDMA) CALL ERR2(NAME, 3, 1, NOUT) C DO 20 IZ = 1,NZ ZD1(IZ) = ONE 20 CONTINUE DO 30 M = 1,MA DO 22 IZ = 1,NZ ZDPL(IZ,1,M) = ZD1(IZ) 22 CONTINUE DO 26 K = 1,KX DO 24 IZ = 1,NZ ZDPL(IZ,K+1,M) = XZ(IZ) * ZDPL(IZ,K,M) 24 CONTINUE 26 CONTINUE DO 28 IZ = 1,NZ ZD1(IZ) = ZD1(IZ) * LOG(XZ(IZ)) / M 28 CONTINUE 30 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END avzp1a.f000644 000311 000121 00000002120 06067230124 012234 0ustar00krivecf1000000 000000 SUBROUTINE AVZP1A(NDZ, NDCN, NZ, JMAX, Z0MX, XZ, ZDP, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XZ(NDZ), ZDP(NDZ,NDCN) C C POWERS OF (Z - Z0M). ZDP(.,P) = (Z - Z0M)**(P-1). C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVZP1A' / CHARACTER*60 VERS DATA VERS */ '1.1, 92/04/04. (AV3MB 1.1) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ONE / 1.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NZ .GT. NDZ) CALL ERR2(NAME, 1, 1, NOUT) IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) C DO 20 IZ = 1,NZ ZDP(IZ,1) = ONE 20 CONTINUE JMAX1 = JMAX + 1 IF (JMAX1 .LT. 2) GO TO 26 DO 24 IP = 2,JMAX1 DO 22 IZ = 1,NZ ZDP(IZ,IP) = (XZ(IZ) - Z0MX) * ZDP(IZ,IP-1) 22 CONTINUE 24 CONTINUE 26 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END avzpda.f000644 000311 000121 00000001622 06067230126 012327 0ustar00krivecf1000000 000000 SUBROUTINE AVZPDA(NDCN, JMAX, Z0MX, Z0PX, ZDPX, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ZDPX(NDCN) C C ADDITIONAL POWERS FOR DISCONTINUITY, AT Z = ZMATCH. C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'AVZPDA' / CHARACTER*60 VERS DATA VERS */ '1.0, 92/04/03. (AV3MB 1.1) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ONE / 1.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 1, 1, NOUT) C ZDPX(1) = ONE JMAX1 = JMAX + 1 IF (JMAX1 .GE. 2) THEN DO 20 IP = 2,JMAX1 ZDPX(IP) = (Z0PX - Z0MX) * ZDPX(IP-1) 20 CONTINUE ENDIF IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END cf000c.f000644 000311 000121 00000004151 06067230131 012011 0ustar00krivecf1000000 000000 SUBROUTINE CF000C(ND, NOUT, A, R, RA, RAA, RL, RLL, 1 N, RHO, F, FR, FRR, FA, FAA, FL, FLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION A(3), R(3), RA(3), RAA(3), RL(3), RLL(3), 1 RHO(ND), F(ND), FR(ND), FRR(ND), 2 FA(ND), FAA(ND), FL(ND), FLL(ND) C C CORRELATION FUNCTION F = A(K) R(K), AND ITS RHO, A, LAMBDA C DERIVATIVES, AT A FIXED (A, LAMBDA) POINT, FOR A SET OF RHO C VALUES. C INPUT: C A - COEFFICIENTS, C R - RADII DIVIDED BY RHO, C RA - D(R)/D(A), C RAA - D**2(R)/D(A)**2, C RL - D(R)/D(LAMBDA), C RLL - D**2(R)/D(LAMBDA)**2, C RHO - RHO VALUES. C OUTPUT: C F - CORRELATION FUNCTION, C FR - D(F)/D(RHO), C FRR - D**2(F)/D(RHO)**2, C FA - D(F)/D(A), C FAA - D**2(F)/D(A)**2, C FL - D(F)/D(LAMBDA), C FLL - D**2(F)/D(LAMBDA)**2. C C CHARACTER*6 NAME DATA NAME / 'CF000C' / CHARACTER*60 VERS DATA VERS */ ' 2.0, 92/05/22. (F = A*R) (1.0C) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. ND) CALL ERR2(NAME, 2, 1, NOUT) C C ANGULAR DEPENDENCIES. X0 = (A(1) * R(1) + A(2) * R(2) + A(3) * R(3)) XA = (A(1) * RA(1) + A(2) * RA(2) + A(3) * RA(3)) XL = (A(1) * RL(1) + A(2) * RL(2) + A(3) * RL(3)) XAA = (A(1) * RAA(1) + A(2) * RAA(2) + A(3) * RAA(3)) XLL = (A(1) * RLL(1) + A(2) * RLL(2) + A(3) * RLL(3)) DO 10 I = 1,N F(I) = X0 * RHO(I) FR(I) = X0 FRR(I) = ZERO FA(I) = XA * RHO(I) FAA(I) = XAA * RHO(I) FL(I) = XL * RHO(I) FLL(I) = XLL * RHO(I) 10 CONTINUE C RETURN 2000 FORMAT ( A 2H -, A6, 1H-, A60) END cf001c.f000644 000311 000121 00000006162 06067230134 012021 0ustar00krivecf1000000 000000 SUBROUTINE CF001C(ND, NOUT, A, B, C, R, RA, RAA, RL, RLL, 1 N, RHO, F, FR, FRR, FA, FAA, FL, FLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION A(3), B(3), C(3), 1 R(3), RA(3), RAA(3), RL(3), RLL(3), 2 RHO(ND), F(ND), FR(ND), FRR(ND), 3 FA(ND), FAA(ND), FL(ND), FLL(ND) C C CORRELATION FUNCTION F = (A + B EXP(-C R)) R, AND ITS C AND ITS RHO, A, LAMBDA DERIVATIVES, AT A FIXED (A, LAMBDA) C POINT, FOR A SET OF RHO VALUES. C INPUT: C A,B,C - COEFFICIENTS, C R - RADII DIVIDED BY RHO, C RA - D(R)/D(A), C RAA - D**2(R)/D(A)**2, C RL - D(R)/D(LAMBDA), C RLL - D**2(R)/D(LAMBDA)**2, C RHO - RHO VALUES. C OUTPUT: C F - CORRELATION FUNCTION, C FR - D(F)/D(RHO), C FRR - D**2(F)/D(RHO)**2, C FA - D(F)/D(A), C FAA - D**2(F)/D(A)**2, C FL - D(F)/D(LAMBDA), C FLL - D**2(F)/D(LAMBDA)**2. C C CHARACTER*6 NAME DATA NAME / 'CF001C' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 92/05/22. (F = (A*R + ...)) (CF001B 1.0) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ONE, TWO / 1.D0, 2.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. ND) CALL ERR2(NAME, 2, 1, NOUT) C DO 10 I = 1,N C C EXPONENTIALS. A1 = - C(1) * R(1) * RHO(I) A2 = - C(2) * R(2) * RHO(I) A3 = - C(3) * R(3) * RHO(I) E1 = EXP(A1) E2 = EXP(A2) E3 = EXP(A3) C C DERIVATIVES OF F TERMS WITH RESPECT TO RADII. F1 = (A(1) + B(1) * E1) F2 = (A(2) + B(2) * E2) F3 = (A(3) + B(3) * E3) FR1 = (A(1) + B(1) * (ONE + A1) * E1) FR2 = (A(2) + B(2) * (ONE + A2) * E2) FR3 = (A(3) + B(3) * (ONE + A3) * E3) FRR1 = - B(1) * C(1) * (TWO + A1) * E1 FRR2 = - B(2) * C(2) * (TWO + A2) * E2 FRR3 = - B(3) * C(3) * (TWO + A3) * E3 C C RHO DERIVATIVES. F(I) = (F1 * R(1) + F2 * R(2) + F3 * R(3)) * RHO(I) FR(I) = FR1 * R(1) + FR2 * R(2) + FR3 * R(3) FRR(I) = FRR1 * R(1) **2 + FRR2 * R(2) **2 + FRR3 * R(3) **2 C C A, LAMBDA DERIVATIVES. FA(I) = (FR1 * RA(1) + FR2 * RA(2) + FR3 * RA(3)) * RHO(I) FL(I) = (FR1 * RL(1) + FR2 * RL(2) + FR3 * RL(3)) * RHO(I) FAA(I) = (FRR1 * RA(1) **2 + 1 FRR2 * RA(2) **2 + 2 FRR3 * RA(3) **2 ) * RHO(I) **2 + 3 (FR1 * RAA(1) + FR2 * RAA(2) + FR3 * RAA(3)) * RHO(I) FLL(I) = (FRR1 * RL(1) **2 + 1 FRR2 * RL(2) **2 + 2 FRR3 * RL(3) **2 ) * RHO(I) **2 + 3 (FR1 * RLL(1) + FR2 * RLL(2) + FR3 * RLL(3)) * RHO(I) 10 CONTINUE C RETURN 2000 FORMAT ( A 2H -, A6, 1H-, A60) END gwamb.f000644 000311 000121 00000006627 06067230166 012155 0ustar00krivecf1000000 000000 SUBROUTINE GWAMB(NDGO, NDPAS, NA, XA, MXPLOG, IASL, LPWA, NOUT, 1 S, INDEX, WK1Q, WK2Q, 2 XAM, WAMS) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LPWA DIMENSION XA(NDGO), 1 S(NDGO,NDGO), INDEX(NDGO,2), 2 XAM(NDGO), WAMS(NDPAS) C ************ REAL*16 WK1Q(NDGO,NDGO), WK2Q(NDGO) C ************ C C C MODIFY INTEGRATION WEIGHTS IF SEGMENT IS IN SINGULAR REGION. C MODIFIED WEIGHTS ARE COMPUTED FOR AVERAGES OF R(I)**P TYPE FOR C P = -2, -1; (OTHER R(I)**P AVERAGES ARE COMPUTED WITH THE WEIGHTS C DETERMINED FROM THE GAUSSIAN QUADRATURES. C C INTEGRATION WEIGHTS ARE COMPUTED BY THE METHOD OF "MOMENTS"; C WE ASSUME THAT THE (SINGULAR) FUNCTION TO BE INTEGRATED (G(X)) C CAN BE EXPANDED IN TERMS OF BASIS FUNCTIONS F(I;X), I.E., C G(X) = SUM(I)(G(I)*F(I,X)); WE ALSO ASSUME THE INTEGRAL CAN BE C APPROXIMATED INT(G(X)*DX) = SUM(J)(G(X(J))*DX(J)), WHERE X(J) ARE C FIXED POINTS AND DX(J) ARE INTEGRATION WEIGHTS TO BE DETERMINED C BY REQUIRING THAT THE INTEGRATION FORMULA IS EXACT FOR A FINITE C SET OF BASIS FUNCTIONS EQUAL IN NUMBER TO THE NUMBER OF C INTEGRATION POINTS; THIS REQUIREMENT LEADS TO THE CONDITION C SUM(J = 1,N)(F(I;X(J))*DX(J)) = INT(F(I;X)*DX); THIS CAN BE C WRITTEN AS A MATRIX EQUATION FOR THE VECTOR DX F*DX = INT, WHERE C F(I,J) = F(I;X(J)), INT(I) = INT(F(I;X)*DX); IF THE INTEGRALS C INT(I) CAN BE DONE ANALYTICALLY (OR VERY, VERY ACCURATELY C NUMERICALLY) THE MATRIX EQUATION CAN BE SOLVED FOR THE WEIGHTS C DX(J). C C CHARACTER*6 NAME DATA NAME / 'GWAMB ' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 91/08/02. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ONE, HALF / 1.D0, 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (NA .GT. NDGO) CALL ERR2(NAME, 1, 1, NOUT) IF (IASL .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IASL + NA - 1 .GT. NDPAS) CALL ERR2(NAME, 3, 1, NOUT) C PI2 = HALF * CDXPI() C C CHANGE INTEGRATION VARIABLE FROM A TO X = PI/2 - A FOR C SINGULAR TERMS. DO 20 I = 1,NA XAM(I) = PI2 - XA(I) 20 CONTINUE C C MOST SINGULAR TERM (AFTER LAMBDA INTEGRATION) IS X**1*LN(X). MLMIN = 1 C C COMPUTE WEIGHTS APPROPRIATE FOR ; THESE WILL ALSO BE C APPROPRIATE FOR , , . C ABASI1 COMPUTES F(I;X(J)) AND STORES IN S(I,J). C AINTE1 COMPUTES INT(I) AND TEMPORARILY STORES IT IN WAMS. C MATIXD SOLVES MATRIX EQUATIONS FOR WEIGHTS AND STORES THEM IN C WAMS. CALL ABASI1(NDGO, XAM, NA, MXPLOG, MLMIN, ONE, S, NOUT) CALL AINTE1(NDGO, 1 PI2-XA(NA), PI2-XA(1), 2 NA, MXPLOG, MLMIN, 3 ONE, WAMS(IASL), NOUT) CALL MATIXD(S, WAMS(IASL), WK1Q, WK2Q, 1 NA, 1, NDGO, 1, INDEX, LPWA) IF (.NOT. LPWA) RETURN C C TEST OUTPUT. WRITE (NOUT,2100) NAME, 1 (I, WAMS(IASL+I-1), (IASL+I-1), I = 1,NA) RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 4HWAMS, /, B (1H , 4X, I4, F12.6, I4)) END gwlmb.f000644 000311 000121 00000007754 06067230167 012173 0ustar00krivecf1000000 000000 SUBROUTINE GWLMB(NDGO, NDPLS, NDPAS, LPWL, NOUT, 1 NA, NL, XL, MXPINV, IRL, IASL, ILSL, XSING, XAM, 2 S, INDEX, WK1Q, WK2Q, XLM, 3 WLMS) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LPWL DIMENSION XL(NDGO), XSING(3), XAM(NDGO), 1 S(NDGO,NDGO), INDEX(NDGO,2), 2 XLM(NDGO), WLMS(NDPLS,NDPAS,2) C ************ REAL*16 WK1Q(NDGO,NDGO), WK2Q(NDGO) C ************ C C C MODIFY LAMBDA WEIGHTS IF A, LAMBDA ARE BOTH IN SINGULAR REGIONS. C WLMS IS A GLOBAL ARRAY CONTAINING ALL MODIFIED WEIGHTS. C POINTERS MUST BE PROVIDED FOR (OPERATOR, TERM) PAIRS TO THE C THIRD INDEX OF WLMS. C C CHARACTER*6 NAME DATA NAME / 'GWLMB ' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 91/08/01. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C MODIFY ONLY IF REGION NUMBER IS 2, 3, 5, 6, 8, OR 9. IF (MOD(IRL, 3) .EQ. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NA .GT. NDGO) CALL ERR2(NAME, 2, 1, NOUT) IF (NL .GT. NDGO) CALL ERR2(NAME, 3, 1, NOUT) C PI = CDXPI() C C SELECT THE LAMBDA REGION AND COMPUTE Y VALUES FOR THE POINTS C IN THE SEGMENT (Y = CLOSEST OR NEXT SINGULAR LAMBDA POINT C MINUS LAMBDA); COMPUTE Y BOUNDARIES OF SEGMENT. IF (IRL .EQ. 2) THEN DO 30 I = 1,NL XLM(I) = XSING(1) - XL(I) 30 CONTINUE PL1 = XLM(NL) PL2 = XLM(1) ELSE IF (IRL .EQ. 3) THEN DO 32 I = 1,NL XLM(I) = XL(I) - XSING(1) 32 CONTINUE PL1 = XLM(1) PL2 = XLM(NL) ELSE IF (IRL .EQ. 5) THEN DO 34 I = 1,NL XLM(I) = XSING(2) - XL(I) 34 CONTINUE PL1 = XLM(NL) PL2 = XLM(1) ELSE IF (IRL .EQ. 6) THEN DO 36 I = 1,NL XLM(I) = XL(I) - XSING(2) 36 CONTINUE PL1 = XLM(1) PL2 = XLM(NL) ELSE IF (IRL .EQ. 8) THEN DO 38 I = 1,NL XLM(I) = XSING(3) - XL(I) 38 CONTINUE PL1 = XLM(NL) PL2 = XLM(1) ELSE IF (IRL .EQ. 9) THEN DO 40 I = 1,NL XLM(I) = XL(I) - XSING(3) 40 CONTINUE PL1 = XLM(1) PL2 = XLM(NL) ENDIF C IAS = IASL - 1 DO 50 I = 1,NA C C GLOBAL A POINT COUNT IN SINGULAR A-REGION. IAS = IAS + 1 IF (IAS .GT. NDPAS) CALL ERR2(NAME, 4, 1, NOUT) C C COMPUTE WEIGHTS FOR 1/R(I) TYPE SINGULARITY (MOST SINGULAR C TERM HERE IS (X**2+Y**2)**(-1/2)). LBASI1 COMPUTES BASIS C FUNCTIONS OF THE FORM X**I/(X**2+Y**2)**J. C LINTE1 COMPUTES INTEGRALS OF THESE FUNCTIONS. C MATIXD SOLVES FOR WEIGHTS. CALL LBASI1(NDGO, XLM, NL, MXPINV, 2, XAM(I), S, NOUT) CALL LINTE1(NDGO, PL1, PL2, NL, MXPINV, 2, XAM(I), 1 WLMS(ILSL,IAS,1), NOUT) CALL MATIXD(S, WLMS(ILSL,IAS,1), WK1Q, WK2Q, 1 NL, 1, NDGO, 1, INDEX, LPWL) C C REPEAT FOR 1/R(I)**2 TYPE SINGULARITY (MOST SINGULAR TERM: C (X**2+Y**2)**(-2)). CALL LBASI1(NDGO, XLM, NL, MXPINV, 3, XAM(I), S, NOUT) CALL LINTE1(NDGO, PL1, PL2, NL, MXPINV, 3, XAM(I), 1 WLMS(ILSL,IAS,2), NOUT) CALL MATIXD(S, WLMS(ILSL,IAS,2), WK1Q, WK2Q, 1 NL, 1, NDGO, 1, INDEX, LPWL) IF (.NOT. LPWL) GO TO 50 C C TEST OUTPUT. WRITE (NOUT,2100) NAME, IAS, 1 (J, WLMS(ILSL+J-1,IAS,1), WLMS(ILSL+J-1,IAS,2), 2 (ILSL+J-1), J = 1,NL) 50 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 12HWLMS - IAS: , I4, /, B (1H , I4, 2F12.6, I4)) END iohtaa.f000644 000311 000121 00000002017 06067230173 012310 0ustar00krivecf1000000 000000 INTEGER FUNCTION IOHTAA(IRA, NOUT) C C C POINTER TABLE FOR HAMILTONIAN TERMS TO MODIFIED WEIGHTS IN C VARIABLE A. C 0: UNMODIFIED WEIGHTS; 1: MODIFIED WEIGHTS. C INDEPENDENT OF H TERM. IOHTAA = 1 IN THE FOLLOWING CASES: C C A-REGION LAMBDA-REGIONS C 2 ALL C C NOTE: THIS VERSION KEEPS THE CONVENTION OF HYPWF C THAT A-WEIGHTS ARE MODIFIED ONLY ACCORDING TO C WHETHER A IS SINGULAR REGION, INDEPENDENTLY OF LAMBDA. C SEE ALSO IOTAA. C C CHARACTER*6 NAME DATA NAME / 'IOHTAA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/31. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IOHTAA = 0 IF (IRA .EQ. 2) IOHTAA = 1 RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END iohtla.f000644 000311 000121 00000001634 06067757660 012346 0ustar00krivecf1000000 000000 INTEGER FUNCTION IOHTLA(IRA, IRL, NOUT) C C C POINTER TABLE FOR HAMILTONIAN TERMS TO MODIFIED WEIGHTS IN C VARIABLE LAMBDA. INDEPENDENT OF TERM. C 0: UNMODIFIED WEIGHTS; 1: MODIFIED WEIGHTS OF 1/R TYPE. C IOHTLA = 1 IN THE FOLLOWING CASES: C C A-REGION LAMBDA-REGIONS C 2 2, 3, 5, 6, 8, 9 C C CHARACTER*6 NAME DATA NAME / 'IOHTLA ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/31. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IOHTLA = 0 IF (IRA .EQ. 2 .AND. MOD(IRL, 3) .NE. 1) IOHTLA = 1 RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END iotaa.f000644 000311 000121 00000004251 06067230176 012145 0ustar00krivecf1000000 000000 INTEGER FUNCTION IOTAA(IOP, IRA, IRL, NOUT) C C C POINTER TABLE FOR OPERATORS TO MODIFIED WEIGHTS IN VARIABLE A. C 0: UNMODIFIED WEIGHTS; 1: MODIFIED WEIGHTS. C HERE OPERATOR REFERS TO THE R(K)**P OPERATORS ONLY, NOT TO C THE HAMILTONIAN TERMS. IOTAA = 1 IN THE FOLLOWING CASES: C C IOP OPERATOR A-REGION LAMBDA-REGIONS C C 1 1 C 2 R(1) C 3 R(2) C 4 R(3) C 5 R(1)**2 C 6 R(2)**2 C 7 R(3)**2 C 8 R(1)**-1 2 6 - 10 C 9 R(2)**-1 2 1 - 5 C 10 R(3)**-1 2 1 - 10 C 11 R(1)**-2 2 6 - 10 C 12 R(2)**-2 2 1 - 5 C 13 R(3)**-2 2 1 - 10 C C INTEGRATION IS OVER THE ENTIRE LAMBDA INTERVAL (ENABLING C NONSYMMETRIC CASES). THE ASSUMED CONVENTION FOR PARAMETERS C IS SUCH THAT R(1) = 0 APPEARS FOR LAMBDA .GT. PI. C C NOTE: THIS VERSION KEEPS THE CONVENTION OF HYPWF C THAT A-WEIGHTS ARE MODIFIED ONLY ACCORDING TO C WHETHER LAMBDA FALLS LEFT OR RIGHT OF LAMBDA = PI, C AND NOT WHETHER LAMBDA IS IN A SINGULAR REGION. C FOR EXAMPLE, OPERATOR R(1)**-1 HAS WEIGHTS MODIFIED C IN LAMBDA REGIONS 6 - 10, ALTHOUGH SINGULARITY C BORDERS ONLY REGIONS 8 AND 9. THIS RESTRICTION (IF C IT DOES NOT HAVE OTHER REASONS) CAN BE EASILY C ELIMINATED. C C CHARACTER*6 NAME DATA NAME / 'IOTAA ' / CHARACTER*60 VERS DATA VERS */ ' 2.0, 91/07/30. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IOP .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IOP .GT. 13) CALL ERR2(NAME, 2, 1, NOUT) C IOTAA = 0 IF (IOP .LE. 7 .OR. IRA .EQ. 1) RETURN IF ((IRL .LE. 5 .AND. MOD(IOP, 3) .NE. 2) .OR. 1 (IRL .GE. 6 .AND. MOD(IOP, 3) .NE. 0) ) IOTAA = 1 RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END iotla.f000644 000311 000121 00000004331 06067230177 012160 0ustar00krivecf1000000 000000 INTEGER FUNCTION IOTLA(IOP, IRA, IRL, NOUT) C C C POINTER TABLE FOR OPERATORS TO MODIFIED WEIGHTS IN VARIABLE C LAMBDA. C 0: UNMODIFIED WEIGHTS; 1: MODIFIED WEIGHTS OF 1/R TYPE; C 2: MODIFIED WEIGHTS OF 1/R**2 TYPE. C HERE OPERATOR REFERS TO THE R(K)**P OPERATORS ONLY, NOT TO C THE HAMILTONIAN TERMS. IOTLA = 1 OR 2 IN THE FOLLOWING CASES: C C LAMBDA-REGIONS C IOP OPERATOR A-REGION IOTLA = 1 IOTLA = 2 C C 1 1 C 2 R(1) C 3 R(2) C 4 R(3) C 5 R(1)**2 C 6 R(2)**2 C 7 R(3)**2 C 8 R(1)**-1 2 8, 9 C 9 R(2)**-1 2 2, 3 C 10 R(3)**-1 2 5, 6 C 11 R(1)**-2 2 8, 9 C 12 R(2)**-2 2 2, 3 C 13 R(3)**-2 2 5, 6 C C INTEGRATION IS OVER THE ENTIRE LAMBDA INTERVAL (ENABLING C NONSYMMETRIC CASES). THE ASSUMED CONVENTION FOR PARAMETERS C IS SUCH THAT R(1) = 0 APPEARS FOR LAMBDA .GT. PI. C C CHARACTER*6 NAME DATA NAME / 'IOTLA ' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/07/29. O: HYPWF (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IOP .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IOP .GT. 13) CALL ERR2(NAME, 2, 1, NOUT) C IOTLA = 0 IF (IRA .EQ. 1 .OR. IOP .LE. 7) RETURN IF ((IOP .EQ. 8 .AND. (IRL .EQ. 8 .OR. IRL .EQ. 9)) .OR. 1 (IOP .EQ. 9 .AND. (IRL .EQ. 2 .OR. IRL .EQ. 3)) .OR. 2 (IOP .EQ. 10 .AND. (IRL .EQ. 5 .OR. IRL .EQ. 6)) ) THEN IOTLA = 1 RETURN ENDIF IF ((IOP .EQ. 11 .AND. (IRL .EQ. 8 .OR. IRL .EQ. 9)) .OR. 1 (IOP .EQ. 12 .AND. (IRL .EQ. 2 .OR. IRL .EQ. 3)) .OR. 2 (IOP .EQ. 13 .AND. (IRL .EQ. 5 .OR. IRL .EQ. 6)) ) THEN IOTLA = 2 RETURN ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END lbasi1.f000644 000311 000121 00000003560 06067230201 012212 0ustar00krivecf1000000 000000 SUBROUTINE LBASI1(ND, X, N, MXPINV, KPM, B, S, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION X(ND), S(ND,ND) C C COMPUTES N BASIS FUNCTIONS F(I;X) AT N POINTS X(J), J = 1,N; C THEY ARE STORED IN S(I,J) = F(I;X(J)); THE BASIS FUNCTIONS ARE: C F(I;X) = (X**2 + B**2)**(K/2) (K = 1-KPM,0); C X * (X**2 + B**2)**(K/2) (K = SIGN(MXPINV)*(1-KPM),0); C X**M / (X**2 + B**2)**(-1/2), X**M (M = 2,MXPINV); C X**M (M = MXPINV + 1,...) C (MXPINV> = 0, KPM>0). C C CHARACTER*6 NAME DATA NAME / 'LBASI1' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/07/26. O: LBASIS (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) C C FIX X DO 1 J = 1,N C C INITIALIZE FUNCTION NUMBER I = 0 C C COMPUTE (X**2+B**2)**(1/2) SJ2 = SQRT(X(J) ** 2 + B ** 2) C C LOOP OVER POWERS OF X DO 2 M1 = 1,N M = M1 - 1 C C COMPUTE NUMBER OF FUNCTIONS FOR THIS POWER KPMAX = MIN(3, KPM) IF (M .GT. 1) KPMAX = 2 IF (M .GT. MXPINV) KPMAX = 1 C C LOOP OVER THESE FUNCTIONS DO 3 K = 1,KPMAX C C COMPUTE POWER OF 1/(X**2+B**2) KX2 = KPMAX - K C C INCREMENT FUNCTION NUMBER I = I + 1 C C COMPUTE F(I;X) S(I,J) = X(J) ** M / SJ2 ** KX2 C C QUIT WHEN N FUNCTIONS HAVE BEEN COMPUTED IF (I .EQ. N) GO TO 1 3 CONTINUE 2 CONTINUE 1 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END linte1.f000644 000311 000121 00000004737 06067230203 012244 0ustar00krivecf1000000 000000 SUBROUTINE LINTE1(ND, X1, X2, N, MXPINV, KPM, B, AINT, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION AINT(ND) C C C COMPUTES INT(X1,X2)(DX*F(I;X)) AND STORES IN AINT(I); C SEE LBASI1 FOR THE BASIS FUNCTIONS F(I;X). C C CHARACTER*6 NAME DATA NAME / 'LINTE1' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/07/26. O: LINTEG (M. HAFTEL). ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 HALF / 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) C C INITIALIZE FUNCTION NUMBER J = 0 C C COMPUTE SQRT(X**2+B**2) AT INTEGRATION LIMITS B2 = B ** 2 S1 = SQRT(X1 ** 2 + B2) S2 = SQRT(X2 ** 2 + B2) C C FIX POWER OF X DO 1 M1 = 1,N M = M1 - 1 C C COMPUTE NUMBER OF FUNCTIONS WITH THIS POWER OF X KPMAX = MIN(3, KPM) IF (M .GT. 1) KPMAX = 2 IF (M .GT. MXPINV) KPMAX = 1 C C LOOP OVER THESE FUNCTIONS DO 2 K = 1,KPMAX C C COMPUTE POWER OF 1/(X**2+B**2) (THIS IS KX/2) KX = KPMAX - K C C INCREMENT FUNCTION NUMBER J = J + 1 C C INTEGRAL FOR (X**2+B**2)**(-1) IF (M .EQ. 0 .AND. KX .EQ. 2) 1 AINT(J) = (ATAN(X2 / B) - ATAN(X1 / B)) / B C C INTEGRAL FOR X/(X**2+B**2) IF (M .EQ. 1 .AND. KX .EQ. 2) 1 AINT(J) = HALF * LOG((X2 ** 2 + B2) / (X1 ** 2 + B2)) C C INTEGRAL FOR 1/SQRT(X**2+B**2) IF (M .EQ. 0 .AND. KX .EQ. 1) 1 AINT(J) = LOG((X2 + S2) / (X1 + S1)) C C INTEGRAL FOR X**M IF (KX .EQ. 0) AINT(J) = (X2 ** M1 - X1 ** M1) / M1 C C INTEGRAL FOR X/SQRT(X**2+B**2) IF (KX .EQ. 1 .AND. M .EQ. 1) AINT(J) = S2 - S1 C C INTEGRAL FOR X**M/SQRT(X**2+B**2) BY RECURSION IF (KX .EQ. 1 .AND. M .GT. 1) THEN JP = J - 4 IF (M .EQ. 2 .AND. KPM .EQ. 3) JP = J - 5 AINT(J) = 1 (X2 ** (M - 1) * S2 - X1 ** (M - 1) * S1) / M 2 - B2 * (M - 1) * AINT(JP) / M END IF C C QUIT WHEN N INTEGRALS HAVE BEEN EVALUATED IF (J .EQ. N) RETURN 2 CONTINUE 1 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m2xgqa.f000644 000311 000121 00000005066 06067230265 012253 0ustar00krivecf1000000 000000 SUBROUTINE M2XGQA(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 N, NSI, A, B, 2 P, Z, AG, WG, PTESTG, NOUT, 3 X, W) IMPLICIT REAL * 8 (A-H, O-Z) LOGICAL PTESTG DIMENSION X(NDGO,NDSI), W(NDGO,NDSI) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C MULTIPLE GAUSSIAN QUADRATURE POINTS AND WEIGHTS ON (A, B). C PRIMARY ABSCISSAS/WEIGHTS ARE CALCULATED IN EXTENDED PRECISION. C VALUES AGREE WITH THOSE OF ABRAMOWITZ/STEGUN EVEN FOR N = 96, C EXCEPT IN TWO INSTANCES WHERE THE 21-ST DIGIT AFTER COMMA C DIFFERS (MAYBE THE A/S BOOK HAS ERROS). C V 1.0: DIFFERS FROM M1XG0A ONLY IN X, W ARRAY INDEXING, AND C ELIMINATION OF AG1, WG1. C C ON ENTRY C N GAUSSIAN ORDER C NSI NUMBER OF SUBDIVISIONS OF (A, B) C A, B BOUNDS OF (A, B) C PTESTG TEST OUTPUT BY CGAUSS. C C ON EXIT C X(J,I) J = 1,... N, I = 1,..., NSI, QUADRATURE POINTS. C W(J,I) J = 1,... N, I = 1,..., NSI, QUADRATURE WEIGHTS. C C THE REST ARE WORKING ARRAYS. C C CHARACTER*6 NAME DATA NAME / 'M2XGQA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/16. O: M1XGQA 1.0, 91/07/11. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, XTOL / 1.0D-10 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (N .LT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. NDGO) CALL ERR2(NAME, 2, 1, NOUT) IF (N+1 .GT. NDGO1) CALL ERR2(NAME, 3, 1, NOUT) IF ((N+1)/2 .GT. NDGO2) CALL ERR2(NAME, 4, 1, NOUT) IF (N/2+2 .GT. NDGO1Z) CALL ERR2(NAME, 5, 1, NOUT) IF (NSI .GT. NDSI) CALL ERR2(NAME, 6, 1, NOUT) IF (NSI .LT. 1) CALL ERR2(NAME, 7, 1, NOUT) IF (B - A .LT. XTOL) CALL ERR2(NAME, 8, 1, NOUT) C C HALF OF GAUSSIAN POINTS FOR ORDER N. CALL GAUSCQ(NDGO2, NDGO1, NDGO1Z, 1 N, Z, P, AG, WG, NOUT, PTESTG) C C LOOP OVER SUBINTERVALS. H = (B - A) / NSI DO 20 I = 1,NSI ASI = A + H * (I - 1) BSI = A + H * I IF (I .EQ. NSI) BSI = B CALL GAUSQ(NDGO2, NDGO, AG, WG, N, ASI, BSI, 1 X(1,I), W(1,I), NOUT) 20 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END matinq.f000644 000311 000121 00000005170 06067230300 012327 0ustar00krivecf1000000 000000 SUBROUTINE MATINQ(A, B, N, M, NT, MT, INDEX) IMPLICIT REAL*16 (A-H, O-Z) DIMENSION A(NT,NT), B(NT,MT), INDEX(NT,2) C C C SIMULTANEOUS LINEAR EQUATION SOLVER. C SOLVES A*X=Y. C ON INPUT A=COEFFICIENT MATRIX A, B=Y. C ON OUTPUT A IS DESTROYED AND B=X. C C CHARACTER*6 NAME DATA NAME / 'MATINQ' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/02/12. O: MATIND 2.1, 91/02/12. ' / C ------------------------------------------------------------ C C C DEFINE DIMENSION FOR DECLARATIONS (MUST EQUAL NT). PARAMETER (NCDS = 32) C DIMENSION IPIVOT(NCDS), PIVOT(NCDS) C COMMON / REFDIM / NRDS COMMON / IO / NIN, NOUT C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C CHECK THE DIMENSIONS AGAINST THE REFERENCE DIMENSIONS C PASSED BY THE MAIN PROGRAM. IF (NCDS .NE. NRDS) CALL ERR2(NAME, 1, 1, NOUT) IF (NT .NE. NRDS) CALL ERR2(NAME, 2, 1, NOUT) IF (N .GT. NRDS) CALL ERR2(NAME, 3, 1, NOUT) IF (M .GT. MT) CALL ERR2(NAME, 4, 1, NOUT) C C 10 DETERM=1.Q0 15 DO 20 J=1,N 20 IPIVOT(J)=0 30 DO 550 I=1,N 40 AMAX=0.Q0 45 DO 105 J=1,N 50 IF (IPIVOT(J)-1) 60, 105, 60 60 DO 100 K=1,N 70 IF (IPIVOT(K)-1) 80, 100, 740 80 IF (QABS(AMAX)-QABS(A(J,K))) 85, 100, 100 85 IROW=J 90 ICOLUM=K 95 AMAX=A(J,K) 100 CONTINUE 105 CONTINUE 110 IPIVOT(ICOLUM)=IPIVOT(ICOLUM)+1 130 IF (IROW-ICOLUM) 140, 260, 140 140 DETERM=-DETERM 150 DO 200 L=1,N 160 SWAP=A(IROW,L) 170 A(IROW,L)=A(ICOLUM,L) 200 A(ICOLUM,L)=SWAP 205 IF(M) 260, 260, 210 210 DO 250 L=1, M 220 SWAP=B(IROW,L) 230 B(IROW,L)=B(ICOLUM,L) 250 B(ICOLUM,L)=SWAP 260 INDEX(I,1)=IROW 270 INDEX(I,2)=ICOLUM 310 PIVOT(I)=A(ICOLUM,ICOLUM) 320 CONTINUE 330 A(ICOLUM,ICOLUM)=1.Q0 340 DO 350 L=1,N 350 A(ICOLUM,L)=A(ICOLUM,L)/PIVOT(I) 355 IF(M) 380, 380, 360 360 DO 370 L=1,M 370 B(ICOLUM,L)=B(ICOLUM,L)/PIVOT(I) 380 DO 550 L1=1,N 390 IF(L1-ICOLUM) 400, 550, 400 400 T=A(L1,ICOLUM) 420 A(L1,ICOLUM)=0.Q0 430 DO 450 L=1,N 450 A(L1,L)=A(L1,L)-A(ICOLUM,L)*T 455 IF(M) 550, 550, 460 460 DO 500 L=1,M 500 B(L1,L)=B(L1,L)-B(ICOLUM,L)*T 550 CONTINUE 600 DO 710 I=1,N 610 L=N+1-I 620 IF (INDEX(L,1)-INDEX(L,2)) 630, 710, 630 630 JROW=INDEX(L,1) 640 JCOLUM=INDEX(L,2) 650 DO 705 K=1,N 660 SWAP=A(K,JROW) 670 A(K,JROW)=A(K,JCOLUM) 700 A(K,JCOLUM)=SWAP 705 CONTINUE 710 CONTINUE 740 RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END matixd.f000644 000311 000121 00000005255 06067230302 012332 0ustar00krivecf1000000 000000 SUBROUTINE MATIXD(AS, BS, A, B, N, M, NT, MT, INDEX, LPR) IMPLICIT REAL*16 (A-H, O-Z) REAL*8 AS(NT,NT), BS(NT,MT) DIMENSION A(NT,NT), B(NT,MT), INDEX(NT,2) LOGICAL LPR C C C SIMULTANEOUS LINEAR EQUATION SOLVER: A*X=Y. C ON INPUT AS = A, BS = Y. C ON OUTPUT AS = A, BS = X. C CALCULATIONS ARE DONE IN EXTENDED PRECISION WITH RESPECT TO C INPUT/OUTPUT. C C CHARACTER*6 NAME DATA NAME / 'MATIXD' / CHARACTER*60 VERS DATA VERS */ ' 2.0, 91/03/11. O: MATINV (WF PACKAGE, M. HAFTEL). ' / C ------------------------------------------------------------ C C C DEFINE DIMENSION. PARAMETER (NCDS = 32) C DIMENSION PIVOT(NCDS), IPIVOT(NCDS) C COMMON / REFDIM / NRDS COMMON / IO / NIN, NOUT C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C CHECK THE DIMENSIONS AGAINST THE REFERENCE DIMENSIONS C PASSED BY THE MAIN PROGRAM; ETC. IF (NCDS .NE. NRDS) CALL ERR2(NAME, 1, 1, NOUT) IF (NT .NE. NRDS) CALL ERR2(NAME, 2, 1, NOUT) IF (N .GT. NRDS) CALL ERR2(NAME, 3, 1, NOUT) IF (M .GT. MT) CALL ERR2(NAME, 4, 1, NOUT) C C A, B ARE DOUBLE PRECISION VERSIONS OF AS, BS (ON INPUT). DO 2 J = 1,N DO 1 I = 1,N A(I,J) = AS(I,J) 1 CONTINUE 2 CONTINUE DO 4 J = 1,M DO 3 I = 1,N B(I,J) = BS(I,J) 3 CONTINUE 4 CONTINUE IF (LPR) THEN C TEST OUTPUT. WRITE (NOUT,3000) NAME DO 11 I = 1,N WRITE (NOUT,3002) I, (A(I,J), J = 1,N) 11 CONTINUE WRITE (NOUT,3010) NAME DO 12 I = 1,N WRITE (NOUT,3002) I, (B(I,J), J = 1,M) 12 CONTINUE ENDIF CALL MATINQ(A, B, N, M, NT, MT, INDEX) C C TRUNCATE FINAL RESULT TO SINGLE PRECISION. DO 6 J = 1,M DO 5 I = 1,N BS(I,J) = B(I,J) 5 CONTINUE 6 CONTINUE IF (LPR) THEN C TEST OUTPUT. WRITE (NOUT,3020) NAME DO 61 I = 1,N WRITE (NOUT,3004) I, (BS(I,J), J = 1,M) 61 CONTINUE ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 3000 FORMAT ( A 2H -, A6, 1H-, 32HMATRIX A (EXTENDED PRECISION): ) 3010 FORMAT ( A 2H -, A6, 1H-, 32HMATRIX B (EXTENDED PRECISION): ) 3020 FORMAT ( A 2H -, A6, 1H-, 32HSOLUTION BS (NORMAL PRECISION): ) 3002 FORMAT ( A 1H , I4, 4D16.8, /, (1H , 4X, 4D16.8)) 3004 FORMAT ( A 1H , I4, 4D16.8, /, (1H , 4X, 4D16.8)) END qawt.f000644 000311 000121 00000001702 06067230304 012013 0ustar00krivecf1000000 000000 SUBROUTINE QAWT(ND, N, X1, W1, A, B, X, W, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION X1(ND), W1(ND), X(ND), W(ND) C C TRANSFORMS QUADRATURE POINTS AND WEIGHTS FROM INTERVAL (-1, 1) C TO INTERVAL (A, B). C CHARACTER*6 NAME DATA NAME / 'QAWT ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/17. ' / C ------------------------------------------------------------ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, HALF / 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) IF (A .GE. B) CALL ERR2(NAME, 2, 1, NOUT) C DO 10 I = 1,N X(I) = (HALF * (B - A)) * X1(I) + (HALF * (B + A)) W(I) = (HALF * (B - A)) * W1(I) 10 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END twf0a.f000644 000311 000121 00000002122 06067230314 012056 0ustar00krivecf1000000 000000 SUBROUTINE TWF0A(NDMA, NDKX, MA, KX, DDY, ZDPL, NOUT, WF) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION DDY(NDKX,NDMA), ZDPL(NDKX,NDMA) C C HH-EXPANDED PART OF THE WAVE FUNCTION OR ONE OF ITS DERIVATIVES, C ON THE FIRST INTERVAL (CONTAINING THE ORIGIN). C THE QUANTITY DESIRED DEPENDS ON CONTENTS OF ARRAY DDY . C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'TWF0A ' / CHARACTER*60 VERS DATA VERS */ '1.0, 93/01/19. (AVWF0A 1.0) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 1, 1, NOUT) IF (MA .GT. NDMA) CALL ERR2(NAME, 2, 1, NOUT) WF = ZERO KX1 = KX + 1 DO 22 M = 1,MA DO 20 K1 = 1,KX1 WF = WF + DDY(K1,M) * ZDPL(K1,M) 20 CONTINUE 22 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END twf1a.f000644 000311 000121 00000001726 06067230317 012073 0ustar00krivecf1000000 000000 SUBROUTINE TWF1A(NDCN, JMAX, WFCY, ZDP, NOUT, WF) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WFCY(NDCN), ZDP(NDCN) C C HH-EXPANDED PART OF THE WAVE FUNCTION OR ONE OF ITS DERIVATIVES, C ON INTERVALS NOT CONTAINING THE ORIGIN. C THE QUANTITY DESIRED DEPENDS ON CONTENTS OF ARRAY WFCY . C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'TWF1A ' / CHARACTER*60 VERS DATA VERS */ '1.0, 93/01/19. (AVWF1A 1.0) ' / C ............................................................ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 1, 1, NOUT) WF = ZERO JMAX1 = JMAX + 1 DO 20 IP = 1,JMAX1 WF = WF + WFCY(IP) * ZDP(IP) 20 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END v000.f000644 000311 000121 00000001644 06067230322 011531 0ustar00krivecf1000000 000000 SUBROUTINE V000(ND, NOUT, ZZ, RI, N, RHOI, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ZZ(3), RI(3), RHOI(ND), V(ND) C C COULOMB POTENTIAL, V = ZZ / R, AT A FIXED (A, LAMBDA) POINT, C FOR A SET OF RHO VALUES. C CHARACTER*6 NAME DATA NAME / 'V000 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/29. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (N .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. ND) CALL ERR2(NAME, 2, 1, NOUT) C X0 = ZZ(1) * RI(1) + ZZ(2) * RI(2) + ZZ(3) * RI(3) DO 10 I = 1,N V(I) = X0 * RHOI(I) 10 CONTINUE C RETURN 2000 FORMAT ( A 2H -, A6, 1H-, A60) END wt3ala.f000644 000311 000121 00000010065 06067230337 012242 0ustar00krivecf1000000 000000 SUBROUTINE WT3ALA(NDT, 1 NT, T, XKAPPA, XOMEGA, 2 ARGA, ARG1A, AUXA1, 3 R, RA, RAA, RL, RLL, RP, LP, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION T(NDT,3), XKAPPA(3), XOMEGA(3), 1 ARGA(NDT), ARG1A(NDT), AUXA1(NDT), 2 R(3,NDT), RA(3,NDT), RAA(3,NDT), 3 RL(3,NDT), RLL(3,NDT), RP(9,NDT) LOGICAL LP C C RHO-INDEPENDENT FUNCTIONS OF (A, LAMBDA), INCLUDING THE VALUES OF C RADII DIVIDED BY RHO, AND THEIR DERIVATIVES WITH RESPECT TO A AND C LAMBDA. C THIS ROUTINE IS DERIVED FROM THE ONE FOR AVERAGES WHICH USES A C DIFFERENT STORAGE METHOD FOR POINTS (FOR GAUSSIAN QUADRATURE). C C OUTPUT: C ARGA - COS(2 A). C ARG1A - SIN(A). C AUXA1 - 2 COT(2 A). C R - INTERPARTICLE RADIUS / RHO. C RA - A DERIVATIVE OF R. C RAA - SECOND A DERIVATIVE OF R. C RL - LAMBDA DERIVATIVE OF R. C RLL - SECOND LAMBDA DERIVATIVE OF R. C RP - POWERS OF R. C CHARACTER*6 NAME DATA NAME / 'WT3ALA' / CHARACTER*60 VERS DATA VERS */ ' 2.1, 93/01/28 (AV2ALB 1.2) ' / C ------------------------------------------------------------ C DIMENSION AUXL(6) LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE, HALF / 1.D0, 0.5D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (NT .LE. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (NT .GT. NDT) CALL ERR2(NAME, 2, 1, NOUT) C C FUNCTIONS OF A. DO 10 I = 1,NT C C OUTPUT FUNCTIONS. ARGA(I) = COS(2 * T(I,1)) ARG1A(I) = SIN(T(I,1)) AUXA1(I) = 2 * COS(2 * T(I,1)) / SIN(2 * T(I,1)) 10 CONTINUE C C FUNCTIONS OF (A, LAMBDA). Z1 = HALF * XKAPPA(1) Z2 = HALF * XKAPPA(2) Z3 = HALF * XKAPPA(3) DO 20 I = 1,NT C C AUXILIARY FUNCTIONS. AUXA = COS(T(I,1)) AUXL(1) = COS(T(I,2) + XOMEGA(1)) AUXL(2) = COS(T(I,2) + XOMEGA(2)) AUXL(3) = COS(T(I,2) + XOMEGA(3)) AUXL(4) = SIN(T(I,2) + XOMEGA(1)) AUXL(5) = SIN(T(I,2) + XOMEGA(2)) AUXL(6) = SIN(T(I,2) + XOMEGA(3)) C C INTERPARTICLE RADII R(I), DIVIDED BY HYPERRADIUS. R1 = SQRT(XKAPPA(1) * (ONE + ARG1A(I) * AUXL(1))) R2 = SQRT(XKAPPA(2) * (ONE + ARG1A(I) * AUXL(2))) R3 = SQRT(XKAPPA(3) * (ONE + ARG1A(I) * AUXL(3))) R(1,I) = R1 R(2,I) = R2 R(3,I) = R3 C C AUXILIARY FUNCTIONS. R1I = ONE / R1 R2I = ONE / R2 R3I = ONE / R3 X1 = (Z1 * R1I) * AUXL(1) X2 = (Z2 * R2I) * AUXL(2) X3 = (Z3 * R3I) * AUXL(3) X4 = - (Z1 * R1I) * ARG1A(I) X5 = - (Z2 * R2I) * ARG1A(I) X6 = - (Z3 * R3I) * ARG1A(I) C C A DERIVATIVES. RA(1,I) = X1 * AUXA RA(2,I) = X2 * AUXA RA(3,I) = X3 * AUXA C C SECOND A DERIVATIVES. RAA(1,I) = - X1 * (ARG1A(I) + AUXA * RA(1,I) * R1I) RAA(2,I) = - X2 * (ARG1A(I) + AUXA * RA(2,I) * R2I) RAA(3,I) = - X3 * (ARG1A(I) + AUXA * RA(3,I) * R3I) C C LAMBDA DERIVATIVES. RL(1,I) = X4 * AUXL(4) RL(2,I) = X5 * AUXL(5) RL(3,I) = X6 * AUXL(6) C C SECOND LAMBDA DERIVATIVES. RLL(1,I) = X4 * (AUXL(1) - AUXL(4) * RL(1,I) * R1I) RLL(2,I) = X5 * (AUXL(2) - AUXL(5) * RL(2,I) * R2I) RLL(3,I) = X6 * (AUXL(3) - AUXL(6) * RL(3,I) * R3I) C C POWERS OF R1, R2, R3. RP(1,I) = R1 ** 2 RP(2,I) = R2 ** 2 RP(3,I) = R3 ** 2 RP(4,I) = R1I RP(5,I) = R2I RP(6,I) = R3I RP(7,I) = R1I ** 2 RP(8,I) = R2I ** 2 RP(9,I) = R3I ** 2 IF (LP) WRITE (NOUT,2122) NAME, I, R1, R2, R3 20 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2122 FORMAT ( A 2H -, A6, 1H-, I4, 3E12.4) END wt3c1a.f000644 000311 000121 00000006124 06067230341 012145 0ustar00krivecf1000000 000000 SUBROUTINE WT3C1A(NDT, NDTX, NDTY, 1 ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 2 TX1, TY1, NT, T, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION TX(NDTX), TY(NDTY), TX1(NDTX), TY1(NDTY), T(NDT,3) C ------------------------------------------------------------------ C TAKES A TWO-DIMENSIONAL GRID OF X, Y POINTS SPECIFIED IN INPUT AND C TRANSFORMS IT INTO A ONE-DIMENSIONAL SET OF (A, LAMBDA, RHO) C VALUES. X AND Y ARE INTERPRETED AS MEMBERS OF THE ORDERED TRIPLE C (A, LAMBDA, RHO). C INPUT: C ICOORX - SEQUENTIAL NUMBER OF THE COORDINATE FROM THE C ORDERED TRIPLE (A, LAMBDA, RHO) ASSIGNED TO X. C NTX - NUMBER OF X POINTS. C TX - ARRAY OF X POINTS. C PAR - VALUE OF THE THIRD COORDINATE SERVING AS C PARAMETER. C EXAMPLE: ICOORX = 1, ICOORY = 3 GIVES: C X = A, Y = RHO, PARAMETER = LAMBDA. C ANGULAR COORDINATES ARE ASSUMED INPUT IN DEGREES. C OUTPUT: C NT - NUMBER OF (X, Y) POINTS (NT = NTX * NTY). C T - (A, LAMBDA, RHO) TRIPLES. C ANGULAR COORDINATES ARE OUTPUT IN RADIANS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3C1A' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 93/01/22. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE, X180 / 1.D0, 180.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ C TESTS. IF (ICOORX .LT. 1 .OR. ICOORX .GT. 3) CALL ERR2(NAME, 1, 1, NOUT) IF (ICOORY .LT. 1 .OR. ICOORY .GT. 3) CALL ERR2(NAME, 2, 1, NOUT) IF (ICOORX .EQ. ICOORY) CALL ERR2(NAME, 3, 1, NOUT) C ------------------------------------------------------------------ ICOORZ = 3 - MOD(ICOORX + ICOORY, 3) C ------------------------------------------------------------------ C DEGREES TO RADIANS. ZZZ = ONE IF (ICOORX .NE. 3) ZZZ = CDXPI() / X180 DO 10 IX = 1,NTX TX1(IX) = TX(IX) * ZZZ 10 CONTINUE ZZZ = ONE IF (ICOORY .NE. 3) ZZZ = CDXPI() / X180 DO 12 IY = 1,NTY TY1(IY) = TY(IY) * ZZZ 12 CONTINUE PAR1 = PAR IF (ICOORZ .NE. 3) PAR1 = PAR * (CDXPI() / X180) C ------------------------------------------------------------------ C TRANSFORM TO (A, LAMBDA, RHO). I = 0 DO 22 IY = 1,NTY DO 20 IX = 1,NTX I = I + 1 T(I,ICOORX) = TX1(IX) T(I,ICOORY) = TY1(IY) T(I,ICOORZ) = PAR1 20 CONTINUE 22 CONTINUE NT = I IF (NT .NE. NTX * NTY) CALL ERR2(NAME, 11, 1, NOUT) C ------------------------------------------------------------------ RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3c2a.f000644 000311 000121 00000020145 06067230342 012146 0ustar00krivecf1000000 000000 SUBROUTINE WT3C2A(NDT, NDTX, NDTY, 1 IPAIR, ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 2 XM, XKAPPA, XOMEGA, 3 TX1, TY1, NT, T, LTRH, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION TX(NDTX), TY(NDTY), XM(3), XKAPPA(3), XOMEGA(3), 1 TX1(NDTX), TY1(NDTY), T(NDT,3) LOGICAL LTRH C ------------------------------------------------------------------ C TAKES A TWO-DIMENSIONAL GRID OF X, Y POINTS SPECIFIED IN INPUT AND C TRANSFORMS IT INTO A ONE-DIMENSIONAL SET OF (A, LAMBDA, RHO) C VALUES. X AND Y ARE INTERPRETED AS MEMBERS OF THE ORDERED TRIPLE C (R(IPAIR), S(IPAIR), PHI(IPAIR)), WHERE R AND S ARE THE LENGTHS OF C THE JACOBI COORDINATES, AND PHI THE ANGLE BETWEEN VECTORS R AND S C IF THE VECTOR R POINTS TO THE RIGHT IN A CYCLICAL PERMUTATION OF C THE TRIPLE (1, 2, 3). IPAIR IS ONLY MEANINGFUL RELATIVE TO THE C ORIGINAL PAIR NUMBER; THIS IS ASSUMED TO BE 3 (THE VALUES OF C (A, LAMBDA, RHO) ARE ASSUMED TO BELONG TO THE PAIR 3). C INPUT: C IPAIR - ODD-MAN-OUT NOTATION TO DEFINE SELECTED R, S. C ICOORX - SEQUENTIAL NUMBER OF THE COORDINATE FROM THE C ORDERED TRIPLE (A, LAMBDA, RHO) ASSIGNED TO X. C NTX - NUMBER OF X POINTS. C TX - ARRAY OF X POINTS. C PAR - VALUE OF THE THIRD COORDINATE SERVING AS C PARAMETER. C XM - MASSES. C XKAPPA - KAPPA. C XOMEGA - OMEGA (OMEGA(3) ASSUMED 0). C EXAMPLE: IPAIR = 2, ICOORX = 1, ICOORY = 3 GIVES: C X = R(2), Y = PHI(2), PARAMETER = S(2); R(2) POINTS C FROM PARTICLE 3 TO PARTICLE 1. C ANGULAR COORDINATES ARE ASSUMED INPUT IN DEGREES. C OUTPUT: C NT - NUMBER OF (X, Y) POINTS (NT = NTX * NTY). C T - (A, LAMBDA, RHO) TRIPLES. C ANGULAR COORDINATES ARE OUTPUT IN RADIANS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3C2A' / CHARACTER*60 VERS DATA VERS */ ' 1.4, 93/01/25. ' / C ............................................................ DIMENSION R(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE, TWO, X180 / 1.D0, 2.D0, 180.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ C TESTS. IF (IPAIR .LT. 1 .OR. IPAIR .GT. 3) CALL ERR2(NAME, 1, 1, NOUT) IF (ICOORX .LT. 1 .OR. ICOORX .GT. 3) CALL ERR2(NAME, 2, 1, NOUT) IF (ICOORY .LT. 1 .OR. ICOORY .GT. 3) CALL ERR2(NAME, 3, 1, NOUT) IF (ICOORX .EQ. ICOORY) CALL ERR2(NAME, 4, 1, NOUT) C ------------------------------------------------------------------ ICOORZ = 3 - MOD(ICOORX + ICOORY, 3) C ------------------------------------------------------------------ C DEGREES TO RADIANS. ZZZ = ONE IF (ICOORX .EQ. 3) ZZZ = CDXPI() / X180 DO 2 IX = 1,NTX TX1(IX) = TX(IX) * ZZZ 2 CONTINUE ZZZ = ONE IF (ICOORY .EQ. 3) ZZZ = CDXPI() / X180 DO 4 IY = 1,NTY TY1(IY) = TY(IY) * ZZZ 4 CONTINUE PAR1 = PAR IF (ICOORZ .EQ. 3) PAR1 = PAR * (CDXPI() / X180) C ------------------------------------------------------------------ C CYCLICAL PAIR NUMBERS: IF R(IPAIA) IS THE BASE OF A TRIANGLE C ORIENTATED ANTICLOCKWISE, PHI(IPAIA) FACES R(IPAIB). IPAIA = IPAIR IPAIB = MOD(IPAIR, 3) + 1 IPAIC = 3 - MOD(IPAIA + IPAIB, 3) XMB = XM(IPAIB) / (XM(IPAIB) + XM(IPAIC)) XMC = XM(IPAIC) / (XM(IPAIC) + XM(IPAIB)) C ------------------------------------------------------------------ C CALCULATE SQUARES OF INTERPARTICLE DISTANCES, THEN TRANSFORM TO C (A, LAMBDA, RHO). IF (ICOORX .EQ. 1 .AND. ICOORY .EQ. 2) THEN I = 0 DO 12 IY = 1,NTY DO 10 IX = 1,NTX I = I + 1 R(IPAIA) = TX1(IX) ** 2 R(IPAIB) = (XMB * TX1(IX)) ** 2 + TY1(IY) ** 2 1 - XMB * TWO * TX1(IX) * TY1(IY) * COS(PAR1) R(IPAIC) = (XMC * TX1(IX)) ** 2 + TY1(IY) ** 2 1 + XMC * TWO * TX1(IX) * TY1(IY) * COS(PAR1) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 10 CONTINUE 12 CONTINUE NT = I ELSE IF (ICOORX .EQ. 1 .AND. ICOORY .EQ. 3) THEN I = 0 DO 22 IY = 1,NTY DO 20 IX = 1,NTX I = I + 1 R(IPAIA) = TX1(IX) ** 2 R(IPAIB) = (XMB * TX1(IX)) ** 2 + PAR1 ** 2 1 - XMB * TWO * TX1(IX) * PAR1 * COS(TY1(IY)) R(IPAIC) = (XMC * TX1(IX)) ** 2 + PAR1 ** 2 1 + XMC * TWO * TX1(IX) * PAR1 * COS(TY1(IY)) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 20 CONTINUE 22 CONTINUE NT = I ELSE IF (ICOORX .EQ. 2 .AND. ICOORY .EQ. 1) THEN I = 0 DO 32 IY = 1,NTY DO 30 IX = 1,NTX I = I + 1 R(IPAIA) = TY1(IY) ** 2 R(IPAIB) = (XMB * TY1(IY)) ** 2 + TX1(IX) ** 2 1 - XMB * TWO * TY1(IY) * TX1(IX) * COS(PAR1) R(IPAIC) = (XMC * TY1(IY)) ** 2 + TX1(IX) ** 2 1 + XMC * TWO * TY1(IY) * TX1(IX) * COS(PAR1) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 30 CONTINUE 32 CONTINUE NT = I ELSE IF (ICOORX .EQ. 2 .AND. ICOORY .EQ. 3) THEN I = 0 DO 42 IY = 1,NTY DO 40 IX = 1,NTX I = I + 1 R(IPAIA) = PAR1 ** 2 R(IPAIB) = (XMB * PAR1) ** 2 + TX1(IX) ** 2 1 - XMB * TWO * PAR1 * TX1(IX) * COS(TY1(IY)) R(IPAIC) = (XMC * PAR1) ** 2 + TX1(IX) ** 2 1 + XMC * TWO * PAR1 * TX1(IX) * COS(TY1(IY)) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 40 CONTINUE 42 CONTINUE NT = I ELSE IF (ICOORX .EQ. 3 .AND. ICOORY .EQ. 1) THEN I = 0 DO 52 IY = 1,NTY DO 50 IX = 1,NTX I = I + 1 R(IPAIA) = TY1(IY) ** 2 R(IPAIB) = (XMB * TY1(IY)) ** 2 + PAR1 ** 2 1 - XMB * TWO * TY1(IY) * PAR1 * COS(TX1(IX)) R(IPAIC) = (XMC * TY1(IY)) ** 2 + PAR1 ** 2 1 + XMC * TWO * TY1(IY) * PAR1 * COS(TX1(IX)) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 50 CONTINUE 52 CONTINUE NT = I ELSE IF (ICOORX .EQ. 3 .AND. ICOORY .EQ. 2) THEN I = 0 DO 62 IY = 1,NTY DO 60 IX = 1,NTX I = I + 1 R(IPAIA) = PAR1 ** 2 R(IPAIB) = (XMB * PAR1) ** 2 + TY1(IY) ** 2 1 - XMB * TWO * PAR1 * TY1(IY) * COS(TX1(IX)) R(IPAIC) = (XMC * PAR1) ** 2 + TY1(IY) ** 2 1 + XMC * TWO * PAR1 * TY1(IY) * COS(TX1(IX)) CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 60 CONTINUE 62 CONTINUE NT = I ENDIF IF (NT .NE. NTX * NTY) CALL ERR2(NAME, 11, 1, NOUT) C ------------------------------------------------------------------ RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3c3a.f000644 000311 000121 00000011163 06067230344 012151 0ustar00krivecf1000000 000000 SUBROUTINE WT3C3A(NDT, NDTX, NDTY, 1 ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 2 XM, XKAPPA, XOMEGA, LAR, AR, 3 TX1, TY1, NT, T, LTRH, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION TX(NDTX), TY(NDTY), XM(3), XKAPPA(3), XOMEGA(3), 1 AR(3), TX1(NDTX), TY1(NDTY), T(NDT,3) LOGICAL LAR, LTRH C ------------------------------------------------------------------ C TAKES A TWO-DIMENSIONAL GRID OF X, Y POINTS SPECIFIED IN INPUT AND C TRANSFORMS IT INTO A ONE-DIMENSIONAL SET OF (A, LAMBDA, RHO) C VALUES. X AND Y ARE INTERPRETED AS MEMBERS OF THE ORDERED TRIPLE C (R(1), R(2), R(3)), WHERE R(K) ARE INTERPARTICLE DISTANCES. C THE ORIGINAL PAIR NUMBER IS ASSUMED TO BE 3 (THE VALUES OF C (A, LAMBDA, RHO) ARE ASSUMED TO BELONG TO THE PAIR 3). C INPUT: C ICOORX - SEQUENTIAL NUMBER OF THE COORDINATE FROM THE C ORDERED TRIPLE (R(1), R(2), R(3)) ASSIGNED TO X. C NTX - NUMBER OF X POINTS. C TX - ARRAY OF X POINTS. C PAR - VALUE OF THE THIRD COORDINATE SERVING AS C PARAMETER. C XM - MASSES. C XKAPPA - KAPPA. C XOMEGA - OMEGA (OMEGA(3) ASSUMED 0). C LAR - MULTIPLIES X, Y, Z BY AR(K); I.E., THE INPUT C VALUES ARE IN UNITS OF AR(K). C AR - SEE LAR; AR(K) ARE ORDERED SO THAT THEY C CORRESPOND TO ORIGINAL PAIR NUMBER. C EXAMPLE: ICOORX = 1, ICOORY = 3 GIVES: C X = R(1), Y = R(3), PARAMETER = R(2). C IF IN ADDITION LAR = .TRUE., WE HAVE INSTEAD C R(1) = X * AR(1), R(3) = Y * AR(3), C R(2) = PAR * AR(2). C OUTPUT: C NT - NUMBER OF (X, Y) POINTS (NT = NTX * NTY). C T - (A, LAMBDA, RHO) TRIPLES. C ANGULAR COORDINATES ARE OUTPUT IN RADIANS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3C3A' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 93/02/03. ' / C ............................................................ DIMENSION R(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ C TESTS. IF (ICOORX .LT. 1 .OR. ICOORX .GT. 3) CALL ERR2(NAME, 2, 1, NOUT) IF (ICOORY .LT. 1 .OR. ICOORY .GT. 3) CALL ERR2(NAME, 3, 1, NOUT) IF (ICOORX .EQ. ICOORY) CALL ERR2(NAME, 4, 1, NOUT) C ------------------------------------------------------------------ ICOORZ = 3 - MOD(ICOORX + ICOORY, 3) C ------------------------------------------------------------------ C COORDINATES MUST BE NONNEGATIVE. DO 10 I = 1,NTX IF (TX(I) .LT. ZERO) CALL ERR2(NAME, 1000000+I, 1, NOUT) 10 CONTINUE DO 12 I = 1,NTY IF (TY(I) .LT. ZERO) CALL ERR2(NAME, 2000000+I, 1, NOUT) 12 CONTINUE IF (PAR .LT. ZERO) CALL ERR2(NAME, 3000000, 1, NOUT) C C SCALE. IF (LAR) THEN DO 14 I = 1,NTX TX1(I) = TX(I) * AR(ICOORX) 14 CONTINUE DO 16 I = 1,NTY TY1(I) = TY(I) * AR(ICOORY) 16 CONTINUE PAR1 = PAR * AR(ICOORZ) ELSE DO 18 I = 1,NTX TX1(I) = TX(I) 18 CONTINUE DO 20 I = 1,NTY TY1(I) = TY(I) 20 CONTINUE PAR1 = PAR ENDIF C C GENERATE GRID AND A SET OF (A, LAMBDA, RHO). I = 0 DO 32 IY = 1,NTY DO 30 IX = 1,NTX I = I + 1 R(ICOORX) = TX1(IX) R(ICOORY) = TY1(IY) R(ICOORZ) = PAR1 C C TEST TRIANGLE INEQUALITY. IF ((R(1) .LT. ABS(R(2) - R(3))) .OR. 1 (R(1) .GT. R(2) + R(3) ) ) 2 CALL ERR2(NAME, 1000*IX+IY, 1, NOUT) C C SQUARES OF R, TRANSFORM TO (A, LAMBDA, RHO). R(1) = R(1) ** 2 R(2) = R(2) ** 2 R(3) = R(3) ** 2 CALL WT3RHA( 1 R, XM, XKAPPA, XOMEGA, T(I,1), T(I,2), T(I,3), 2 LTRH, NOUT) 30 CONTINUE 32 CONTINUE NT = I IF (NT .NE. NTX * NTY) CALL ERR2(NAME, 11, 1, NOUT) C ------------------------------------------------------------------ RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3ca.f000644 000311 000121 00000012206 06067230346 012067 0ustar00krivecf1000000 000000 SUBROUTINE WT3CA(NDT, NDTX, NDTY, ICSET, IPAIR, LCUSP, PAR, 1 XL, XU, XS, NX, IMODEX, ICOORX, 2 YL, YU, YS, NY, IMODEY, ICOORY, 3 XM, XKAPPA, XOMEGA, LAR, AR, TX1, TY1, 4 NTX, TX, NTY, TY, NT, T, LTRH, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XM(3), XKAPPA(3), XOMEGA(3), AR(3), 1 TX1(NDTX), TY1(NDTY), TX(NDTX), TY(NDTY), T(NDT,3) LOGICAL LCUSP, LAR, LTRH C ------------------------------------------------------------------ C GENERATES A TWO-DIMENSIONAL GRID OF POINTS SPECIFIED IN INPUT AND C TRANSFORMS IT INTO A ONE-DIMENSIONAL SET OF (A, LAMBDA, RHO) C VALUES. THESE VALUES ARE RELATIVE TO PAIR 3. C THE FIRST COORDINATE OF THE GRID (ABSCISSA) IS CALLED X, THE C SECOND (ORDINATE) IS CALLED Y. BELOW, THE PARAMETERS CORRESPONDING C TO X ARE EXPLAINED ONLY (Y PARAMETERS ARE ANALOGOUS). C INPUT: C ICSET - SPECIFIES THE PARAMETRIZATION OF COORDINATES. C ICSET MAPS INTO ORDERED COORDINATE TRIPLES AS C FOLLOWS: C 1: (A, LAMBDA, RHO). C 2: (R(IPAIR), S(IPAIR), PHI(IPAIR)) C (JACOBI, PHI = ANGLE(R, S)). C 3: (R(1), R(2), R(3)). INPUT IS IN UNITS OF C AR(K) IF LAR = .TRUE. C -: (RHO, ALPHA, THETA) (PR A46, 142, 1992). C -: (R(IPAIR), BETA, R(IPAIR+1 MOD 3)) C (EG. FOR VICINITY OF CUSPS). C THE MAPPING PERMUTATES X, Y, Z (SEE ICOOR-). C IPAIR - SEE ICSET. NOT USED FOR ALL ICSET VALUES. C LCUSP - IF .TRUE., FOR ICSET = 1, MOVE THE LAMBDA VALUES C CLOSEST TO THE CUSPS TO THE CUSP POSITION. THIS C WILL MAKE THE GRID SLIGHTLY UNEVEN. C PAR - VALUE OF THE THIRD COORDINATE SERVING AS C PARAMETER. C XL - SMALLEST VALUE OF FIRST COORDINATE. C XU - LARGEST VALUE OF FIRST COORDINATE. C XS - STEP OF FIRST COORDINATE. C NX - NUMBER OF POINTS IN FIRST COORDINATE. C IMODEX - 1: USE XS, IGNORE NX. C 2: USE NX, IGNORE XS. C ICOORX - SEQUENTIAL NUMBER OF THE COORDINATE FROM THE C ORDERED TRIPLE SPECIFIED BY ICSET ASSIGNED TO X. C EXAMPLE: ICSET = 2, IPAIR = 3, ICOORX = 1, ICOORY = 3 C GIVES: C X = R(3), Y = PHI(3), PARAMETER = S(3). C ANGULAR COORDINATES ARE ASSUMED INPUT IN DEGREES. C OUTPUT: C NTX - NUMBER OF X POINTS. C TX - ARRAY OF X POINTS. C NT - NUMBER OF (X, Y) POINTS (NT = NTX * NTY). C T - (A, LAMBDA, RHO) TRIPLES. C ANGULAR COORDINATES ARE OUTPUT IN RADIANS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3CA ' / CHARACTER*60 VERS DATA VERS */ ' 3.0, 93/01/29. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, X180 / 180.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ C TESTS. IF (ICSET .LT. 1 .OR. ICSET .GT. 4) CALL ERR2(NAME, 1, 1, NOUT) C ------------------------------------------------------------------ C GENERATE X, Y. CALL WT3CGA( 1 NDTX, XL, XU, XS, NX, IMODEX, NTX, TX, NOUT) CALL WT3CGA( 1 NDTY, YL, YU, YS, NY, IMODEY, NTY, TY, NOUT) C ------------------------------------------------------------------ ICOORZ = 3 - MOD(ICOORX + ICOORY, 3) GO TO (100, 200, 300, 400), ICSET 100 CONTINUE IF (LCUSP) THEN C MOVE NEAREST LAMBDA POINTS TO THE CUSPS (DEGREES). IF (ICOORX .EQ. 2) THEN CALL WT3CMA(NDTX, XOMEGA, NTX, TX, NOUT) ELSE IF (ICOORY .EQ. 2) THEN CALL WT3CMA(NDTY, XOMEGA, NTY, TY, NOUT) ELSE IF (ICOORZ .EQ. 2) THEN NZZ = 1 CALL WT3CMA(NZZ, XOMEGA, NZZ, PAR, NOUT) ENDIF ENDIF CALL WT3C1A( 1 NDT, NDTX, NDTY, 2 ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 3 TX1, TY1, NT, T, NOUT) RETURN 200 CONTINUE CALL WT3C2A( 1 NDT, NDTX, NDTY, 2 IPAIR, ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 3 XM, XKAPPA, XOMEGA, 4 TX1, TY1, NT, T, LTRH, NOUT) RETURN 300 CONTINUE CALL WT3C3A( 1 NDT, NDTX, NDTY, 2 ICOORX, ICOORY, NTX, TX, NTY, TY, PAR, 3 XM, XKAPPA, XOMEGA, LAR, AR, 4 TX1, TY1, NT, T, LTRH, NOUT) RETURN 400 CONTINUE CALL ERR2(NAME, 1400, 1, NOUT) RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3cga.f000644 000311 000121 00000005246 06067230347 012245 0ustar00krivecf1000000 000000 SUBROUTINE WT3CGA(NDTX, XL, XU, XS, NX, IMODEX, 1 NTX, TX, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION TX(NDTX) C ------------------------------------------------------------------ C GENERATES A SET OF X VALUES (INCREASING OR DECREASING). C TO OBTAIN A SINGLE VALUE, USE ABS(XU - XL) .LT. ABS(XS) WITH C IMODEX = 1 OR NX = 1 WITH IMODEX = 2. TO HAVE LAST VALUE EQUAL XU C EXACTLY, USE IMODEX = 2. C INPUT: C XL - SMALLEST VALUE OF X. C XU - LARGEST VALUE OF X. C XS - STEP OF X. C NX - NUMBER OF POINTS IN X. C IMODEX - 1: USE XS, IGNORE NX. C 2: USE NX, IGNORE XS. C OUTPUT: C NTX - NUMBER OF GENERATED X POINTS. C TX - ARRAY OF X POINTS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3CGA' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 93/02/03. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ IF (IMODEX .LT. 1 .OR. IMODEX .GT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF (XS .GT. ZERO .AND. XL .GE. XU) CALL ERR2(NAME, 2, 1, NOUT) IF (XS .LT. ZERO .AND. XL .LE. XU) CALL ERR2(NAME, 3, 1, NOUT) C ------------------------------------------------------------------ IF (IMODEX .EQ. 1) THEN IF (XS .EQ. ZERO) CALL ERR2(NAME, 11, 1, NOUT) I = 0 X = XL - XS 10 CONTINUE I = I + 1 IF (I .GT. NDTX) CALL ERR2(NAME, 12, 1, NOUT) X = X + XS C DO NOT CROSS XU. IF ((XS .GT. ZERO .AND. X .GT. XU) .OR. 1 (XS .LT. ZERO .AND. X .LT. XU) ) GO TO 12 TX(I) = X GO TO 10 12 CONTINUE C IGNORE LAST POINT. NTX = I - 1 IF (NTX .EQ. 0) CALL ERR2(NAME, 13, 1, NOUT) ELSE IF (NX .LE. 0) CALL ERR2(NAME, 21, 1, NOUT) IF (NX .GT. NDTX) CALL ERR2(NAME, 22, 1, NOUT) TX(1) = XL IF (NX .GT. 1) THEN XS0 = (XU - XL) / (NX - 1) DO 14 J = 2,NX TX(J) = XL + (J - 1) * XS0 14 CONTINUE C FIX LAST VALUE. TX(NX) = XU ENDIF NTX = NX ENDIF RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3cma.f000644 000311 000121 00000004163 06067230351 012243 0ustar00krivecf1000000 000000 SUBROUTINE WT3CMA(NDTX, XOMEGA, NTX, TX, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XOMEGA(3), TX(NDTX) C ------------------------------------------------------------------ C MOVES THE POINTS NEAREST TO THE CUSP POSITIONS TO THE PRECISE C CUSP POSITIONS, CHANGING THE COORDINATE LAMBDA. THIS DISTORTS C THE GRID BUT EMPHASIZES CUSPS. C INPUT: C XOMEGA - OMEGA. C NTX - NUMBER OF LAMBDA POINTS. C TX - ARRAY OF LAMBDA POINTS. C LAMBDA COORDINATE IS ASSUMED INPUT IN DEGREES. C OUTPUT: C TX - *** CHANGED *** ARRAY OF LAMBDA POINTS. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3CMA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 93/01/28. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, X180 / 180.D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ------------------------------------------------------------------ C TESTS. IF (NTX .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NTX .GT. NDTX) CALL ERR2(NAME, 2, 1, NOUT) C ------------------------------------------------------------------ DO 20 K = 1,3 C C CUSP POSITION (DEGREES). X = (CDXPI() - XOMEGA(K)) * (X180 / CDXPI()) C C FIND IF INSIDE INTERVAL. IF (((TX(1) .LE. TX(NTX)) .AND. 1 (X .GE. TX(1)) .AND. (X .LE. TX(NTX))) .OR. 2 ((TX(1) .GT. TX(NTX)) .AND. 3 (X .LE. TX(1)) .AND. (X .GE. TX(NTX))) ) THEN D = 361 J = 0 DO 10 I = 1,NTX IF (ABS(TX(I) - X) .LT. D) THEN D = ABS(TX(I) - X) J = I ENDIF 10 CONTINUE IF (J .EQ. 0) CALL ERR2(NAME, 1000*K+1, 1, NOUT) TX(J) = X ENDIF 20 CONTINUE RETURN 2000 FORMAT (2H -, A6, 1H-, A60) END wt3d1a.f000644 000311 000121 00000003146 06067230352 012151 0ustar00krivecf1000000 000000 SUBROUTINE WT3D1A(NDTX, NDTY, NDT, 1 NTX, TX, NTY, TY, F, D, NOUT) C IMPLICIT REAL*8 (A-H, O-Z) DIMENSION TX(NDTX), TY(NDTY), F(NDT), D(NDTX) C C CALCULATES LOGARITHMIC DERIVATIVE OF F WITH RESPECT TO C COORDINATE X (I.E., THE FIRST RUNNING IN F). C SIMPLE FIRST DIVIDED DIFFERENCE IS USED. C CHARACTER*6 NAME DATA NAME / 'WT3D1A' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 93/02/11. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C TEST DIMENSIONS. IF (NTX .GT. NDTX) CALL ERR2(NAME, 1, 1, NOUT) IF (NTY .GT. NDTY) CALL ERR2(NAME, 2, 1, NOUT) C IF (NTX .LE. 1) CALL ERR2(NAME, 10, 1, NOUT) NTX1 = NTX - 1 WRITE (NOUT,3000) (TX(IX), IX = 1,NTX1) WRITE (NOUT,3002) I = 0 DO 14 IY = 1,NTY DO 12 IX = 1,NTX I = I + 1 IF (IX .LT. NTX) THEN D(IX) = (F(I+1) - F(I)) / ((TX(IX+1) - TX(IX)) * F(I)) ENDIF 12 CONTINUE WRITE (NOUT,3100) TY(IY), (D(IX), IX = 1,NTX1) 14 CONTINUE C RETURN C 2000 FORMAT (2H -, A6, A60) 3000 FORMAT (//, 1 1H , 32HLOGARITHMIC DERIVATIVES , /, 2 1H , 12H X , 5F12.6, /, (1H , 12X, 5F12.6)) 3002 FORMAT ( 1 1H , 12H Y ) 3100 FORMAT ( 1 1H , 6F12.6, /, (1H , 12X, 5F12.6)) END wt3rha.f000644 000311 000121 00000012523 06067230354 012257 0ustar00krivecf1000000 000000 SUBROUTINE WT3RHA(R2, XM, XKAPPA, XOMEGA, A, XLAM, RHO, 1 LTEST, NOUT) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LTEST DIMENSION R2(3), XM(3), XKAPPA(3), XOMEGA(3) C ------------------------------------------------------------------ C TRANSFORMS R(1), R(2), R(3) (INTERPARTICLE DISTANCES IN ODD-MAN- C OUT NOTATION) TO (A, LAMBDA, RHO), WHERE THE LATTER ARE ASSUMED C DEFINED WITH RESPECT TO THE PAIR 3 (MEANING OMEGA(3) = 0). C INPUT: C R2 - SQUARES OF R(K). C XM - MASSES. C XKAPPA - KAPPA; KAPPA(K) = 1/2M(I,J). C XOMEGA - OMEGA; KAPPA(1) (1 - COS(OMEGA(1)) = 1/M(3;1,2). C LTEST - CALCULATE BACK R2 FROM A, LAMBDA, RHO AND PRINT. C OUTPUT: C A - A. C XLAM - LAMBDA. C RHO - RHO. C NB.: IF SIN(A) = 0, LAMBDA IS NOT UNIQUE. THIS CASE IS IMPLIED BY C R(K)**2 = RHO**2 KAPPA(K), FOR ALL K. THERE ARE OTHER SPECIAL C CASES. NOT ALL OF THEM MAY BE TREATED IN THIS ROUTINE. TRIANGULAR C TEST IS NOT DONE. C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'WT3RHA' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 93/01/28. ' / C ............................................................ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TWO, HALF, X15, X180, XMTOL 2 / 0.D0, 1.D0, 2.D0, 0.5D0, 1.5D0, 180.D0, 1.D-4 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (XOMEGA(3) .NE. ZERO) CALL ERR2(NAME, 1, 1, NOUT) C ------------------------------------------------------------------ C RHO. ASSUME AT MOST ONE VERY LARGE MASS CAN APPEAR. DO 10 I = 1,3 IF (XM(I) .GT. XMTOL * CDXMAX()) THEN I1 = MOD(I, 3) + 1 I2 = MOD(I1, 3) + 1 RHO2 = XM(I1) * R2(I1) + XM(I2) * R2(I2) GO TO 12 ENDIF 10 CONTINUE ZZZ = ONE / (XM(1) + XM(2) + XM(3)) RHO2 = ZZZ * (XM(1) * XM(2) * R2(3) + 1 XM(2) * XM(3) * R2(1) + 2 XM(3) * XM(1) * R2(2) ) 12 CONTINUE RHO = SQRT(RHO2) C A SIMPLE TEST. IF (RHO .LT. CDXTOL()) THEN A = ZERO XLAM = ZERO IF (LTEST) WRITE (NOUT,3200) NAME GO TO 20 ENDIF C ------------------------------------------------------------------ C A, LAMBDA. DETERMINE TAN(LAMBDA) BY DIVIDING EXPRESSIONS FOR C R(3)**2 AND R(1)**2. AUXILIARY EXPRESSIONS. ZZZ1 = R2(1) / (RHO2 * XKAPPA(1)) - ONE ZZZ2 = R2(2) / (RHO2 * XKAPPA(2)) - ONE ZZZ3 = R2(3) / (RHO2 * XKAPPA(3)) - ONE ZZZS = ONE / SIN(XOMEGA(1)) IF (LTEST) WRITE (NOUT,3300) NAME, ZZZ1, ZZZ2, ZZZ3, ZZZS C C TEST FOR SIN(A) = 0. IT SUFFICES TO TEST TWO PAIRS EXCEPT C IF SOME MASS IS VERY LARGE; THEN THE EXPRESSION FOR RHO IS C DEGENERATE. THEREFORE ALL THREE CONDITIONS ARE TESTED. C LAMBDA IS NOT UNIQUE AND IS SET ARBITRARILY TO 0. IF ((ABS(ZZZ1) .LT. CDXTOL()) .AND. 1 (ABS(ZZZ2) .LT. CDXTOL()) .AND. 2 (ABS(ZZZ3) .LT. CDXTOL()) ) THEN A = ZERO XLAM = ZERO IF (.NOT. LTEST) RETURN WRITE (NOUT,3202) NAME GO TO 20 ENDIF C C TEST FOR COS(LAMBDA) = 0 (WITH SIN(A) =/= 0). IF (ABS(ZZZ3) .LT. CDXTOL()) THEN ZZZ = - ZZZ1 * ZZZS IF (ABS(ZZZ) .GT. ONE) WRITE (NOUT,3214) NAME, ZZZ A = ASIN(MIN(ONE, ABS(ZZZ))) XLAM = HALF * (TWO - SIGN(ONE, ZZZ)) * CDXPI() IF (.NOT. LTEST) RETURN WRITE (NOUT,3204) NAME GO TO 20 ENDIF C C NONDEGENERATE CASE. CALCULATE TAN(LAMBDA); FIND SIGN OF C COS(LAMBDA) (= SIGN OF ZZZ3); ATAN() ASSUMED TO RETURN VALUE ON C (-PI/2, PI/2). XLAM = ATAN((COS(XOMEGA(1)) - ZZZ1 / ZZZ3) * ZZZS) IF (ZZZ3 .LT. ZERO) THEN XLAM = XLAM + CDXPI() ELSE IF (XLAM .LT. ZERO) THEN XLAM = XLAM + TWO * CDXPI() ENDIF IF (ABS(ZZZ3 / COS(XLAM)) .GT. ONE) THEN WRITE (NOUT,3216) NAME, (ZZZ3 / COS(XLAM)) A = ASIN(SIGN(ONE, (ZZZ3 / COS(XLAM)))) ELSE A = ASIN(ZZZ3 / COS(XLAM)) ENDIF IF (.NOT. LTEST) RETURN WRITE (NOUT,3206) NAME C ------------------------------------------------------------------ 20 CONTINUE IF (LTEST) THEN C RECALCULATE R2. R21 = RHO2 * XKAPPA(1) * (ONE + SIN(A) * COS(XLAM+XOMEGA(1))) R22 = RHO2 * XKAPPA(2) * (ONE + SIN(A) * COS(XLAM+XOMEGA(2))) R23 = RHO2 * XKAPPA(3) * (ONE + SIN(A) * COS(XLAM+XOMEGA(3))) A1 = (X180 / CDXPI()) * A XL1 = (X180 / CDXPI()) * XLAM WRITE (NOUT,3000) NAME, R2, A1, XL1, RHO, R21, R22, R23 ENDIF RETURN 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-, 3E20.12, /, 1 1H , 8X, 3F20.4, /, 1H , 8X, 3E20.12) 3200 FORMAT (2H -, A6, 1H-, 8H EXIT 1) 3202 FORMAT (2H -, A6, 1H-, 8H EXIT 2) 3204 FORMAT (2H -, A6, 1H-, 8H EXIT 3) 3214 FORMAT (2H -, A6, 1H-, 8H EXIT 3, E24.16) 3206 FORMAT (2H -, A6, 1H-, 8H EXIT 4) 3216 FORMAT (2H -, A6, 1H-, 8H EXIT 4, E24.16) 3300 FORMAT (2H -, A6, 1H-, 3E20.12, /, 1H , 8X, E20.12) END wt3ta.f000644 000311 000121 00000012432 06067230355 012111 0ustar00krivecf1000000 000000 SUBROUTINE WT3TA(ISEL, E, HC0, HC1, RHOP, AUXA1, ARG1A, 1 TWF, TWFD, TWFA, TWFL, TWFZ, TWFZZ, 2 TCF, TCFR, TCFRR, TCFA, TCFAA, TCFL, TCFLL, 3 TVF, R, 4 F, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION RHOP(4), R(3) C C CALCULATES VALUE OF REQUIRED TABULATION FUNCTION AT A SINGLE C (A, LAMBDA, RHO) POINT. C E - MINUS ENERGY (VALUE FROM ITERATION PROGRAM; IT IS C POSITIVE). C AUXA1 - 2 COT(2 A); C ARG1A - SIN(A). C NB: TCFL, TCFLL ALREADY CONTAIN 1/SIN(A)**2. C R - R(I) / RHO. C LOGICAL LCALL0 CHARACTER*6 NAME DATA NAME / 'WT3TA ' / CHARACTER*60 VERS DATA VERS */ '4.2, 95/05/16 (A5QZA 1.0) ' / C ............................................................ DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TWO, HALF / 0.D+0, 1.D+0, 2.D+0, 0.5D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C TWFR = HC0 * TWFZ TWFRR = HC1 * TWFZZ RHO2I4 = 4 * RHOP(3) C ------------------------------------------------------------------ IF (ISEL .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (ISEL .GT. 31) CALL ERR2(NAME, 2, 1, NOUT) F = ZERO GO TO (1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, A 15, 16, 17, 18, 19, 20, 21, 21, 23, 24, 25, B 26, 27, 28, 29, 30, 31), ISEL 1 CONTINUE F = TCF RETURN 2 CONTINUE F = EXP(TCF) RETURN 3 CONTINUE F = EXP(TCF) * RHOP(3) RETURN 4 CONTINUE CALL ERR2(NAME, 104, 1, NOUT) RETURN 5 CONTINUE F = TWF RETURN 6 CONTINUE F = TWF * RHOP(3) RETURN 7 CONTINUE CALL ERR2(NAME, 107, 1, NOUT) RETURN 8 CONTINUE CALL ERR2(NAME, 108, 1, NOUT) RETURN 9 CONTINUE F = EXP(TCF) * TWF RETURN 10 CONTINUE F = EXP(TCF) * TWF * RHOP(3) RETURN 11 CONTINUE CALL ERR2(NAME, 111, 1, NOUT) RETURN 12 CONTINUE CALL ERR2(NAME, 112, 1, NOUT) RETURN 13 CONTINUE F = TVF RETURN 14 CONTINUE F = TVF * EXP(TCF) * TWF * RHOP(3) RETURN 15 CONTINUE C -1/2 D**2/D(RHO)**2. F = EXP(TCF) * RHOP(3) * (- HALF * TWFRR) RETURN 16 CONTINUE C -1/(2 RHO) D/D(RHO). F = EXP(TCF) * RHOP(3) * (- HALF * RHOP(2) * TWFR) RETURN 17 CONTINUE C 1/(2 RHO**2) (4 - DELTA(*)). F = EXP(TCF) * RHOP(3) * (+ HALF * RHOP(3) * TWFD) RETURN 18 CONTINUE C -1/2 DELTA(F) + (2/RHO) D(F)/D(RHO). F = EXP(TCF) * RHOP(3) * (- HALF * TWF) * 1 (TCFRR + TCFR * RHOP(2) + 2 RHO2I4 * (TCFAA + AUXA1 * TCFA + TCFLL)) RETURN 19 CONTINUE C -1/2 GRAD(F)**2. F = EXP(TCF) * RHOP(3) * (- HALF * TWF) * 1 (TCFR ** 2 + 2 RHO2I4 * (TCFA ** 2 + 3 (ARG1A * TCFL) ** 2)) RETURN 20 CONTINUE C - (GRAD(F), GRAD). F = - EXP(TCF) * RHOP(3) * 1 (TCFR * TWFR + 2 RHO2I4 * (TCFA * TWFA + 3 TCFL * TWFL )) RETURN 21 CONTINUE F = HALF * 1 (TWO * TVF * TWF 2 - TWFRR 3 - RHOP(2) * TWFR 4 + RHOP(3) * TWFD 5 - TWF * 6 (TCFRR + TCFR * RHOP(2) + 7 RHO2I4 * (TCFAA + AUXA1 * TCFA + TCFLL)) 8 - TWF * 9 (TCFR ** 2 + A RHO2I4 * (TCFA ** 2 + B (ARG1A * TCFL) ** 2)) C - TWO * (TCFR * TWFR + D RHO2I4 * (TCFA * TWFA + E TCFL * TWFL )) ) IF (ISEL .EQ. 22) GO TO 22 F = EXP(TCF) * RHOP(3) * F RETURN 22 CONTINUE IF (ABS(TWF) .LT. CDXTOL()) THEN F = ZERO ELSE C DELTA IN PERCENT. F = (F / (- E * TWF) - ONE) * 100 ENDIF RETURN C C THE FOLLOWING ARE TEST QUANTITIES. 23 CONTINUE C TEST (DISCONTINUITY). F = TCFL RETURN 24 CONTINUE C TEST (DISCONTINUITY). F = TCFL ** 2 RETURN 25 CONTINUE C TEST (CONTINUITY). F = TCFLL RETURN 26 CONTINUE C TEST (R). F = R(1) RETURN 27 CONTINUE C TEST (R). F = R(2) RETURN 28 CONTINUE C TEST (R). F = R(3) RETURN 29 CONTINUE C LOG10(ABS(EXP(TCF))). F = LOG10(MAX(ABS(EXP(TCF)), CDXTOL())) RETURN 30 CONTINUE C LOG10(ABS(PHI * RHO**2)). F = LOG10(MAX(ABS(TWF), CDXTOL())) RETURN 31 CONTINUE C LOG10(ABS(PSI * RHO**2)). F = LOG10(MAX(ABS(EXP(TCF) * TWF), CDXTOL())) RETURN C ------------------------------------------------------------------ 2000 FORMAT (2H -, A6, 1H-, A60) END av2yld.f000644 000311 000121 00000007442 06067230100 012241 0ustar00krivecf1000000 000000 SUBROUTINE AV2YLD(NDS, NDL, NDMU, NOUT, LP, 1 NS, ISMN, NLX, ARG, WK1, WK2, YL, YLL) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION ISMN(2,NDS), NLX(2), ARG(NDL,2), 1 WK1(NDL,NDMU,2), WK2(NDL,NDMU,2), 2 YL(NDS,NDL,2), YLL(NDS,NDL,2) LOGICAL LP C C C LAMBDA-DEPENDENT PARTS OF THE REAL HH, AND THEIR DERIVATIVES, FOR C ALL STATES, ALL ARGUMENTS. FOR NONNEGATIVE NU, C YL(MU,NU,LAMBDA) = COS(LAMBDA NU), C YL(MU,-NU,A,LAMBDA) = SIN(LAMBDA NU).. C INPUT: C ISMN - MU, NU PAIRS. NOTE THAT ISMN MAY HAVE BEEN ADJUSTED C BY M2WRDA (COULDR). THEREFORE ONLY ISMN IS RELIED ON, C AND NOT ISIS OR ISN WHICH ARE NOT CHANGED BY M2WRDA. C ARG - VALUES OF LAMBDA, FOR THE TWO A REGIONS. C C CHARACTER*6 NAME DATA NAME / 'AV2YLD' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 94/05/23 (-B 1.1) NLX = 0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (NLX(1) .LT. 1) CALL ERR2(NAME, 3, 0, NOUT) IF (NLX(1) .GT. NDL) CALL ERR2(NAME, 4, 1, NOUT) IF (NLX(2) .LT. 1) CALL ERR2(NAME, 5, 0, NOUT) IF (NLX(2) .GT. NDL) CALL ERR2(NAME, 6, 1, NOUT) C C FIND MAX. MU, NU BY DIRECT SEARCH (TO MAKE IT INDEPENDENT OF THE C STATE SEQUENCE). NUU = 0 DO 10 I = 1,NS IF (ABS(ISMN(2,I)) .GT. NUU) NUU = ISMN(2,I) 10 CONTINUE IF (NUU + 1 .GT. NDMU) CALL ERR2(NAME, 5, 1, NOUT) C C RESET YL, YLL. DO 24 J = 1,2 NL = NLX(J) IF (NL .EQ. 0) GO TO 24 DO 22 I = 1,NL DO 20 IY = 1,NS YL(IY,I,J) = ZERO YLL(IY,I,J) = ZERO 20 CONTINUE 22 CONTINUE 24 CONTINUE C C LOOP OVER ALL CONTIGUOUS NONNEGATIVE NU. NU1U = NUU + 1 DO 34 J = 1,2 NL = NLX(J) IF (NL .EQ. 0) GO TO 34 DO 32 NU1 = 1,NU1U DO 30 I = 1,NL WK1(I,NU1,J) = COS((NU1 - 1) * ARG(I,J)) WK2(I,NU1,J) = SIN((NU1 - 1) * ARG(I,J)) 30 CONTINUE 32 CONTINUE 34 CONTINUE C C LOOP OVER STATES. DO 48 IY = 1,NS NU = ISMN(2,IY) IF (NU .GE. 0) THEN DO 42 J = 1,2 NL = NLX(J) IF (NL .EQ. 0) GO TO 42 DO 40 I = 1,NL YL(IY,I,J) = WK1(I,NU+1,J) YLL(IY,I,J) = - NU * WK2(I,NU+1,J) 40 CONTINUE 42 CONTINUE ELSE DO 46 J = 1,2 NL = NLX(J) IF (NL .EQ. 0) GO TO 46 DO 44 I = 1,NL YL(IY,I,J) = WK2(I,-NU+1,J) YLL(IY,I,J) = (-NU) * WK1(I,-NU+1,J) 44 CONTINUE 46 CONTINUE ENDIF 48 CONTINUE IF (.NOT. LP) RETURN C C TEST OUTPUT. WRITE (NOUT,2100) NAME DO 52 J = 1,2 NL = NLX(J) IF (NL .EQ. 0) GO TO 52 DO 50 I = 1,NL WRITE (NOUT,2102) 1 I, J, ARG(I,J), 2 (IY, ISMN(1,IY), ISMN(2,IY), YL(IY,I,J), YLL(IY,I,J), 3 IY = 1,NS) 50 CONTINUE 52 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT (/, A 2H -, A6, 1H-, 8HYL, YLL ) 2102 FORMAT ( A 1H , 2I4, F12.6, /, B (1H , I4, 4X, 2I4, 2F12.6)) END av3rtb.f000644 000311 000121 00000005350 06067230112 012240 0ustar00krivecf1000000 000000 SUBROUTINE AV3RTB(NDPA, NDPL, NOUT, 1 NGOA, NSUBA, XMASS, NPA, NPLX, RP, 2 RMA, RML, RMU) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION NGOA(2), NSUBA(2), XMASS(3), NPLX(2), 1 RP(9,NDPL,NDPA) C C C TEST THE RHO-INDEPENDENT RELATION C SUM M(I) M(J) R(K)**2 / RHO = M(1) + M(2) + M(3). C INDIRECTLY TESTS NPA (OTHERWISE UNUSED). C ALLOWS NGO- = 0. C C CHARACTER*6 NAME DATA NAME / 'AV3RTB' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 94/05/23 (- 1.1C) NGO- = 0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE / 0.D0, 1.0D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ICNT = 0 RMA = ZERO RML = CDXMAX() RMU = ZERO IAX = 0 DO 16 IRA = 1,2 NSA = NSUBA(IRA) NA = NGOA(IRA) NLX = NPLX(IRA) IF (NA .EQ. 0) GO TO 16 DO 14 ISA = 1,NSA DO 12 IA = 1,NA IAX = IAX + 1 DO 10 ILX = 1,NLX ICNT = ICNT + 1 RM = (XMASS(2) * XMASS(3) * RP(1,ILX,IAX) + 1 XMASS(3) * XMASS(1) * RP(2,ILX,IAX) + 2 XMASS(1) * XMASS(2) * RP(3,ILX,IAX) ) / 3 (XMASS(1) + XMASS(2) + XMASS(3)) - ONE RMA = RMA + ABS(RM) IF (ABS(RM) .GT. RMU) THEN RMU = ABS(RM) IAXU = IAX ILXU = ILX ENDIF IF (ABS(RM) .LT. RML) THEN RML = ABS(RM) IAXL = IAX ILXL = ILX ENDIF 10 CONTINUE 12 CONTINUE 14 CONTINUE 16 CONTINUE IF (ICNT .NE. 1 (NGOA(1) * NSUBA(1) * NPLX(1) + NGOA(2) * NSUBA(2) * NPLX(2))) 2 CALL ERR2(NAME, 1, 1, NOUT) RMA = RMA / (NPA * (NPLX(1) + NPLX(2))) WRITE (NOUT,3000) NAME, RMA, RML, IAXL, ILXL, RMU, IAXU, ILXU WRITE (NOUT,3100) NAME, XMASS RETURN C 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-, 36HSUM M(I) M(J) R(K)**2 / M - 1 TEST: , /, 1 1H , 52H VALUE A, LAMBDA INDICES, /, 2 1H , 16HAVERAGE , E12.1, /, 3 1H , 16HMINIMAL , E12.1, 8X, 2I8, /, 4 1H , 16HMAXIMAL , E12.1, 8X, 2I8) 3100 FORMAT (2H -, A6, 1H-, 12HMASSES: , /, 1 1H , 3E24.16) END m2arqb.f000644 000311 000121 00000003325 06067230222 012225 0ustar00krivecf1000000 000000 SUBROUTINE M2ARQB(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 DAS, NGOA, NSUBA, 2 P, Z, AG, WG, PTEST, PTESTG, NOUT, 3 X, W) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL PTEST, PTESTG DIMENSION NGOA(2), NSUBA(2), X(NDGO,NDSI,2), W(NDGO,NDSI,2) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C INTEGRATION POINTS IN VARIABLE A. C INTERVAL IS (0, PI/2), SINGULARITIES ARE AT A = PI/2. C IF NGOA(I) = 0, LEAVES X(.,.,I), W(.,.,I) UNDEFINED. C C CHARACTER*6 NAME DATA NAME / 'M2ARQB' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 94/05/23 (-A 1.0). NGOA=0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DIMENSION XAB(3) DATA LCALL0 / .TRUE. /, 1 ZERO, HALF, ONE4 / 0.D0, 0.5D0, 0.25D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C TESTS. IF (DAS .LT. ZERO) CALL ERR2(NAME, 1, 1, NOUT) IF (DAS .GT. ONE4 * CDXPI()) CALL ERR2(NAME, 2, 1, NOUT) C C BOUNDARIES. XAB(1) = ZERO XAB(2) = HALF * CDXPI() - DAS XAB(3) = HALF * CDXPI() C C GENERATE QUADRATURE POINTS. SKIP IF NGOA = 0. DO 20 I = 1,2 IF (NGOA(I) .EQ. 0) GO TO 20 CALL M2XGQA(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 NGOA(I), NSUBA(I), XAB(I), XAB(I+1), 2 P, Z, AG, WG, PTESTG, NOUT, 3 X(1,1,I), W(1,1,I)) 20 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m2lrqb.f000644 000311 000121 00000006347 06067230224 012251 0ustar00krivecf1000000 000000 SUBROUTINE M2LRQB(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 XOMEGA, DLS, NGOL, NSUBL, 2 P, Z, AG, WG, PTEST, PTESTG, NOUT, 3 S, X, W) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL PTEST, PTESTG DIMENSION XOMEGA(3), NGOL(10,2), NSUBL(10,2), 1 S(3), X(NDGO,NDSI,20), W(NDGO,NDSI,20) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C INTEGRATION POINTS IN VARIABLE LAMBDA. C INTERVAL IS (0, 2PI), SINGULARITIES ARE: C R(K) = 0: LAMBDA = PI - XOMEGA(K), K = 1, 2, 3. C THEY ARE RETURNED IN S. C IF NGOL(.,.) = 0, SKIPS THE CORRESPONDING LOOPS, AND LEAVES C THE CORRESPONDING PARTS OF X AND W UNDEFINED. C C CHARACTER*6 NAME DATA NAME / 'M2LRQB' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 94/05/23 (-A 1.3) NGOL = 0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DIMENSION XLB(11) DATA LCALL0 / .TRUE. /, 1 ZERO, TWO, THREE / 0.D0, 2.D0, 3.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C TEST SIGNS. IF (XOMEGA(2) .LT. CDXTOL()) CALL ERR2(NAME, 1, 1, NOUT) IF (XOMEGA(1) .GT. -CDXTOL()) CALL ERR2(NAME, 2, 1, NOUT) IF (DLS .LT. ZERO) CALL ERR2(NAME, 3, 1, NOUT) C C SINGULAR POINTS (ORDERED). XLL = ZERO XLU = TWO * CDXPI() S(1) = CDXPI() - XOMEGA(2) S(2) = CDXPI() - XOMEGA(3) S(3) = CDXPI() - XOMEGA(1) IF (S(1) .LT. TWO * DLS) CALL ERR2(NAME, 4, 1, NOUT) IF (S(2)-S(1) .LT. THREE * DLS) CALL ERR2(NAME, 5, 1, NOUT) IF (S(3)-S(2) .LT. THREE * DLS) CALL ERR2(NAME, 6, 1, NOUT) IF (XLU -S(3) .LT. TWO * DLS) CALL ERR2(NAME, 7, 1, NOUT) C C BOUNDARIES. XLB(1) = XLL XLB(2) = S(1) - DLS XLB(3) = S(1) XLB(4) = S(1) + DLS XLB(5) = S(2) - DLS XLB(6) = S(2) XLB(7) = S(2) + DLS XLB(8) = S(3) - DLS XLB(9) = S(3) XLB(10) = S(3) + DLS XLB(11) = XLU IF (PTEST) WRITE (NOUT,2500) NAME, DLS IF (PTEST) WRITE (NOUT,2300) NAME, S IF (PTEST) WRITE (NOUT,2400) NAME, XLB C C GENERATE QUADRATURE POINTS. DO 40 K = 1,2 C C INTERVAL. DO 20 I = 1,10 IF (PTEST) WRITE (NOUT,2200) NAME, 1 K, I, XLB(I), XLB(I+1), NGOL(I,K), NSUBL(I,K) IF (NGOL(I,K) .EQ. 0) GO TO 20 CALL M2XGQA(NDSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 NGOL(I,K), NSUBL(I,K), XLB(I), XLB(I+1), 2 P, Z, AG, WG, PTESTG, NOUT, 3 X(1,1,I+(K-1)*10), W(1,1,I+(K-1)*10)) 20 CONTINUE 40 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2200 FORMAT (2H -, A6, 1H-, A 1H , 20HK, I, A, B, N, NSI , 2I4, 2F16.8, 2I4) 2300 FORMAT (2H -, A6, 1H-, A 1H , 20HS , 3F16.8) 2400 FORMAT (2H -, A6, 1H-, A 1H , 20HXLB , /, B (1H , F16.8)) 2500 FORMAT (2H -, A6, 1H-, A 1H , 20HDLS , F16.8) END wt3d.f000644 000311 000121 00000047350 06067230700 011731 0ustar00krivecf1000000 000000 SUBROUTINE WT3D(MDMU, MDS, MDKX, MDMA, MDCN, MDPJ, MDVPAR, 1 XM, XKAPPA, XOMEGA, ISMN, 2 MM, KX, MA, JMAX, IINTR, Z0M1, Z0P1, E, PCV11, 3 DD, WFC, WKY, DDY, WFCY, 4 MODF, FANA, MODV, IPVL, IPVU, VPAR, 6 NOUTB, NIN, NOUT, NOUTP, NOUTP1) C IMPLICIT REAL*8 (A-H, O-Z) DIMENSION XM(3), XKAPPA(3), XOMEGA(3), ISMN(2,MDS), 1 DD(MDS,MDKX,MDMA), WFC(MDS,MDCN), 2 WKY(MDS,4), DDY(MDKX,MDMA,6), WFCY(MDCN,6), 3 FANA(3,3), VPAR(3,MDVPAR) C ------------------------------------------------------------------ C TABULATES CFHHM WAVE FUNCTION OR ITS PARTS, CORRELATION FUNCTION C ETC. FOR OPTIONS SEE WT3T-, FOR DEFINITIONS SEE PROGRAM AV3M-. C POINTS LIE ON A TWO-DIMENSIONAL GRID IN SOME VARIABLES (FOR C OPTIONS SEE WT3C-) AND ARE FIRST MAPPED INTO A ONE-DIMENSIONAL SET C OF (A, LAMBDA, RHO) TRIPLES DEFINED WITH RESPECT TO PAIR 3. C TABULATED VALUES CAN BE TRIVIALLY MAPPED BACK AT THE END. C WAVE FUNCTION DATA ARE READ FROM A FILE, ONE INTERVAL AT A TIME, C AND TABULATION IS DONE FOR ALL POINTS WHOSE Z VALUES LIE ON THE C CURRENT INTERVAL. C C SOME ARRAYS ARE TRANSFERRED FROM THE CALLING PROGRAM (AV3M-). C OTHERS ARE DEFINED INTERNALLY, WITH DIMENSION CHECKING, SO THAT C C THIS ROUTINE IS A RATHER INDEPENDENT BRANCH OF AV3M-. C IT READS ITS CONTROL PARAMETERS FROM ITS OWN INPUT FILE. C C THIS ROUTINE HAS ITS OWN SPECIAL CASE BRANCH, THE OUTPUT OF C THE CHI(RHO) FUNCTIONS (THE SOLUTION OF THE ODE'S), WHEN C LCHI = .TRUE.. (IN THIS CASE A, LAMBDA ARE DUMMIES). C C TESTS: C C TESTED ON HE ATOM, KM = 32, 93/01/29. COMPARED WITH C PHYS. REV. A42, 6324 (1990). AGREEMENT 2 S.D. IN H/E - 1 C AT POINTS WHERE IT IS BELOW 0.01. C IF ONE OF R(I) APPROACHES 0, RESULTS DISAGREE WITH THE C PAPER. EXAMPLE (R(I) IN UNITS OF AVERAGE DISTANCES): C R(2) R(1) R(3) H PSI/E PSI - 1 (PERCENT) C 0.5 0.5 0.000 000 1 -3(+5) C 0.000 001 -284.982 C 0.000 005 2.171 C 0.000 01 1.883 C 0.000 05 2.165 C 0.000 1 2.158 C 0.001 2.043 C 0.01 1.046 C C PAPER 0.000 001 2.166 C THE PRESENT PROGRAM MAY BE UNSTABLE CLOSE TO COALESCENCE C POINTS. C C OPTIONALLY (LDERIV) LOGARITHMIC DERIVATIVES WITH RESPECT TO THE C FIRST (X) COORDINATE ARE CALCULATED BY A SIMPLE FORMULA. C ------------------------------------------------------------------ C DIMENSION PARAMETERS OF THE FORM MD-- ARE DEFINED IN THE CALLING C PROGRAM. THOSE OF THE FORM ND-- ARE DEFINED HERE. SOME OF THEM C MEAN THE SAME THING; IN THIS WAY THE ARRAYS INTERNAL TO THIS C ROUTINE, BUT HAVING SOME DIMENSIONS DICTATED BY CALLING PROGRAM, C CAN BE DEFINED INTERNALLY. EQUALITY OF DIMENSIONS IS TESTED BELOW. C THIS ALSO ENABLES PUTTING INTERNAL DIMENSIONS TO SMALL VALUES IN C ORDER FOR THIS ROUTINE NOT TO INTERFERE WITH THE LENGTH OF THE C CALLING PROGRAM IF USED FOR OTHER PURPOSES. C NDSX: MAY BE 1 IF LCHI = .FALSE.. C PARAMETER (NDTX = 101, NDTY = 101, NDMU = 25, NDCN = 22, ISYM = 0) PARAMETER (NDT = NDTX * NDTY, 1 NDS = (1 - ISYM) * (NDMU * (NDMU + 1) / 2) 2 + ISYM * (((NDMU + 1) / 2) ** 2), 3 NDMA = NDMU, 4 NDKX = (NDCN - 1) + 2 * (NDMU - 1) + 2 + 1, 5 NDPJ = (NDMU - 1) / 2 + 1) PARAMETER (NDSX = NDS) C C --POINTS-- DIMENSION TX1(NDTX), TY1(NDTY), TX(NDTX), TY(NDTY), AR(3), 1 T(NDT,3), T1(NDT), F(NDT,NDSX), RHOP(4), INDT(NDT), 2 D(NDTX) LOGICAL IFLAG(NDT), LAR, LTRH, LCUSP, LDERIV, LCHI C --ANGULAR FUNCTIONS-- DIMENSION ARGA(NDT), ARG1A(NDT), AUXA1(NDT), 1 R(3,NDT), RA(3,NDT), RAA(3,NDT), 2 RL(3,NDT), RLL(3,NDT), RP(9,NDT) LOGICAL LTAL C --HH(A)-- DIMENSION TPJ(NDT,NDPJ), TYA(NDS,NDT), TYAA(NDS,NDT) C --HH(LAMBDA)-- DIMENSION WK1(NDT,NDMU,2), WK2(NDT,NDMU,2), 1 TYL(NDS,NDT), TYLL(NDS,NDT) LOGICAL LTJY C --POWERS OF Z-- DIMENSION ZDPL(NDKX,NDMA), ZDP(NDCN) C --C.F., V-- LOGICAL LTCF, LTV C --W. F. TEST-- DIMENSION IWFC(NDS,NDCN) C --GENERAL-- LOGICAL LQWF0 C ------------------------------------------------------------------ CHARACTER NAME*6, VERS*66 DATA NAME / 'WT3D ' /, VERS / ' & 1.0, 95/05/16. -C 1.3; -B 1.0. & ' / C ------------------------------------------------------------------ LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, & ZERO, ONE, X180, X15 / 0.D0, 1.D0, 180.D0, 1.5D0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C ================================================================== C TEST EXTERNAL AND INTERNAL DIMENSIONS. IF (NDMU .NE. MDMU) CALL ERR2(NAME, 1, 1, NOUT) IF (NDS .NE. MDS) CALL ERR2(NAME, 2, 1, NOUT) IF (NDKX .NE. MDKX) CALL ERR2(NAME, 3, 1, NOUT) IF (NDMA .NE. MDMA) CALL ERR2(NAME, 4, 1, NOUT) IF (NDCN .NE. MDCN) CALL ERR2(NAME, 5, 1, NOUT) IF (NDPJ .NE. MDPJ) CALL ERR2(NAME, 6, 1, NOUT) C ================================================================== C I/O CONTROL PARAMETERS. READ (NIN,1030) LCHI READ (NIN,1010) ISL, ISU READ (NIN,1010) ISEL READ (NIN,1010) ICSET, IPAIR READ (NIN,1020) XL, XU, XS, NX, IMODEX, ICOORX READ (NIN,1020) YL, YU, YS, NY, IMODEY, ICOORY READ (NIN,1020) PAR READ (NIN,1030) LAR READ (NIN,1020) AR READ (NIN,1030) LCUSP READ (NIN,1030) LTRH, LTAL, LTJY, LTCF, LTV READ (NIN,1040) FSCALE READ (NIN,1030) LDERIV READ (NIN,1020) ZWFC, ZWFCD READ (NIN,1030) LQWF0 C WRITE(NOUT,2100) NAME, LCHI, ISL, ISU, ISEL, 1 ICSET, IPAIR, 2 XL, XU, XS, NX, IMODEX, ICOORX, 3 YL, YU, YS, NY, IMODEY, ICOORY, 4 PAR, LAR, AR, LCUSP, 5 LTRH, LTAL, LTJY, LTCF, LTV, FSCALE, LDERIV, 6 ZWFC, ZWFCD, LQWF0 C ================================================================== C INITIALIZE (SEE AV3M-). RHOTOZ = 2 * SQRT(2 * E) HC0 = 2 * SQRT(2 * E) HC1 = HC0 ** 2 C PHI AT RHO = 0 (ALTERNATIVE FORMULA, SEE QWF0). QWF0A = (RHOTOZ ** 2 / CDXPI() ** X15) * PCV11 WRITE (NOUT,2210) QWF0A C PRINT LAMBDAS AT R(I) = 0 IN DEGREES. ZZZ1 = (CDXPI() - XOMEGA(1)) * (X180 / CDXPI()) ZZZ2 = (CDXPI() - XOMEGA(2)) * (X180 / CDXPI()) ZZZ3 = (CDXPI() - XOMEGA(3)) * (X180 / CDXPI()) WRITE (NOUT,4000) NAME, ZZZ1, ZZZ2, ZZZ3 C ================================================================== C CHI BRANCH: INITIALIZE (IMODEX, NX, ... TAKEN FROM INPUT). C ADJUST ISL, ISU, EG.: (0,0)->(1,1), (0,9999)->(1,MM),... IF (LCHI) THEN IF (NDSX .LT. NDS) CALL ERR2(NAME, 7, 1, NOUT) ICSET = 1 ICOORX = 3 ICOORY = 1 IMODEY = 2 NY = 1 YL = 45. YU = 45. ISL = MIN(MM, MAX(1, ISL)) ISU = MAX(ISL, MIN(MM, ISU)) ENDIF C ================================================================== C GENERATE A ONE-DIMENSIONAL SET OF (A, LAMBDA, RHO) POINTS. CALL WT3CA( 1 NDT, NDTX, NDTY, ICSET, IPAIR, LCUSP, PAR, 2 XL, XU, XS, NX, IMODEX, ICOORX, 3 YL, YU, YS, NY, IMODEY, ICOORY, 4 XM, XKAPPA, XOMEGA, LAR, AR, TX1, TY1, 5 NTX, TX, NTY, TY, NT, T, LTRH, NOUT) C IF (.NOT. LCHI) THEN C CALCULATE ANGULAR PARTS OF R(K), THEIR DERIVATIVES, ETC. CALL WT3ALA( 1 NDT, NT, T, XKAPPA, XOMEGA, 2 ARGA, ARG1A, AUXA1, 3 R, RA, RAA, RL, RLL, RP, LTAL, NOUT) C C A-DEPENDENT PARTS AND LAMBDA-DEPENDENT PARTS OF THE REAL HH C FOR ALL STATES, ALL ARGUMENTS. CALL AV2YAB( 1 NDS, NDT, NDPJ, NOUT, LTJY, 2 MM, ISMN, NT, ARGA, ARG1A, TPJ, TYA, TYAA) CALL AV2YLC( 1 NDS, NDT, NDMU, NOUT, LTJY, 2 MM, ISMN, NT, T(1,2), WK1, WK2, TYL, TYLL) ENDIF C ================================================================== C LOOP OVER INTERVALS (ANY ORDER). C C SET FLAGS. DO 10 I = 1,NT IFLAG(I) = .TRUE. 10 CONTINUE C FIRST INTERVAL WAS INPUT ALREADY. SKIP READING, ENTER LOOP. JMAX1 = JMAX + 1 JINT = 1 Z0M = Z0M1 Z0P = Z0P1 GO TO 34 20 CONTINUE JINT = JINT + 1 READ (NOUTB,ERR=22,END=22) IINT, Z0M, Z0P C ----------------------------------------- IF (IINT .NE. JINT) CALL ERR2(NAME, 11, 1, NOUT) GO TO 24 22 CONTINUE CALL ERR2(NAME, 12, 1, NOUT) 24 CONTINUE DO 26 J = 1,JMAX1 READ (NOUTB) (WFC(I,J), I = 1,MM) C --------------------------------- 26 CONTINUE C C OPTIONAL TEST OUTPUT OF WFC. IF (ABS(Z0M - ZWFC) .LE. ZWFCD) THEN DO 30 J = 1,JMAX1 DO 28 I = 1,MM IWFC(I,J) = LOG10(MAX(CDXEPS(), ABS(WFC(I,J)))) 28 CONTINUE 30 CONTINUE WRITE (NOUT,5000) IINT, Z0M, Z0P DO 32 I = 1,MM WRITE (NOUT,5002) I, (IWFC(I,J), J = 1,JMAX1) 32 CONTINUE ENDIF 34 CONTINUE C C FIND AND UNFLAG POINTS WHOSE Z VALUES LIE INSIDE INTERVAL. C CONVERSION TO RHO MAY BE A SOURCE OF SMALL BOUNDARY ERRORS. ZL = MIN(Z0M, Z0P) ZU = MAX(Z0M, Z0P) J = 0 DO 36 I = 1,NT ZZZ = T(I,3) * RHOTOZ IF (IFLAG(I) .AND. ZZZ .GE. ZL .AND. 1 ZZZ .LT. ZU ) THEN IFLAG(I) = .FALSE. J = J + 1 T1(J) = ZZZ INDT(J) = I ENDIF 36 CONTINUE NT1 = J IF (NT1 .GT. NDT) CALL ERR2(NAME, 21, 1, NOUT) C C GO TO NEXT INTERVAL IF NO POINTS LIE IN THE CURRENT ONE. IF (NT1 .EQ. 0 .AND. JINT .LT. IINTR) GO TO 20 C -------------------------------------------------------------- NZZ = 1 DO 40 J = 1,NT1 I = INDT(J) C ---------------------------------------------------------- C RHO AND POWERS OF RHO. RHO = T(I,3) RHOP(1) = RHO ** 2 RHOP(2) = (ONE / RHO) RHOP(3) = (ONE / RHO) ** 2 RHOP(4) = (ONE / RHO) ** 3 C ---------------------------------------------------------- C CHI BRANCH: EVALUATE CHI, SKIP WAVE FUNCTION. C ** USE THE ARRAY TYA (USED FOR HH OTHERWISE) ** IF (LCHI) THEN IF (JINT .EQ. 1) THEN CALL AVZP0A( 1 NZZ, NDKX, NDMA, NZZ, KX, MA, 2 T1(J), ZD1, ZDPL, NOUT) CALL TCHI0A( & NDS, NDMA, NDKX, MM, MA, KX, DD, ZDPL, & NOUT, TYA(1,1)) ELSE CALL AVZP1A( 1 NZZ, NDCN, NZZ, JMAX, Z0M, 2 T1(J), ZDP, NOUT) CALL TCHI1A( & NDS, NDCN, MM, JMAX, WFC, ZDP, NOUT, TYA(1,1)) ENDIF C PUT CHI/RHO**2 VALUES INTO TABLE. DO 38 K = 1,MM F(I,K) = TYA(K,1) * RHOP(3) 38 CONTINUE GO TO 40 ENDIF C ---------------------------------------------------------- C HH PART OF WAVE FUNCTION AND ITS DERIVATIVES. C FIRST SUM OVER HH THEN OVER POWERS. USE TWF-- INSTEAD OF C AVWF-- BECAUSE 1 VALUE OF Z MUST BE DONE AT A TIME C OTHERWISE DDY, WFCY WOULD HAVE TO HAVE INDEX J. C FUNCTIONS OF Z AND Z0M FOR SELECTED POINTS. IF (JINT .EQ. 1) THEN CALL AV2W0A( 1 NDS, NDKX, NDMA, NOUT, 2 MM, ISMN, TYA(1,I), TYAA(1,I), 3 TYL(1,I), TYLL(1,I), KX, MA, DD, WKY, DDY) IF (Z0M .NE. ZERO) CALL ERR2(NAME, 31, 1, NOUT) CALL AVZP0A( 1 NZZ, NDKX, NDMA, NZZ, KX, MA, 2 T1(J), ZD1, ZDPL, NOUT) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,1), ZDPL, NOUT, TWF) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,2), ZDPL, NOUT, TWFD) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,3), ZDPL, NOUT, TWFA) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,4), ZDPL, NOUT, TWFL) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,5), ZDPL, NOUT, TWFZ) CALL TWF0A( 1 NDMA, NDKX, MA, KX, DDY(1,1,6), ZDPL, NOUT, TWFZZ) ELSE CALL AV2W1A( 1 NDS, NDCN, NOUT, 2 MM, ISMN, TYA(1,I), TYAA(1,I), 3 TYL(1,I), TYLL(1,I), JMAX, WFC, WKY, WFCY) CALL AVZP1A( 1 NZZ, NDCN, NZZ, JMAX, Z0M, 2 T1(J), ZDP, NOUT) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,1), ZDP, NOUT, TWF) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,2), ZDP, NOUT, TWFD) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,3), ZDP, NOUT, TWFA) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,4), ZDP, NOUT, TWFL) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,5), ZDP, NOUT, TWFZ) CALL TWF1A( 1 NDCN, JMAX, WFCY(1,6), ZDP, NOUT, TWFZZ) ENDIF C ---------------------------------------------------------- C CORRELATION FUNCTION F AND ITS DERIVATIVES. CALL AV2CFD( 1 NZZ, NOUT, LTCF, FANA, 2 R(1,I), RA(1,I), RAA(1,I), RL(1,I), RLL(1,I), 3 ARG1A(I), MODF, NZZ, RHO, 4 TCF, TCFR, TCFRR, TCFA, TCFAA, TCFL, TCFLL) C ---------------------------------------------------------- C POTENTIAL V. CALL AV2VA( 1 MDVPAR, NZZ, NOUT, LTV, 2 MODV, IPVL, IPVU, VPAR, R(1,I), RP(4,I), 4 NZZ, RHO, RHOP(2), TVF) C ---------------------------------------------------------- C CALCULATE REQUIRED FUNCTION (SINGLE) VALUE. IF (LQWF0) THEN C DIVIDE BY TWF(RHO = 0). ZZZ = ONE / (QWF0A * RHOP(1)) TWF = TWF * ZZZ TWFD = TWFD * ZZZ TWFA = TWFA * ZZZ TWFL = TWFL * ZZZ TWFZ = TWFZ * ZZZ TWFZZ = TWFZZ * ZZZ ENDIF CALL WT3TA( 1 ISEL, E, HC0, HC1, RHOP, AUXA1(I), ARG1A(I), 2 TWF, TWFD, TWFA, TWFL, TWFZ, TWFZZ, 3 TCF, TCFR, TCFRR, TCFA, TCFAA, TCFL, TCFLL, 4 TVF, R(1,I), F(I,1), NOUT) C ---------------------------------------------------------- 40 CONTINUE IF ((.NOT. LCHI) .AND. (JINT .EQ. 1)) THEN C ---------------------------------------------------------- C WAVE FUNCTION EXP(F) WF / RHO**2 AT RHO = 0 C (NORMALIZED AS ARRAY QWF IN AV3M-). LAST VERSION OF DDY C USED (ALL ARE EQUAL). THIS IS PRINTED ONLY IF INTERVAL 1 C IS ACCESSED. QWF0 = DDY(3,1,1) * RHOTOZ ** 2 WRITE (NOUT,2200) QWF0 C ---------------------------------------------------------- ENDIF C END LOOP OVER INTERVALS. IF (JINT .LT. IINTR) GO TO 20 C TEST FLAGS. DO 42 I = 1,NT IF (IFLAG(I)) CALL ERR2(NAME, 1000000+I, 0, NOUT) 42 CONTINUE C ================================================================== C SCALE FACTOR TO HELP WITH PLOTTING. IF (LCHI) THEN JL = ISL JU = ISU ELSE JL = 1 JU = 1 ENDIF DO 52 J = JL,JU DO 50 I = 1,NT F(I,J) = F(I,J) * FSCALE 50 CONTINUE 52 CONTINUE C C OUTPUT FOR PLOTTING. X RUNS FIRST IN THE ABOVE ROUTINES. C EMPTY LINES INSERTED TO SEPARATE GRID LINES (REQUIRED EG. C BY GNUPLOT; THE VERSION AS OF 94/10/26 REQUIRES THE FIRST C LINE TO BE EMPTY TOO). WRITE (NOUTP1,3200) 1 MM, E, ISEL, ICSET, IPAIR, 2 XL, XU, IMODEX, ICOORX, 3 YL, YU, IMODEY, ICOORY, 4 PAR, LAR IF (LCHI) THEN IF (NTX .NE. NT) CALL ERR2(NAME, 40, 1, NOUT) IF (JL .LT. 1) CALL ERR2(NAME, 41, 1, NOUT) IF (JU .GT. MM) CALL ERR2(NAME, 42, 1, NOUT) IF (JL .GT. JU) CALL ERR2(NAME, 43, 1, NOUT) DO 62 J = JL,JU WRITE (NOUTP,3100) DO 60 IX = 1,NTX WRITE (NOUTP,3300) TX(IX), FLOAT(J), F(IX,J) 60 CONTINUE 62 CONTINUE ELSE I = 0 DO 66 IY = 1,NTY WRITE (NOUTP,3100) DO 64 IX = 1,NTX I = I + 1 WRITE (NOUTP,3000) TX(IX), TY(IY), F(I,1) 64 CONTINUE 66 CONTINUE ENDIF C ================================================================== IF (LDERIV .AND. (.NOT. LCHI)) THEN CALL WT3D1A( 1 NDTX, NDTY, NDT, NTX, TX, NTY, TY, F, D, NOUT) ENDIF C ================================================================== RETURN 1010 FORMAT (20I4) 1020 FORMAT (3F12.6, 3I4) 1030 FORMAT (20L1) 1040 FORMAT (E12.4) C 2000 FORMAT (2H -, A6, A66) 2100 FORMAT (2H -, A6, 1H-, //, I 1H , 32H ---- TABULATION ---- , //, J 1H , 32H ---- LCHI , L4, /, K 1H , 32HISL, ISU , 2I4, /, 1 1H , 32HISEL , I4, /, 2 1H , 32HICSET, IPAIR , 2I4, /, 3 1H , 32HXL, XU, XS, NX, IMODEX, ICOORX , 3F12.6, I4, 2I2, /, 4 1H , 32HYL, YU, YS, NY, IMODEY, ICOORY , 3F12.6, I4, 2I2, /, 5 1H , 32HPAR , F12.6, /, 6 1H , 32HLAR, AR , L4, /, 7 1H , 4X, 3F24.16 , /, 8 1H , 32HLCUSP , L4, /, 9 1H , 32HLTRH, LTAL, LTJY, LTCF, LTV , 5L4, /, A 1H , 32HFSCALE , E12.4, /, B 1H , 32HLDERIV , L4, /, C 1H , 32HZWFC, ZWFCD , 2F12.6, /, D 1H , 32HLQWF0 , L4, //) 2200 FORMAT (1H , 8HQWF0 , E24.16) 2210 FORMAT (1H , 8HQWF0A , E24.16) 3000 FORMAT (1H , 3E24.16) 3100 FORMAT () 3200 FORMAT (1H , 11Hset title \, /, 1 1H , 1H", I3, F20.16, I3, 2I2, 2F10.4, 2I2, 2F10.4, 2I2, 2 F10.4, L2, 1H") 3300 FORMAT (1H , E24.16, E24.16, E24.16) 4000 FORMAT (2H -, A6, 1H-, 1 32H LAMBDA AT R(I) = 0: , /, 2 1H , 3F20.12) 5000 FORMAT (1H , 20HIINT, Z0M, Z0P: , I8, 2F12.6, /, 1 1H , 4HWFC:) 5002 FORMAT (1H , I8, 18I4, /, (1H , 8X, 18I4)) END av2alc.f000644 000311 000121 00000016607 06067230026 012222 0ustar00krivecf1000000 000000 SUBROUTINE AV2ALC(NDGO, NDSI, NDPA, NDPL, NOUT, LP, 1 NGOA, NSUBA, NGOL, NSUBL, 2 XA, XL, XKAPPA, XOMEGA, 3 NPA, NPLX, ARGA, ARG1A, PSA, ARGL, 4 AUXA, AUXL, R, RA, RAA, RL, RLL, RP) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2), 1 XA(NDGO,NDSI,2), XL(NDGO,NDSI,20), 2 XKAPPA(3), XOMEGA(3), NPLX(2), 3 ARGA(NDPA), ARG1A(NDPA), PSA(NDPA), ARGL(NDPL,2), 4 AUXA(NDPA), AUXL(NDPL,2,6), 5 R(3,NDPL,NDPA), RA(3,NDPL,NDPA), RAA(3,NDPL,NDPA), 6 RL(3,NDPL,NDPA), RLL(3,NDPL,NDPA), 7 RP(9,NDPL,NDPA) LOGICAL LP C C C RHO-INDEPENDENT FUNCTIONS OF (A, LAMBDA), INCLUDING THE VALUES OF C RADII DIVIDED BY RHO, AND THEIR DERIVATIVES WITH RESPECT TO A AND C LAMBDA. C ALLOWS NGO- = 0; SKIPS LOOPS IN THOSE CASES. C C OUTPUT: C R - INTERPARTICLE RADIUS / RHO. C RA - A DERIVATIVE OF R. C RAA - SECOND A DERIVATIVE OF R. C RL - LAMBDA DERIVATIVE OF R. C RLL - SECOND LAMBDA DERIVATIVE OF R. C RP - POWERS OF R. C C CHARACTER*6 NAME DATA NAME / 'AV2ALC' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 94/05/23 (-B 1.2) NGO- = 0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ONE, HALF / 1.D0, 0.5D0 / C C STATEMENT FUNCTION. IND2(I, J, ID) = I + (J - 1) * ID C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C FUNCTIONS OF A. IF (LP) WRITE (NOUT,2100) NAME IAX = 0 DO 14 IRA = 1,2 NSA = NSUBA(IRA) NA = NGOA(IRA) IF (NA .EQ. 0) GO TO 14 DO 12 ISA = 1,NSA DO 10 IA = 1,NA IAX = IAX + 1 PSA(IAX) = SIN(2 * XA(IA,ISA,IRA)) ARGA(IAX) = COS(2 * XA(IA,ISA,IRA)) ARG1A(IAX) = SIN(XA(IA,ISA,IRA)) C AUXA(IAX) = COS(XA(IA,ISA,IRA)) C IF (LP) WRITE (NOUT,2102) 1 IAX, XA(IA,ISA,IRA), ARGA(IAX), ARG1A(IAX) 10 CONTINUE 12 CONTINUE 14 CONTINUE NPA = IAX IF (NPA .GT. NDPA) CALL ERR2(NAME, 1, 1, NOUT) C C FUNCTIONS OF LAMBDA. IF (LP) WRITE (NOUT,2110) NAME DO 30 IRA = 1,2 ILX = 0 DO 24 IRL = 1,10 NSL = NSUBL(IRL,IRA) NL = NGOL(IRL,IRA) IF (NL .EQ. 0) GO TO 24 DO 22 ISL = 1,NSL DO 20 IL = 1,NL ILX = ILX + 1 ZZZ = XL(IL,ISL,IND2(IRL,IRA,10)) ARGL(ILX,IRA) = ZZZ C AUXL(ILX,IRA,1) = COS(ZZZ + XOMEGA(1)) AUXL(ILX,IRA,2) = COS(ZZZ + XOMEGA(2)) AUXL(ILX,IRA,3) = COS(ZZZ + XOMEGA(3)) AUXL(ILX,IRA,4) = SIN(ZZZ + XOMEGA(1)) AUXL(ILX,IRA,5) = SIN(ZZZ + XOMEGA(2)) AUXL(ILX,IRA,6) = SIN(ZZZ + XOMEGA(3)) C IF (LP) WRITE (NOUT,2112) 1 ILX, IRA, ARGL(ILX,IRA) 20 CONTINUE 22 CONTINUE 24 CONTINUE NPLX(IRA) = ILX IF (NPLX(IRA) .GT. NDPL) CALL ERR2(NAME, 2, 1, NOUT) 30 CONTINUE C C FUNCTIONS OF (A, LAMBDA). IF (LP) WRITE (NOUT,2120) NAME Z1 = HALF * XKAPPA(1) Z2 = HALF * XKAPPA(2) Z3 = HALF * XKAPPA(3) IAX = 0 DO 46 IRA = 1,2 NSA = NSUBA(IRA) NA = NGOA(IRA) NLX = NPLX(IRA) IF (NA .EQ. 0) GO TO 46 DO 44 ISA = 1,NSA DO 42 IA = 1,NA IAX = IAX + 1 DO 40 ILX = 1,NLX C C INTERPARTICLE RADII R(I), DIVIDED BY HYPERRADIUS. R1 = SQRT(XKAPPA(1) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,1))) R2 = SQRT(XKAPPA(2) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,2))) R3 = SQRT(XKAPPA(3) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,3))) C R(1,ILX,IAX) = R1 R(2,ILX,IAX) = R2 R(3,ILX,IAX) = R3 C C AUXILIARY. R1I = ONE / R1 R2I = ONE / R2 R3I = ONE / R3 X1 = (Z1 * R1I) * AUXL(ILX,IRA,1) X2 = (Z2 * R2I) * AUXL(ILX,IRA,2) X3 = (Z3 * R3I) * AUXL(ILX,IRA,3) X4 = - (Z1 * R1I) * ARG1A(IAX) X5 = - (Z2 * R2I) * ARG1A(IAX) X6 = - (Z3 * R3I) * ARG1A(IAX) C C A DERIVATIVES. RA(1,ILX,IAX) = X1 * AUXA(IAX) RA(2,ILX,IAX) = X2 * AUXA(IAX) RA(3,ILX,IAX) = X3 * AUXA(IAX) C C SECOND A DERIVATIVES. RAA(1,ILX,IAX) = 1 - X1 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(1,ILX,IAX) * R1I) RAA(2,ILX,IAX) = 1 - X2 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(2,ILX,IAX) * R2I) RAA(3,ILX,IAX) = 1 - X3 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(3,ILX,IAX) * R3I) C C LAMBDA DERIVATIVES. RL(1,ILX,IAX) = X4 * AUXL(ILX,IRA,4) RL(2,ILX,IAX) = X5 * AUXL(ILX,IRA,5) RL(3,ILX,IAX) = X6 * AUXL(ILX,IRA,6) C C SECOND LAMBDA DERIVATIVES. RLL(1,ILX,IAX) = 1 X4 * (AUXL(ILX,IRA,1) - 2 AUXL(ILX,IRA,4) * RL(1,ILX,IAX) * R1I) RLL(2,ILX,IAX) = 1 X5 * (AUXL(ILX,IRA,2) - 2 AUXL(ILX,IRA,5) * RL(2,ILX,IAX) * R2I) RLL(3,ILX,IAX) = 1 X6 * (AUXL(ILX,IRA,3) - 2 AUXL(ILX,IRA,6) * RL(3,ILX,IAX) * R3I) C C POWERS OF R1, R2, R3. RP(1,ILX,IAX) = R1 ** 2 RP(2,ILX,IAX) = R2 ** 2 RP(3,ILX,IAX) = R3 ** 2 C RP(4,ILX,IAX) = R1I RP(5,ILX,IAX) = R2I RP(6,ILX,IAX) = R3I C RP(7,ILX,IAX) = R1I ** 2 RP(8,ILX,IAX) = R2I ** 2 RP(9,ILX,IAX) = R3I ** 2 C IF (LP) WRITE (NOUT,2122) 1 IRA, IAX, ILX, R1, R2, R3 40 CONTINUE 42 CONTINUE 44 CONTINUE 46 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 20HXA, ARGA, ARG1A: ) 2102 FORMAT ( A 1H , I4, 3F12.6) 2110 FORMAT ( A 2H -, A6, 1H-, 20HARGL: ) 2112 FORMAT ( A 1H , 2I4, F12.6) 2120 FORMAT ( A 2H -, A6, 1H-, 20HR1, R2, R3: ) 2122 FORMAT ( A 1H , 3I4, 3E12.4) END tchi0a.f000644 000311 000121 00000002325 06067231071 012213 0ustar00krivecf1000000 000000 SUBROUTINE TCHI0A(NDS, NDMA, NDKX, & NS, MA, KX, DD, ZDPL, NOUT, CHI) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION DD(NDS,NDKX,NDMA), ZDPL(NDKX,NDMA), CHI(NDS) C C SUM THE LOG-POWER SERIES FOR CHI (W. F. HH COMPONENTS), C ON THE FIRST INTERVAL (CONTAINING THE ORIGIN). C ZDPL: ONE Z-VALUE ONLY. C LOGICAL LCALL0 CHARACTER NAME*6, VERS*66 DATA NAME / 'TCHI0A' /, VERS / ' & 1.0, 94/10/24. TWF0A 1.0. & ' / C ------------------------------------------------------------------ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NS .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (KX + 1 .GT. NDKX) CALL ERR2(NAME, 2, 1, NOUT) IF (MA .GT. NDMA) CALL ERR2(NAME, 3, 1, NOUT) DO 20 I = 1,NS CHI(I) = ZERO 20 CONTINUE KX1 = KX + 1 DO 26 M = 1,MA DO 24 K1 = 1,KX1 DO 22 I = 1,NS CHI(I) = CHI(I) + DD(I,K1,M) * ZDPL(K1,M) 22 CONTINUE 24 CONTINUE 26 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A66) END tchi1a.f000644 000311 000121 00000002053 06067230777 012226 0ustar00krivecf1000000 000000 SUBROUTINE TCHI1A(NDS, NDCN, NS, JMAX, WFC, ZDP, NOUT, CHI) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WFC(NDS,NDCN), ZDP(NDCN), CHI(NDS) C C SUM TAYLOR SERIES FOR CHI (W. F. HH COMPONENTS), C ON INTERVALS NOT CONTAINING THE ORIGIN. C ZDP: ONE Z-VALUE ONLY. C LOGICAL LCALL0 CHARACTER NAME*6, VERS*66 DATA NAME / 'TCHI1A' /, VERS / ' & 1.0, 94/10/24. TWF1A 1.0. & ' / C ------------------------------------------------------------------ DATA LCALL0 / .TRUE. /, ZERO / 0.D+0 / IF (LCALL0) WRITE (NOUT,2000) NAME, VERS C IF (NS .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) DO 20 I = 1,NS CHI(I) = ZERO 20 CONTINUE JMAX1 = JMAX + 1 DO 24 IP = 1,JMAX1 DO 22 I = 1,NS CHI(I) = CHI(I) + WFC(I,IP) * ZDP(IP) 22 CONTINUE 24 CONTINUE IF (LCALL0) LCALL0 = .FALSE. RETURN 2000 FORMAT (2H -, A6, 1H-, A66) END MBDA. IF (LP) WRITE (NOUT,2110) NAME DO 30 IRA = 1,2 ILX = 0 DO 24 IRL = 1,10 NSL = NSUBL(IRL,IRA) NL = NGOL(IRL,IRA) IF (NL .EQ. 0) GO TO 24 DO 22 ISL = 1,NSL DO 20 IL = 1,NL ILX = ILX + 1 ZZZ = XL(IL,ISL,IND2(IRL,IRA,10)) ARGL(ILX,IRA) = ZZZ C AUXL(ILX,IRA,1) = COS(ZZZ + XOMEGA(1)) AUXL(ILX,IRA,2) = COS(ZZZ + XOMEGA(2)) AUXL(ILX,IRA,3) = COS(ZZZ + XOMEGA(3)) AUXL(ILX,IRA,4) = SIN(ZZZ + XOMEGA(1)) AUXL(ILX,IRA,5) = SIN(ZZZ + XOMEGA(2)) AUXL(ILX,IRA,6) = SIN(ZZZ + XOMEGA(3)) C IF (LP) WRITE (NOUT,2112) 1 ILX, IRA, ARGL(ILX,IRA) 20 CONTINUE 22 CONTINUE 24 CONTINUE NPLX(IRA) = ILX IF (NPLX(IRA) .GT. NDPL) CALL ERR2(NAME, 2, 1, NOUT) 30 CONTINUE C C FUNCTIONS OF (A, LAMBDA). IF (LP) WRITE (NOUT,2120) NAME Z1 = HALF * XKAPPA(1) Z2 = HALF * XKAPPA(2) Z3 = HALF * XKAPPA(3) IAX = 0 DO 46 IRA = 1,2 NSA = NSUBA(IRA) NA = NGOA(IRA) NLX = NPLX(IRA) IF (NA .EQ. 0) GO TO 46 DO 44 ISA = 1,NSA DO 42 IA = 1,NA IAX = IAX + 1 DO 40 ILX = 1,NLX C C INTERPARTICLE RADII R(I), DIVIDED BY HYPERRADIUS. R1 = SQRT(XKAPPA(1) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,1))) R2 = SQRT(XKAPPA(2) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,2))) R3 = SQRT(XKAPPA(3) * 1 (ONE + ARG1A(IAX) * AUXL(ILX,IRA,3))) C R(1,ILX,IAX) = R1 R(2,ILX,IAX) = R2 R(3,ILX,IAX) = R3 C C AUXILIARY. R1I = ONE / R1 R2I = ONE / R2 R3I = ONE / R3 X1 = (Z1 * R1I) * AUXL(ILX,IRA,1) X2 = (Z2 * R2I) * AUXL(ILX,IRA,2) X3 = (Z3 * R3I) * AUXL(ILX,IRA,3) X4 = - (Z1 * R1I) * ARG1A(IAX) X5 = - (Z2 * R2I) * ARG1A(IAX) X6 = - (Z3 * R3I) * ARG1A(IAX) C C A DERIVATIVES. RA(1,ILX,IAX) = X1 * AUXA(IAX) RA(2,ILX,IAX) = X2 * AUXA(IAX) RA(3,ILX,IAX) = X3 * AUXA(IAX) C C SECOND A DERIVATIVES. RAA(1,ILX,IAX) = 1 - X1 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(1,ILX,IAX) * R1I) RAA(2,ILX,IAX) = 1 - X2 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(2,ILX,IAX) * R2I) RAA(3,ILX,IAX) = 1 - X3 * (ARG1A(IAX) + 2 AUXA(IAX) * RA(3,ILX,IAX) * R3I) C C LAMBDA DERIVATIVES. RL(1,ILX,IAX) = X4 * AUXL(ILX,IRA,4) RL(2,ILX,IAX) = X5 * AUXL(ILX,IRA,5) RL(3,ILX,IAX) = X6 * AUXL(ILX,IRA,6) C C SECOND LAMBDA DERIVATIVES. RLL(1,ILX,IAX) = 1 X4 * (AUXL(ILX,IRA,1) - 2 AUXL(ILX,IRA,4) * RL(1,ILX,IAX) * R1I) RLL(2,ILX,IAX) = 1 X5 * (AUXL(ILX,IRA,2) - 2 AUXL(ILX,IRA,5) * RL(2,ILX,IAX) * R2I) RLL(3,ILX,IAX) = 1 X6 * (AUXL(ILX,IRA,3) - 2 AUXL(ILX,IRA,6) * RL(3,ILX,IAX) * R3I) C C POWERS OF R1, R2, R3. RP(1,ILX,IAX) = R1 ** 2 RP(2,ILX,IAX) = R2 ** 2 RP(3,ILX,IAX) = R3 ** 2 C RP(4,ILX,IAX) = R1I RP(5,ILX,IAX) = R2I RP(6,ILX,IAX) = R3I C RP(7,ILX,IAX) = R1I ** 2 RP(8,ILX,IAX) = R2I ** 2 RP(9,ILX,IAX) = R3I ** 2 C IF (LP) WRITE (NOUT,2122) 1 IRA, IAX, ILX, R1, R2, R3 40 CONTINUE 42 CONTINUE 44 CONTINUE 46 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, 20HXA, ARGA, ARG1A: ) 2102 FORMAT ( A 1H , I4, 3F12.6) 2110 FORMAT ( A 2H -, A6, 1H-, 20HARGL: ) 2112 FORMAT ( A 1H , 2I4, F12.6) 2120 FORMAT ( A 2H -, A6, 1H-, 20HR1, R2, R3: ) 2122 FORMAT ( A 1H , 3I4, 3E12.4) END tchi0a.f000644 000311 000121 00000002325 06067231071 012213 0ustar00krivecf1000000 000000 SUBROUTINE TCHI0A(NDS, NDMA, NDKX, & NS, MA, KX, DD, ZDPL, NOUT, CHI) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION DD(NDS,NDKX,NDMA), ZDPL(NDKX,NDMA), CHI(NDS) C C SUM THE LOG-POWER SERIES FOR CHI (W. F. HH COMPONENTS), C ON THE FIRST INTERVAL (CONTAINING THE ORIGIN). C ZDPL: ONE Z-VALUE ONLY. C LOGICAL LCALL0 CHARACTER NAME*6, VERS*66 DATA NAME / 'TCHI0A' /, VERS / ' & 1.0, 94/10/24. TWF0A 1.0. ewf2n000.csh000755 000311 000121 00000003676 06030577761 012662 0ustar00krivecf1000000 000000 #! /bin/csh -f # ewf2n000.csh (easy restart) set rr = 'xxx'; set best = 'xxx' # set default set xrr = $17; set xbest = $18 # input parameters @ i = $#argv while ($i) @ i = $i - 1 @ j = 18 - $i echo '-------- ' $j ' ' $argv[$j] end set rr = $xrr # 0: original run; # 1: restart (LMOD = 5); # 2: re-restart (LMOD = 51) if ($rr > 0) set best = $xbest # restart E setenv FOR003 $4/$6$9.3uu # scratch disk setenv FOR001 $2/$5$8.i set fo = $5$9$10 if ($rr >= 1) then set fox = $11$12$13 echo '-------- fox' $fox endif if ($rr == 2) then set foy = $14$15$16 echo '-------- foy' $foy endif setenv FOR002 $3/$fo.2ff echo '-------- FOR001 ' $FOR001 echo '-------- FOR002 ' $FOR002 setenv FOR004 $3/$fo.4uu setenv FOR014 $3/$fo.14f setenv FOR008 $3/$fo.8uu setenv FOR005 $3/$fo.5ff setenv FOR030 $4/$fo.30u # scratch disk setenv FOR020 $3/$fo.20u if ($rr < 2) then setenv FOR040 $4/$fo.40d # scratch disk echo '-------- rr FOR040 ' $rr $FOR040 endif if ($rr == 2) then setenv FOR040 $4/$foy.40d # scratch disk; restart file echo '-------- rr FOR040 ' $rr $FOR040 endif if ($rr > 0) then if ($best == 0) setenv FOR007 $3/$fox.4uu # iteration file if ($best == 1) setenv FOR007 $3/$fox.8uu # best value file echo '-------- FOR007 ' $FOR007 endif setenv ZZZLOG $3/$fo.log setenv ZZZEXE $1/$5.$7 touch $ZZZLOG date >> $ZZZLOG echo $FOR002 >> $ZZZLOG echo $ZZZEXE >> $ZZZLOG $ZZZEXE date >> $ZZZLOG set zzz = $4/$fo.30u; if (-e $zzz) ls -ls $zzz >> $ZZZLOG set zzz = $4/$fo.40d; if (-e $zzz) ls -ls $zzz >> $ZZZLOG cat $ZZZLOG # cleanup \rm -f $4/$fo.30u \rm -f $4/$fo.40d unsetenv FOR005 unsetenv ZZZLOG unsetenv ZZZEXE ewf2n1a.csh000644 000311 000121 00000004720 06070006673 012641 0ustar00krivecf1000000 000000 #!/bin/csh -f set pi1 = 'xxx'; set fo3 = 'xxx'; set fo4 = 'xxx' set pi2 = 'xxx'; set fo5 = 'xxx'; set fo6 = 'xxx' set rr = 'xxx'; set best = 'xxx'; set work = 'xxx' set rr = 0 # 0: original run; # 1: restart (LMOD = 5, --> w.f.); # 2: re-restart (LMOD = 51, --> w.f.); # 3: tabulation (LMOD = 7, E from iteration file). set xer = 0 # 0: previous run wrote best E value file # 1: previous run stopped before writing best E value file # (this overrides value of best if previous run had error) if ($rr == 1 || $rr == 2) set best = 1 # restart E: best value if ($rr == 3) set best = 0 # tabulation E; iteration file if ($xer == 1) set best = 0 # override best: use iteration file set work = 1 # 1: ewf2- # 2: av3m- # 3: both set fi = '1a' # 8 set fo1 = '1aa4001' # 9 set fo2 = '06cfec5555b31a' # 10 if ($rr >= 1) then set pi1 = 'ewf2n' # 11 initial run set fo3 = '1aa4001' # 12 set fo4 = '0acfec5555b33a' # 13 echo '---- pi1: ' $pi1 endif if ($rr == 2) then set pi2 = 'ewf2n' # 14 previous restart run set fo5 = '1aa4001' # 15 set fo6 = '0acfec5555b33a' # 16 echo '---- pi2: ' $pi2 endif set de = "$cwd/../pro" # 1 set di = "$cwd" set do = "$cwd/../out" set ds = "$cwd/../out" set pe = 'ewf2n' # 5 set pi = 'm2mk' # 6 set fe = 'e40p0s_ol_O2' # 7 if ($work == 1 || $work == 3) then echo '---- work' $work $di/${pe}000.csh $de $di $do $ds $pe $pi $fe $fi $fo1 $fo2 $pi1 $fo3 $fo4 \ $pi2 $fo5 $fo6 $rr $best # 1 2 3 4 5 6 7 8 9 10 11 12 13 # 14 15 16 17 18 endif if ($work > 1) then set do1 = '' set pi = $pe set pi1 = 'n' # see $pi set pe = 'av3mj' set fe = 'e_ol_O2' set fi1 = '2222224' set fi2 = 'a' set fi = 'md'$fi1$fi2 set fo3 = '0a'$fi1${fi2}$pi1 $di/${pe}000.c $de $di $do $ds $pe $pi $fe $fi $fo1 $fo2 $fo3 $do1 # 1 2 3 4 5 6 7 8 9 10 11 12 endif ewf2n1a.i000644 000311 000121 00000002051 06030244130 012273 0ustar00krivecf1000000 000000 95/09/21 He bm_a FFFFFFFF LTDD,LTDDR,LTVICD,LTRRPS,LPRBIN,LPRZ0M,LTCPU,LTCRU TFFTFT LPRCV0, LPRXX, LPRCV, *LPRCVM, LPRMAT, LPRWF TFT LTZE, LTZEIF, LXLAST (IPROG = 200) T LTDET FF LDOUBL, LDOUBM 9999 IINTPR 20 200 LM, IPROG 0 IENXL (LMOD = 5, 6 ONLY) 0 I0D 0 49 1 IPWUU, NSU, INUSEL 20 16 NM, JMAX 0.50 0.50 9999.0 BC0, BC1, RHOUW 2.9000 3.0000 A, B +1.0000000D-14 0.05000000D+00 5.00000000D+00 EPSP, TOL, DZU 0.50 5.00 120.00 ZM, ZMATCH, ZTOP 0 NHH 1 LMOD 2.90374150697155 3.00 1.00 ENXL, ENXU, ENXS 1 IPIO (0: M1M-, 1: M2M-) 0.00 999.00 1 1 Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ------------------------------------------------------------------------------- ewf2n_pack.tar000644 000311 000121 00001274000 06070002267 013422 0ustar00krivecf1000000 000000 ewf2n.f000644 000311 000121 00000125231 06070002116 012054 0ustar00krivecf1000000 000000 PROGRAM EWF2N IMPLICIT REAL*8 (A - H, O - Z) C C C C F H H M C C C SOLVES THE CFHHM COUPLED SYSTEM OF DIFFERENTIAL EQUATIONS, USING C PIECEWISE MATRIX POWER SERIES REPRESENTATION OF THE SOLUTION, WITH C THE CORRECT EXPANSION AT THE ORIGIN. C WORKS FOR POTENTIALS EXPANDED IN GENERAL POWER-TYPE EXPANSIONS C IN HYPERRADIUS, AND FOR CORRELATION FUNCTIONS EXPANDED IN POWER C SERIES IN HYPERRADIUS. C FINDS THE EIGENVALUE AND CALCULATES THE SERIES REPRESENTATION OF C THE WAVE FUNCTION. C C ****************************************************************** C * PROPAGATES TRANSPOSED R AND USES CNT (TRANSPOSED CN). * C * TRANSPOSITIONS HAVE BEEN ELIMINATED FROM THE ENERGY SEARCH * C * PART, BUT NOT FROM THE LESS CRITICAL WAVE FUNCTION PART. * C ****************************************************************** C C AUTHOR: R. KRIVEC, J. STEFAN INSTITUTE, LJUBLJANA. C C ORIGINAL VERSION (1990) WAS BASED ON PROGRAM CULON (FOR C COULOMB INTERACTION AND LINEAR F ONLY) BY M. HAFTEL, NRL. C C ****************************************************************** C * WARNINGS: * C * * C * 1. RESTART WITH LMOD = 5, 51: PARAMETERS NOT COMPARED TO THOSE * C * OF ORIGINAL RUN; RESTART INPUT FILE (UNIT NIN) OVERRIDES. * C * ALSO, MM IS DEFINED BY MATD- AND MAY NOT EQUAL THE ORI- * C * GINAL ONE IF A SMALLER MATRIX ELEMENT FILE IS USED FOR * C * RESTART. IF LMOD = 51, IINTL, IINTR ARE READ FROM UNIT * C * NOUTC. * C * 2. TABULATION WITH LMOD = 6, 7: PARAMETERS ALSO NOT COMPARED; * C * EXCEPT THAT HERE ONE OR MORE PARAMETERS NORMALLY DO DIFFER. * C ****************************************************************** C C ================================================================== C INPUT PARAMETERS C (FORTRAN convention, otherwise (I) integer, (L) logical, C (R) real, (A) Hollerith.) C C ITITLE (A) Title of output file (any text, 80 characters). C C LTDD (L) Test output by RRLSD- (long). C LTDDR (L) Writes Z0P, R(1,1), etc. to NOUT3 (short). C LTVICD (L) Test output for VICD- (long). C LTRRPS (L) Use test-output RR routine instead of the C optimized one. See Z0MTTT, etc. C LPRBIN (L) Test output by BIN-. C LPRZ0M (L) Test output by POW-. C LTCPU (L) Unused. C LTCRU (L) Test output by M2WRD- (not long). C LPRCV0 (L) (DWFPD-) Print main joining vectors (short). C LPRXX (L) (DWFPD-) Print X(+), X(-) (two matrices, long). C LPRCV (L) (DWFPD-) Print all joinig vectors (long). C LPRCVM (L) (DM1D-) Print joining system of equations C (log scale, medium long). C LPRMAT (L) (MAIXD-) Print matrices for inversion (long). C LPRWF (L) (DWFPD-) See IINTPR. Short. C LTZE (L) EWF2Z-: test output control passed to zero- C search routines. C LTZEIF (L) Additional test parameter used only if IPROG C is 1-6. C LXLAST (L) Stop zero search if last two E differ less C than EPSP. Used only if IPROG = 200. C LTDET (L) Test output by DETD- (normalization row; does C not make output file long). C LDOUBL, LDOUBM (L) Use extended precision arithmetic (MAINQ-) C for wave function CV joining vectors. C LDOUBM refers to z = ZMATCH. C IINTPR Controls at which intervals wave function is C printed (see WFPS1-). Ignored unless LPRWF = C .TRUE.. C LM Parameter that determines max. number of C determinant evaluations allowed in C zero search (in ZEROD-, originally C LM = 300 / (KM + 1)), where KM is the max. K. C IPROG Choose zero-finding algorithm for eigenvalue. C Best: 200. C IENXL The sequential number of energy value from unit C NIN20 to be taken (LMOD = 5, 6; ignored if C LMOD = 51). If negative or larger than the C number of E values in the file, it is ignored. C Enables using best value from iteration file C if the best value file was not written due to C some error on previous run. (For example, C if the program stops during wave function C calculation because of too small disk space, C the best E value is usually the one before the C last in the iteration file. On the other hand, C if the best value file is used, IENXL is C irrelevant as it should be.) C IPWUU Maximum power of rho in the W expansion C to be used in the calculation. It is C compared to the available number of C powers and reduced if necessary; a C warning is printed in that case. C NSU The number of rows/columns of the C W matrix to be used, after the W matrix C has been collapsed according to INUSEL. C Program checks if the last mu-value thus C included is less than the next one, if any, C otherwise program stops. If the rows/columns C are ordered so that mu is nondecreasing, C this ensures that all nu-values for a given C mu will be taken. A better parameter would C be maximum K. C INUSEL Selects a submatrix from W (for each power). C -1: use the rows/columns labelled by C negative values of nu (in M2M- this C means sine HH only), if any (stops the C program if none). C 0: use all the rows/columns. C 1: use the rows/columns labelled by C nonnegative nu values (in M2M- this C means the cosine HH only), if any (stops C the program if none). C The selection is done on the label array ISMN C accompanying the W matrices. After that, C the W arrays are collapsed. This is about C the only instance in the package that a C subroutine changes a formal parameter. C **** This version differs from COULDS in that C INUSEL is used already in the matrix element C program to contract the output file for C symmetric systems. In that case INUSEL in this C program may be 0 (no further contraction), or C equal to INUSEL from file. This is not a C critical point because M2WRDA called C by MATD- searches for the required states C explicitly. See subroutine MATD-. **** C NM Maximum power in the wave function C power series on the first rho-interval. C JMAX Maximum power in the wave function C power series on all other rho-intervals. C BC0, BC1 Defines the approximate boundary condition as C X = I, X' = (BC0 + BC1 / RHO) * I. Usually C 0.5, 0.5. C RHOUW Cutoff in RHO for W (power series treated C as zero for RHO larger than RHOUW). C A, B Zero search interval on the E axis. C EPSP Zero-search: abs. error of zero allowed; C see also LXLAST. C TOL Parameter determining the length of C rho-intervals as follows: length = C position * TOL. C (Changed definition: previously C TOL**(1/JMAX) was what is now TOL.) C DZU Maximum possible interval length. C ZM z-boundary of the first interval; C z = 2 sqrt(-2E) rho. C ZMATCH Matching z-boundary. C ZTOP Maximum z value. C NHH Number of subdivisions in the preliminary C search for sign change of the determinant. C (cannot be used in the EWF2Z-, the newer C zero search program; unnecessary anyway). C LMOD Mode switch: C 1: search for a zero on (A, B); C ENXL/U/S ignored. C 2: tabulate determinant on the interval C (ENXL, ENXU) with step ENXS, as read C by EPIO-. C 3: as 1, but with wave function output at C the last iterated energy; ENXL/U/S ignored. C 4: as 2, but with wave function output at C the first input energy (ENXL). ENXU/S C input by EPIO- are ignored. C 5: calculate the wave function using the C IENXL-th E value in the file C assigned to unit NIN20 (see below). If C the previous run aborted during iteration, C NIN20 will be the previous NOUT2 file. C (The last record in this case may not C contain the best E; see below.) C If the previous run was successful, the C previous NOUT4 file should be assigned to C NIN20. Energy from file is assigned to ENXL; C ENXU/S input by EPIO- are ignored. C Different physical file names should be used C in order not to destroy the old output. C (Restart after iteration.) C 51: as 5, but skip NOUTC write. C (Restart after iteration and first restart.) C 6: Tabulate determinant at E(1 + 10**-n), C where E is read from a file as with LMOD = 5, C and assigned to ENXL. n = 2 (ENXS) ENXU, C where ENXU/S are input by EPIO-. C 7: Tabulate determinant at several E, C where E are read from a file as with LMOD = C 5 (except IENXL is not used). The first ENXL C records are skipped, and the next ENXU C energies are used with step ENXS. C ENXL, ENXU, ENXS Determine the set of points to tabulate C determinant (see LMOD). In some cases they are C ignored or modified. C IPIO Switch between input files by M1M- or C M2M-. (M1M- calculates with the cosine HH C only; input files differ slightly.) C 0: M1M-. C 1: M2M-. C Z0MTTT Value of z for which a test output C of the power series for the solution C will be done if the (L) switch LTRRPS is C .TRUE., and if Abs(Z0M - Z0MTTT) is less C than Z0MTTD. C Z0MTTD See above. Must be chosen carefully C to obtain only one Z0M at which the C test output will be done. C IPRTTT Row of matrix element to be printed on test. C IPCTTT Column of matrix element to be printed on test. C C C ================================================================== C TYPICAL SEQUENCE OF MODES USED ON A NEW PHYSICAL SYSTEM: C 1. LOCATING ZERO OF DET(R(E)): C LMOD = 2. FIX INTRINSIC PARAMETERS TO EXPECTED GOOD VALUES, C TYPICALLY NM = 20, JMAX = 16, TOL = 0.1, DZU = 5, C ZMATCH = (Z AT AVERAGE INTERPARTICLE DISTANCES), C ZM = (ZMATCH / 10), ZTOP = (10 ZMATCH). FOR HE ATOM, ZTOP C IS OF THE ORDER OF 100. FOR SYSTEMS LIKE E-MUON-4HE, Z C SCALE IS CHANGED BY MUON, AND ZTOP HAS TO BE OF THE ORDER C OF 1000 (100 TIMES SQRT(MASS(MUON)/MASS(E)). C 2. FIND ZERO OF DET(R(E)): C LMOD = 1. C 3. DETERMINING GOOD PARAMETERS: C PROVIDED INITIAL PARAMETERS WERE REASONABLE, USE LMOD = 7 C TO CALCULATE DET(R(E)) WITH CHANGED PARAMETERS AT ONE OR MORE C ENERGIES FROM PREVIOUS RUN, CLOSE TO ZERO OF DET(R(E)). C TYPICALLY, ENERGY SHOULD AGREE IN AT LEAST 9 SIGNIFICANT C DIGITS WITH THE ZERO. FROM THIS (USING PROGRAMS DEDDM-, C DEDXM-), ESTIMATE CHANGE OF ZERO OF DET(R(E)) DUE TO CHANGED C PARAMETERS. SOMETIMES IT IS BETTER, ALTHOUGH MORE TIME C CONSUMING, TO RUN ANOTHER FULL ZERO SEARCH. C 4. WAVE FUNCTION: C WHEN REASONABLY GOOD PARAMETERS ARE FOUND, USE LMOD = 3 TO C FIND ZERO AND CALCULATE W.F., OR LMOD = 5 IF THE ZERO IS C KNOWN. THIS MAY HAVE TO BE REPEATED FOR DIFFERENT PARAMETERS C TO OBSERVE THE CHANGES IN THE WAVE FUNCTION AND AVERAGES. C (USE PROGRAM AV3M- TO CALCULATE AVERAGES.) NOTE THAT THE C FINDING OF THE ZERO OF DET(R(E)) TO ALMOST MACHINE PRECISION C USUALLY REQUIRES LESS INTRINSIC PRECISION (LESS GOOD C PARAMETERS) THAN THE CALCULATION OF A VERY PRECISE WAVE C FUNCTION (THE REQUIRED INTRINSIC PRECISIONS IN BOTH CASES C DEPEND STRONGLY ON THE SYSTEM STUDIED). C C OTHER VALUES OF LMOD ARE USED IN THE CASE OF CERTAIN ERRORS. C LMOD = 4 CALCULATES THE WAVE FUNCTION AT A PRESCRIBED ENERGY C ENTERED BY HAND IN THE FORMATTED INPUT FILE; NORMALLY THE GOOD C ENERGY SHOULD BE AVAILABLE FROM A PREVIOUS RUN AND LMOD = 5 WOULD C BE USED (MORE PRECISE, UNFORMATTED E) INSTEAD OF LMOD = 4. C LMOD = 6 IS USED IF ONE WANTS TO FOLLOW PREDICTIONS OF ENERGY C CHANGE WITH CHANGED PARAMETERS, AS ONE NEARS THE ZERO OF C DET(R(E)), BUT IT REQUIRES REPEATING THE RUN FOR ALL SETS OF C PARAMETERS WHILE LMOD = 7 USES ENERGIES FROM OLD RUNS. C LMOD = 51 IS USED IF A PREVIOUS RUN WITH LMOD = 5 FAILED, BUT C THE UNIT NOUTC FILE WAS WRITTEN. C C C ================================================================== C I/O UNITS: C NOUT - STANDARD OUTPUT. C NOUT2 - UNFORMATTED; DET(E) (FOR PLOTTING). C NOUT2A - FORMATTED; DET(E) (FOR PLOTTING). C NIN20 - UNFORMATTED; E VALUE(S) OF A PREVIOUS RUN (USED IF C LMOD = 5, 51, 7). THE FILE ASSIGNED TO C THIS UNIT MAY BE AN OLD NOUT2 FILE, OR C AN OLD NOUT4 FILE. NOTE THAT C NOUT2 IS WRITTEN BY DD- WHICH MEANS C THAT THE LAST E VALUE WRITTEN MAY NOT C BE THE BEST ONE BECAUSE IT MAY HAVE C BEEN REJECTED BY THE ZERO FINDING C ROUTINE DUE TO INCREASE IN DET(E). C SEE COMMENT FOR LMOD = 5, 51 ABOVE. C NOUT3 - FORMATTED; R(1,1)(Z) (FOR PLOTTING). C NOUT4 - UNFORMATTED; THE BEST E OBTAINED ON SUCCESSFUL END. C NOUTA - UNFORMATTED; ARRAYS CN, PM FOR X(Z), INTERVAL 1 C (PREVIOUSLY: ALL INTERVALS - TOO LONG). C THIS FILE IS ONLY USED AS AN EXTERNAL C MEMORY INSIDE DD-- TO PASS DATA FROM C RRLSD- TO WFPS0- IN THE CALL IN WHICH C THE WAVE FUNCTION IS OUTPUT TO UNIT C NOUTB. C NOUTB - UNFORMATTED; WAVE FUNCTION DATA. CONTENTS: C 1. PARAMETERS OF THIS PROGRAM; C 2. PASSED PARAMETERS OF M. ELEM. PROG.; C 3. XOMEGA,..., STATE Q. NUMBERS (MATD-); C 4. ENERGY (EWF2-); C 5. W. F. ARRAYS BY WFPS0-, WFPS1-. C NOUTC - UNFORMATTED, DIRECT ACCESS; X(Z). C C C ================================================================== C PART OF COMMENT FROM PROGRAM CULON BY M. HAFTEL: C C EPSP = ABSOLUTE ACCURACY YOU DESIRE FOR THE WAVE FUNCTION (DO NOT C TAKE THIS TOO PRECISELY - RECOMMENDED VALUE: 1.0E-20; SMALLER C VALUES WILL DECREASE CPU TIME, BUT SIGNIFICANT NUMERICAL ERROR C COULD BE PRODUCED). C C COMMENT FROM FUNCTION D BY M. HAFTEL: C C THIS FUNCTION IS THE DETERMINANT OF THE DISCONTINUITY OF THE R C MATRIX AT Z=ZMATCH (Z=2*KAPPA*RHO, KAPPA=SQRT(2E)); C THE R MATRIX IS x'*x**(-1), WHERE x IS THE SOLUTION MATRIX, C AND x' IS Dx/DZ; x SATISFIES THE MATRIX DIFFERENTIAL EQUATION: C D2x/DRHO**2+1/RHO*Dx/DRHO-(KAPPA**2+ C +(2*u+2)**2/RHO**2)*x-D0*Dx/DRHO-F*x/RHO-F0*x=0; (u="MU"=K/2); C (x,D0,F,F0 ARE ALL MM*MM MATRICES WHERE MM=NUMBER OF HH STATES) C THE PHYSICAL WAVE FUNCTION (xPHYS) IS DETERMINED BY MATCHING TWO C MATRIX SOLUTIONS (x- AND x+) WHICH ARE MATRIX SOLUTIONS ON C (0,ZMATCH), AND (ZMATCH,ZTOP) RESPECTIVELY, AND THEIR DERIVATIVES; C THE REQUIRED MATCHING EQUATIONS ARE: C xPHYS(ZMATCH)(-)=x-*B(-)=xPHYS(ZMATCH)(+)=x+*B(+) C xPHYS(ZMATCH)'(-)=x-'*B(-)=xPHYS(ZMATCH)'(+)=x+'*B(+) C FOR NONTRIVIAL SOLUTIONS TO EXIST, DET(R(-)-(R+))=0 WHERE C R=x'*x**(-1). C TO SOLVE FOR x THE REGION (0,ZMATCH) IS DIVIDED INTO INTERVALS, C THE FIRST OF WHICH IS (0,ZM); THE EQUATIONS ARE INTEGRATED OVER C THESE INTERVALS; THEN THE EQUATIONS ARE INTEGRATED OVER INTERVALS C COVERING (ZMATCH,ZTOP), STARTING AT ZTOP AND INTEGRATING INWARD C TO ZMATCH; IN EACH INTERVAL THE EQUATIONS ARE INTEGRATED BY USING C A TAYLOR SERIES EXPANSION ABOUT A POINT Z0 (DENOTED Z0M IN THE C PROGRAM) WHICH IS EITHER THE MINIMUM Z OF THE INTERVAL (FOR THOSE C LEFT OF ZMATCH) OR THE MAXIMUM Z OF THE INTERVAL (RIGHT OF C ZMATCH); AT THE Z0 POINT OF EACH INTERVAL x(Z0) IS SET EQUAL TO C THE IDENTITY; x'(Z0) IS SET EQUAL TO x'(Z0)*x**(-1)(Z0) AS C EVALUATED FROM THE TAYLOR SERIES OF THE PREVIOUS INTERVAL; C THEREFORE x IS NOT CONTINUOUS ACROSS INTERVAL BOUNDARIES, C BUT R IS. R IS NUMERICALLY A MORE STABLE QUANTITY THAN EITHER C x OR x' SEPARATELY, AND PROPAGATING R IS SUFFICIENT FOR EVALUATING C THE DET OF ITS DISCONTINUITY AT ZMATCH, WHICH IS ALL THAT IS C NECESSARY TO DETERMINE THE ALLOWED ENERGY; C THE TAYLOR SERIES COEFFICIENTS ARE DETERMINED FROM RECURSION RELA- C TIONS COMING FROM THE DIFFERENTIAL EQUATION, PROVIDING A TAYLOR C SERIES EXPANSION OF THE POTENTIAL TERMS (INCLUDING COULOMB AND C CENTRIFUGAL TERMS) IS ALSO MADE; THE TAYLOR SERIES WILL BE DENOTED C AS x(I,J)=SUM(N)(C(I,J;N)*(Z-Z0)**N), OR, IN MATRIX NOTATION, C x=SUM(N)(C(N)*(Z-Z0)**N); (HENCEFORTH C(I,J;N) WILL REFER TO C MATRIX ELEMENTS OF C(N), AND C(N) WILL REFER TO THE MATRIX C ITSELF); THE ARRAY CN(I,J,K) STORES THE MATRIX ELEMENTS OF C(N), C BUT K IS NOT ALWAYS EQUAL TO N+1 [ALTHOUGH USUALLY IT IS]); C ON THE FIRST INTERVAL (0,ZM) THE USUAL POWER SERIES DOES NOT WORK; C A SOLUTION OF THE FORM x=SUM(N)(C(N)*Z**(N+MU+P)) IS NECESSARY, C WHERE MU IS A DIAGONAL MATRIX: MU(I,J)=MU(I)*DELTA(I,J), AND C P IS NONVANISHING BELOW THE DIAGONAL; (SEE V.B. MANDELZWEIG, C PHYS. LETT 78A, 25, 1980; THE DIFFERENCES HERE ARE THAT WHAT HE C CALLS CAP LAMDA I CALL MU, AND OUR EQUATIONS ARE ALL TRANSPOSED C FROM HIS;[MU(J)=2*u(J)+2=K(J)+2] ); VICTOR'S PAPER GIVES RECURSION C RELATIONS FOR C(N), WHICH INVOLVE THE MATRIX P, AND ALSO RELATIONS C TO CALCULATE P (WHICH ALL BE TRANSPOSED, AND REEXPRESSED WITH THE C Z VARIBLE); IN THE CFHHM THERE ARE EXTRA TERMS ON THE RHS OF C VICTOR'S EQUATIONS (8), (10), AND CORRESPONDING CHANGES IN (11); C IN THE TRANSPOSED FORM THESE EQUATIONS ARE (BEFORE CHANGE IN C VARIABLES TO Z): C E(N)=KAPPA**2*C(N-2)+SUM(M=-1,N-2)(W(M)*C(N-M-2)+D(M) C *(N+MU-M-1)*C(N-M-1)) C F(K,I;N)=E(K,I;N)-SUM(L)(C(K,L;N+MU(I)-MU(L)) C *(2*(N+MU(I))*P(L,I) C +(P**2)(L,I)) C +SUM(M,J)(D(K,J;M)*C(J,L;N+MU(I)-MU(L)-M-1)*P(L,I))) C WHERE W(M) (M=-1...(NM-2)) ARE "POTENTIAL" COEFFICIENTS OF RHO**M, C AND D(M) (M=0...(NM-1)) ARE "POTENTIAL COEFFICIENTS OF C RHO**M*Dx/DRHO. C (END OF ORIGINAL COMMENT.) C C C ================================================================== C SHORT DESCRIPTION OF SUCCESSIVE CHANGES: C C 1. THE PROGRAM IS ABLE TO READ INTEGER-MASS FILES BY M1MF . C 2. IT CONTAINS AN OPTIONAL CALL TO RRPSJT (TEST OUTPUT). C 3. INUSEL : SELECTS STATES: C -1: NEGATIVE-NU ALIAS SINE STATES; C 0: ALL STATES; C 1: NONNEGATIVE-NU ALIAS COSINE STATES. C (IF THE INPUT FILE DOES NOT CONTAIN ANY REQUIRED C STATES, PROGRAM ABORTS.) C THE RADIAL EQUATION PROGRAMMED EXPECTS THE STATES C TO BE DEFINED WITH COSINES (NONNEGATIVE-NU) AND SINES C (NEGATIVE-NU); I.E., THE REAL HH MUST BE USED. IF C THE INPUT IS BY M1MF (Y-BASIS), I.E., IPIO = 0, C MATD- WILL TAKE CARE THAT THE PARAMETERS INUSEL, C IPOS, PSYM MAKE SENSE (ONLY SYMMETRIZED STATES ACCEPTED). C 4. NEW DEFINITION OF TOL (NEW TOL = (OLD TOL)**(1/JMAX); C THIS REMOVES JMAX DEPENDENCE). C 5. PARAMETER DZU MAXIMIZES THE INTERVAL LENGTHS. C 6. PARAMETERS ISYM, ISYMA SAVE SPACE (SEE BELOW). C 7. PARAMETER RHOUW IS A CUTOFF IN RHO FOR W . C 8. WAVE FUNCTION CALCULATION INCLUDED. ALSO TO BE USED FOR C ENERGY SEARCH ONLY, WITHOUT LOSS OF SPEED. C (SEE PARAMETER LMOD .) C 9. SHORTENS ONE LONG OUTPUT FILE (FOR ARRAY CN); SEE DD- . C 10. NDPA SAVES SPACE. C 11. COMMON STATEMENTS WITH CORRESPONDING DIMENSION DECLARATIONS C REMAIN IN DD- ONLY BECAUSE OTHERWISE EWF2Z- WOULD HAVE C TO TRANSFER A LOT OF ARRAYS. C 12. PARAMETER MACHN IN COMMON DENOTES THE TYPE OF MACHINE. C 13. CFC004 ADDED, FOR GENERAL NONLINEAR F AND EXACT OR MODIFIED C CUSPS INCLUDED. CFC005 ADDED (FLEXIBLE, OPTIONALLY EXACT-CUSP C ROUTINE, NO ASYMPTOTIC CONDITIONS ON C.F.). C 14. EWF2Z- (MANY ALGORITHMS FOR ZERO FINDING). C 15. UNIT NOUT4 ADDED (BEST E). C 16. ELIMINATED ARRAYS WS, WD (SEE MATD-). C M1MIOE READS IN ONLY THE NUMBER OF POWERS THAT FIT INTO C EMW, EMWD. NDSA, NDPA ELIMINATED; THERE IS NOW A SINGLE C DIMENSION FOR STATES AND POWERS (NDS, NDP). C 17. NM, JMAX ALIGNED ON LONGWORD BOUNDARY IN COMMON. C 18. LDOUBL, LDOUBM CONTROL WORD LENGTH FOR WAVE FUNCTION JOINING. C 19. ADDED DET(R) TABULATION AT CHANGING E SCALE. W. F. FILE C HEADER BY EPIO- IS WRITTEN UNNECESSARILY EVEN IF NO W. F. IS C CALCULATED BECAUSE EPIO- DOES NOT WANT TO INTERPRET LMOD. C 20. UNIT NOUT2A ADDED (FORMATTED, FOR GNUPLOT). C 21. DETDE: DOES NOT NORMALIZE DETERMINANTS FROM WAVE FUNCTION C CALCULATION. C 22. ADDED LMOD = 51: SKIP WRITING OF NOUTC FOR FASTER RESTART FROM C DWFPD-. DO NOT DELETE FILE/UNIT NOUTC IF RUN ABORTS AFTER C WRITING IT, TO ENABLE RESTART. (93/10/19, PROBLEMS WITH BUS C ERROR, DM1DD.) RT(-) - RT(+), IINTL, IINTR APPENDED TO UNIT C NOUTC TO ENABLE RESTART FROM DWFPD- (PREVIOUSLY IN COMMON). C 23. LMOD = 7 ENABLES DE/DD TESTS USING A PREVIOUS ITERATION AS C A SOURCE OF E VALUES. C 24. IENXL: THE SEQUENTIAL NUMBER OF ENERGY VALUE FROM UNIT NIN20 C TO BE TAKEN. C 25. LMOD = 7: ENXL/U/S USED TO DETERMINE WHICH ENERGIES TO TAKE C (SEE EWF2Z-). C 26. I0 (DM1DE,...) IS INPUT PARAMETER. C C CHARACTER*6 NAME DATA NAME / 'EWF2N ' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 94/10/20; -M 1.7C, 94/06/09. -L, 2.1. ' / C ------------------------------------------------------------ C C ================================================================== C C PARAMETERS, DIMENSIONS, COMMON: C C ALL DIMENSION DECLARATIONS, INCLUDING THOSE FOR COMMON , ARE C DEFINED BELOW IN THE PARAMETER STATEMENTS. DIMENSIONS THAT C APPEAR IN COMMON IN SUBPROGRAMS ARE DEFINED BY PARAMETER C STATEMENTS THERE; BUT THIS PROGRAM ALSO PLACES REFERENCE C DIMENSIONS IN THE COMMON AREA / REFDIM / SO THAT ALL THE C DIMENSIONS DECLARED IN THE SUBPROGRAMS ARE CHECKED, AND ALL C SUBPROGRAMS ABORT IF A MISMATCH IS FOUND. C C MACHN : ENABLES AUTOMATIC ADJUSTMNENTS OF OPEN STATEMENTS TO C DIFFERENT MACHINES. IT DOES NOT YET AUTOMATICALLY ADJUST C THE CONSTANTS IN THE ROUTINES CDX--- AND CQX--- BECAUSE C NO SIMPLE WAY WAS FOUND TO DO THAT (EXCEPT FOR EXPLICIT C SEARCH). THESE HAVE TO BE ADJUSTED BY HAND. OTHER USES OF C MACHN ARE POSSIBLE (IT IS PLACED IN A COMMON BLOCK). (SEE C OPEN STATEMENTS IN DD- AND DWFPD- .) C 1: VAX-TYPE MACHINE C 2: CONVEX-TYPE MACHINE C 3: IBM-TYPE MACHINE. C C PARAMETERS FOR MATRIX ELEMENT INPUT: C EXAMPLE: COULOMB POTENTIAL, LINEAR F: NDP0 AT LEAST 3 C (FOR POWERS (-1, 0, 1)); NDP AT LEAST 2 (FOR POWERS -1, 0). C NOTE: NDCN MUST BE AT LEAST NM + 2 (SEE DD- TEST). C FOR OTHER CASES SEE M2M- COMMENT. C C ISYM : MUST BE EITHER 0 OR 1; IF 0, DIMENSIONS WILL BE C DEFINED TO ACCEPT ALL HH STATES; IF 1, DIMENSIONS FOR COSINE-HH C ONLY WILL BE DEFINED. C C NDP0 MUST CORRESPOND TO THE MATRIX ELEMENT FILE; NDP, NDMU C MAY SPECIFY SMALLER DIMENSIONS (SEE M1MIO-). C C C PARAMETERS WHICH MAY BE CHANGED. C -------------------------------- C PARAMETER (NOUT1 = 0, NIN1 = 3, NOUT4 = 8, NIN20 = 7, 1 NDFPAR = 20, NDVPAR = 20, 2 NDP = 2, NDP0 = 3, NDCN = 22, 3 NDMU = 21, ISYM = 1, 4 NDINT = 1200, 5 MACHN0 = 2) C C C PARAMETERS WHICH SHOULD N O T BE CHANGED. C ------------------------------------------- C PARAMETER (NDS = (1 - ISYM) * (NDMU * (NDMU + 1) / 2) 1 + ISYM * (((NDMU + 1) / 2) ** 2) , 2 NDML = 2 * (NDMU - 1) + 1, 3 NDWK = NDVPAR / 2) PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0, HALF = 0.5D0, 1 NINX = 1, NOUTX = 2) C C C DECLARATIONS. C ------------- C C MATD-: INTEGER ISMN(2,NDS) DIMENSION XOMEGA(3), XKAPPA(3), 1 FPAR(3,NDFPAR), FZZZ(3,NDP0), 2 VPAR(3,NDVPAR), VZZZ(3,NDP0), WK(3,NDWK), 3 ICONTR(NDS) C C DWFPD-: DIMENSION XX(NDS,NDS), 1 RX(NDS,NDS), RX1(NDS,NDS), 2 RXL(NDS,NDS), RXR(NDS), CHI0(NDS), 3 INDEX(NDS,2), IPIVOT(NDS), PIVOT(NDS), 4 Z1(NDS), WORK1(NDS), PR1(NDS), IPVT(NDS) C ************** REAL*16 RXLD(NDS,NDS), RXRD(NDS), CWFD(NDS), 1 PIVOTX(NDS) C ************** LOGICAL LDOUBL, LDOUBM C C LTCFC, LTVC ARE UNDEFINED AND UNUSED IN THIS PROGRAM. LOGICAL LTDD, LTDDR, LTVICD, LTRRPS, LPRBIN, LPRZ0M, LTCPU, 1 LTCRU, LTCFC, LTVC, LOUTA, LOUTB, LOUTC, 2 LPRCV0, LPRXX, LPRCV, LPRCVM, LPRMAT, LPRWF, 3 LXLAST, LTZE, LTZEIF, LTDET DIMENSION ITITLE(20) C DIM. 2 NEEDED TO FOOL COMPILER. LARGER DIMENSION WOULD BE NEEDED C ONLY IF MORE ZEROS WERE SEARCHED FOR, BUT A SINGLE ONE IS ALWAYS C REQUIRED. DIMENSION ZE(2), PR(2), DD(2) C REAL*8 DDAA EXTERNAL DDAA C C C COMMON: C ------- C C ****************************************************************** C COMMON / MACH / MACHN COMMON / REFDIM / NRDS, NRDP, NRDCN, NRDML, NRDINT COMMON / VM / MM COMMON / IO / NIN, NOUT, NOUT2, NOUT3, NOUTA, NOUTB, NOUTC, 1 NOUT2A COMMON / TESTIO / LTDD, LTDDR, LTVICD, LTRRPS, LPRBIN, LPRZ0M, 1 LTCPU, LOUTA, LOUTB, LOUTC, LPRWF, LTDET COMMON / DETOPT / NREADE COMMON / ENERGY / ENXL, ENXU, ENXS COMMON / SOF / MA COMMON / NM / ZM, ZMATCH, TOL, DZU, ZTOP, 1 BC0, BC1, RHOUW, NM, JMAX COMMON / TESTZ / Z0MTTT, Z0MTTD, IPRTTT, IPCTTT COMMON / INTERV / IINT, IINTL, IINTR, IINTPR COMMON / RR / SUM(NDS,NDS) COMMON / COEF / CN(NDS,NDS,NDCN), PM(NDS,NDS), 1 DML(NDS), CV(NDS,NDINT), 2 WF(NDS), WFD(NDS), WFL(NDS), WFDL(NDS), 3 WFC(NDS,NDCN) COMMON / MEL / EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP), 1 IPXU, IPOFF COMMON / MU / MU(NDS) C C ****************************************************************** C C WRITE (NOUTX,4000) NAME, VERS, 1 NDP, NDP0, NDCN, NDMU, ISYM, NDINT, MACHN0, 2 NDS, NDML CPU0 = ZERO CALL TEMPD(CPU0, CPU1, CPUD, NOUTX, .TRUE.) C C C ****************************************************************** C C REFERENCE PARAMETERS FOR COMMON DECLARATIONS IN SUBPROGRAMS. C THESE ARE PLACED IN COMMON SO THAT THE SUBPROGRAMS CAN C CHECK THE DIMENSIONS IN COMMON . C DO NOT CHANGE THESE STATEMENTS; SEE PARAMETER DEFINITIONS ABOVE. C IF A SUBPROGRAM REPORTS A REFERENCE DIMENSION MISMATCH, CHANGE C THE DIMENSION IN THAT SUBPROGRAM, NOT IN THIS PROGRAM. NRDS = NDS NRDP = NDP NRDCN = NDCN NRDML = NDML NRDINT = NDINT C C UNIT NUMBERS TO BE PASSED TO COMMON . NIN = NINX NOUT = NOUTX NOUT2 = 4 NOUT2A = 14 NOUT3 = 5 NOUTA = 30 NOUTB = 20 NOUTC = 40 C C MACHINE TYPE. MACHN = MACHN0 C C ****************************************************************** C C C ================================================================== C PARAMETER TESTS. IF (MACHN .LT. 1 .OR. MACHN .GT. 3) CALL ERR2(NAME, 1, 1, NOUT) IF (ISYM .LT. 0 .OR. ISYM .GT. 1) CALL ERR2(NAME, 2, 1, NOUT) C C C ================================================================== C PARAMETER INPUT/OUTPUT. C READ (NIN,1000) ITITLE READ (NIN,1010) LTDD, LTDDR, LTVICD, LTRRPS, LPRBIN, LPRZ0M, 1 LTCPU, LTCRU READ (NIN,1010) LPRCV0, LPRXX, LPRCV, LPRCVM, LPRMAT, LPRWF READ (NIN,1010) LTZE, LTZEIF, LXLAST READ (NIN,1010) LTDET READ (NIN,1010) LDOUBL, LDOUBM READ (NIN,1020) IINTPR READ (NIN,1020) LM, IPROG READ (NIN,1020) IENXL READ (NIN,1020) I0D C WRITE (NOUT,4100) ITITLE, 1 LTDD, LTDDR, LTVICD, LTRRPS, LPRBIN, LPRZ0M, 2 LTCPU, LTCRU, 3 LPRCV0, LPRXX, LPRCV, LPRCVM, LPRMAT, LPRWF, 4 LTZE, LTZEIF, LXLAST, LTDET, LDOUBL, LDOUBM, 5 IINTPR, LM, IPROG, IENXL, I0D C MODE = 1 NIN1E = 0 CALL EPIOA(MODE, NIN, NOUT, NIN1E, NOUTB, 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, A, B, EPSP, TOL, DZU, 3 ZM, ZMATCH, ZTOP, NHH, 4 LMOD, ENXL, ENXU, ENXS, 5 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT) C C TESTS. IF (ZMATCH .LE. ZM) CALL ERR2(NAME, 3, 1, NOUT) IF (ZMATCH .GE. ZTOP) CALL ERR2(NAME, 4, 1, NOUT) IF (TOL .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (DZU .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) C C C ================================================================== C MATRIX ELEMENT INPUT. MA = 2 KM + 1 IS PASSED TO DD- VIA COMMON. C C ENTER MATRIX ELEMENTS IF LMOD = 3, 4, 5, 51. IF ((LMOD .GE. 3 .AND. LMOD .LE. 5) .OR. LMOD .EQ. 51) THEN C WRITE HEADER TO WAVE FUNCTION FILE. MODE1 = 4 ELSE C INPUT ONLY. MODE1 = 3 ENDIF CALL MATDN(NDS, NDP, 1 NDFPAR, NDVPAR, NDWK, NDP0, 2 MODE1, NIN1, NOUT, NOUTB, IPIO, LTCFC, LTVC, 3 IPWUU, INUSEL, NSU, LTCRU, 4 ISMN, EMW, EMWD, 5 XOMEGA, XKAPPA, FPAR, FZZZ, VPAR, VZZZ, 6 WK, ICONTR, IPXU, IPOFF, MU, MM, MA) C C C ================================================================== C INITIALIZATIONS. C C MAX. VALUE OF DETERMINANT TO BE USED TO STOP FURTHER SEARCH. C LOOK FOR ONLY ONE ZERO OF DET(E). EPSF = ZERO NN = 1 C C MIN AND MAX KAPPA. SKA = SQRT(TWO * A) SKB = SQRT(TWO * B) C C INTERVAL BETWEEN SUCCESSIVE EVALUATIONS ON FIRST PHASE OF SEARCH. HH = .9999 * (SKB - SKA) IF (NHH .GT. 1) HH = .9999 * (SKB - SKA) / (NHH - 1) CALL TEMPD(CPU1, CPU2, CPUD, NOUT, .TRUE.) CALL CDXFBO(NOUT) C C C ================================================================== C EITHER TABULATION OR SEARCH FOR ZERO OF DETERMINANT. C OPTIONALLY CALCULATE THE WAVE FUNCTION. THE PROGRAM CAN BE C RESTARTED FROM DIFFERENT POINTS BELOW, AS CONTROLLED BY LMOD . C IF (LMOD .EQ. 5 .OR. LMOD .EQ. 51 .OR. LMOD .EQ. 6) THEN C C -------------------------------------------------------------- C READ ENXL FROM UNFORMATTED FILE (FIRST POSITION IN RECORD). C MODIFIES INPUT VALUE OF ENXL . READ THE IENXL-TH ENERGY VALUE C FROM THE UNFORMATTED FILE WITH TABULATED DETERMINANT AS C FUNCTION OF ENERGY, WRITTEN ON A PREVIOUS RUN WHICH ABORTED C FOR SOME REASON (ITERATION FILE), OR FROM THE UNFORMATTED C FILE WRITTEN BY THIS PROGRAM AFTER A SUCCESSFUL RUN (BEST E C VALUE FILE). IF BEST VALUE FILE IS USED, IENXL IS IRRELEVANT. C LMOD = 5, 51 (FOR WAVE F.): ENXS, ENXU WILL BE MODIFIED LATER. C LMOD = 6 (FOR TABULATION): INPUT ENXS, ENXU WILL BE USED. C **** PARAMETERS ARE NOT CHECKED FOR AGREEMENT **** C ENXL = -CDXMAX() WRITE (NOUT,4300) I = 0 10 CONTINUE I = I + 1 READ (NIN20,ERR=20,END=20) ENXL WRITE (NOUT,4302) I, ENXL, ENXL IF (LMOD .NE. 51 .AND. I .EQ. IENXL) THEN WRITE (NOUT,4306) GO TO 20 ENDIF GO TO 10 20 CONTINUE IF (ENXL .EQ. -CDXMAX()) CALL ERR2(NAME, 8, 1, NOUT) WRITE (NOUT,4304) CALL CDXFBO(NOUT) ENDIF NREADE = -1 ITC = 0 ITCI = 0 IF (LMOD .EQ. 1 .OR. LMOD .EQ. 2 .OR. 1 LMOD .EQ. 3 .OR. LMOD .EQ. 6 .OR. LMOD .EQ. 7) THEN C C -------------------------------------------------------------- C CALCULATE DET(E), NO WAVE FUNCTION-RELATED CALCULATIONS IN C THIS SECTION (DONE LATER FOR CERTAIN LMOD VALUES). C EWF2Z- TABULATES DET(E) OR FINDS A ZERO OF DET(E). C VALUE OF NREADE CONTROLS THE USE OF ENXL/U/S . C C LMOD = 1: SEARCH FOR EIGENVALUE (ZERO OF DET(R)). C LMOD = 2: INPUT E (EQUIDISTANT TABULATION). C LMOD = 3: SEARCH E. (W.F. OUTPUT AT SUBSEQUENT CALL.) C LMOD = 6: INPUT E (TABULATION AT DECREASING E SCALE). C LMOD = 7: INPUT E FROM ANOTHER RUN (FOR TABULATION). IF (LMOD .EQ. 1) NREADE = 0 IF (LMOD .EQ. 2) NREADE = 1 IF (LMOD .EQ. 3) NREADE = 0 IF (LMOD .EQ. 6) NREADE = 2 IF (LMOD .EQ. 7) NREADE = 3 IF (LMOD .EQ. 7) WRITE (NOUT,4304) LOUTA = .FALSE. LOUTB = .FALSE. LOUTC = .FALSE. CALL EWF2ZC(DDAA, SKA, SKB, LM, HH, EPSF, EPSP, DD, ZE, PR, 1 NN, 2 ENXL, ENXU, ENXS, NOUT, NIN20, 3 NREADE, IPROG, ITCI, 4 LXLAST, LTZE, LTZEIF) IF (IINT .GT. NDINT) THEN C TOO MANY INTERVALS (NUMBER UNKNOWN BEFORE). C PREVENT FURTHER CALCULATIONS, BUT OUTPUT CPU TIME. CALL TEMPD(CPU2, CPU3, CPUD, NOUT, .TRUE.) CALL TEMPD(CPU0, CPUT, CPUD, NOUT, .TRUE.) CALL ERR2(NAME, 9, 1, NOUT) ENDIF ENDIF CALL TEMPD(CPU2, CPU3, CPUD, NOUT, .TRUE.) IF (LMOD .EQ. 3 .OR. LMOD .EQ. 4 .OR. LMOD .EQ. 5 .OR. 1 LMOD .EQ. 51 ) THEN CALL TEMPD(CPU0, CPU31, CPUD, NOUT, .FALSE.) C C -------------------------------------------------------------- C (RE)EVALUATE DETERMINANT AND CALCULATE WAVE FUNCTION. C LMOD = 3, 5, 51: CALL WITH THE LAST ITERATED ENERGY. C LMOD = 4: CALL WITH THE FIRST INPUT ENERGY, ENXL (EPIO-). C C MODIFY THE INPUT VALUES OF ENXS, ENXU ; ENXL IS MODIFIED C ONLY IF LMOD = 3 . WRITE ENERGY TO THE WAVE FUNCTION FILE. IF (LMOD .EQ. 3) ENXL = HALF * ZE(NN) ** 2 ENXU = ENXL + ONE ENXS = TWO C ------------------ WRITE (NOUTB) ENXL C ------------------ WRITE (NOUT,4400) ENXL C C CONTROL VARIABLES FOR DD-. NREADE = 1 LOUTB = .TRUE. IF (LMOD .NE. 51) THEN C C THE CALL TO STORE X(Z) TO UNIT NOUTC . LOUTB IGNORED. C THIS CALL SKIPPED ON RE-RESTART BECAUSE IT ONLY SERVES C THE PURPOSE OF WRITING NOUTC . LOUTA = .FALSE. LOUTC = .TRUE. CALL EWF2ZC(DDAA, SKA, SKB, LM, HH, EPSF, EPSP, 1 DD, ZE, PR, NN, 2 ENXL, ENXU, ENXS, NOUT, NIN20, 3 NREADE, IPROG, ITC, 4 LXLAST, LTZE, LTZEIF) C (NOUTB IS PARTLY WRITTEN. NOUTC IS FINISHED.) ENDIF CALL TEMPD(CPU31, CPU32, CPUD, NOUT, .TRUE.) C C MATCH THE WAVE FUNCTION AND PROPAGATE TRANSFORMATION VECTORS. C X(Z), RT(-)-RT(+), IINTL, IINTR ARE READ FROM UNIT NOUTC . C (THE PROGRAM IS RESTARTED FROM HERE IF NOUTC WAS KEPT, BY C JUST SKIPPING THE ABOVE DD- CALL. NOUTC IS REFERRED TO ONLY C IN THIS PROGRAM BLOCK.) THIS CALL IS FAST COMPARED TO C LMOD = 5 CALL. C MM MAY BE CUT OFF BY MATD- IF A DIFFERENT MATRIX C ELEMENT FILE IS USED TO RESTART THE PROGRAM (LMOD = 5). C THE ARRAY SUM IS RETAINED IN COMMON TO AVOID DOUBLE SPACE C ALLOCATION. IINTL, IINTR MUST BE PUT IN COMMON BY DWFPD- C FOR SUBSEQUENT USE BY DD--. CALL DWFPDF(NDS, NDINT, NOUT, NOUTC, 1 ZMATCH, MM, SUM, IINTL, IINTR, 2 XX, RX, RX1, RXL, RXR, RXLD, RXRD, 3 INDEX, IPIVOT, PIVOT, PIVOTX, 4 Z1, WORK1, PR1, IPVT, LDOUBL, LDOUBM, 5 CHI0, CWFD, 6 LPRCV0, LPRXX, LPRCV, LPRCVM, LPRMAT, LTDET, 7 I0D, J0, CV) CALL TEMPD(CPU32, CPU33, CPUD, NOUT, .TRUE.) C C THE CALL TO RECALCULATE CN AND CALCULATE WAVE FUNCTION POWER C SERIES. THIS IS STORED TO UNIT NOUTB . LOUTA = .TRUE. LOUTC = .FALSE. CALL EWF2ZC(DDAA, SKA, SKB, LM, HH, EPSF, EPSP, DD, ZE, PR, 1 NN, 2 ENXL, ENXU, ENXS, NOUT, NIN20, 3 NREADE, IPROG, ITC, 4 LXLAST, LTZE, LTZEIF) CALL TEMPD(CPU33, CPU34, CPUD, NOUT, .TRUE.) ENDIF C C E READ MODE ERROR CHECK. IF (NREADE .EQ. -1) CALL ERR2(NAME, 10, 1, NOUT) CALL TEMPD(CPU3, CPU4, CPUD, NOUT, .TRUE.) C C C ================================================================== C SUMMARY OF SEARCH FOR ZEROS. C IF (LMOD .EQ. 1 .OR. LMOD .EQ. 3) THEN WRITE (NOUT,4210) DO 30 L = 1,NN ENR = HALF * ZE(L) ** 2 WRITE (NOUT,4220) L, DD(L), PR(L), ENR WRITE (NOUT4) ENR 30 CONTINUE ENDIF IF (ITCI .GT. 0) THEN CPUI = (CPU3 - CPU2) / DFLOAT(2 + ITCI) WRITE (NOUT,4500) ITCI, CPUI ENDIF CALL TEMPD(CPU4, CPUT, CPUD, NOUT, .TRUE.) CALL TEMPD(CPU0, CPUT, CPUD, NOUT, .TRUE.) CALL EXIT STOP C ================================================================== C C 1000 FORMAT (20A4) 1010 FORMAT (20L1) 1020 FORMAT (20I4) C C 4000 FORMAT ( A 5H , A6, A60, //, B 1H , 40H NDP NDP0 NDCN NDMU ISYM, C 32H NDINT MACHN0 NDS NDML, /, D 1H , 9I8, //) 4100 FORMAT (//, A 1H , 20A4, //, B 1H , 20HINPUT PARAMETERS: , //, C 1H , 40HLTDD/R,LTVICD/RRPS,LPRBIN/Z0M,LTCPU/RU , 8L4, /, D 1H , 40HLPRCV0/XX/CV/CVM/MAT/WF/ZE/ZEIF , 8L4, /, E 1H , 40HLXLAST , L4, /, F 1H , 40HLTDET , L4, /, G 1H , 40HLDOUBL, LDOUBM , 2L4, /, H 1H , 20HIINTPR , I4, /, I 1H , 20HLM, IPROG , 2I4, /, J 1H , 20HIENXL , I4, /, K 1H , 20HI0D , I4) 4210 FORMAT (//, A 1H , 44HSUMMARY (RENORM. DET., INTERVAL LENGTH, E): , /) 4220 FORMAT ( A 1H , I4, E24.16, 4H H , E12.4, F24.16, /, B 1H , 44X, 8X, 16H--- --- ----) 4300 FORMAT (/, A 1H , 48HENERGY(IES) FROM THE PREVIOUS RUN: ) 4302 FORMAT ( A 1H , I4, E28.16, F24.16) 4304 FORMAT (/, A 1H , 48H************************************************, /, B 1H , 48H* PARAMETERS OF THE ENERGY(IES) INPUT NOT *, /, C 1H , 48H* CHECKED FOR AGREEMENT WITH THE PARAMETERS OF *, /, D 1H , 48H* THIS RUN. THE WAVE FUNCTION WILL BE CALCULA- *, /, E 1H , 48H* TED OR TABULATION DONE USING AN INPUT ENERGY *, /, F 1H , 48H* AND THE NEW PARAMETERS. *, /, G 1H , 48H************************************************) 4306 FORMAT (/, A 1H , 48H************************************************, /, B 1H , 48H* IENXL USED TO SELECT ENERGY. *, /, C 1H , 48H************************************************) 4400 FORMAT ( A 1H , 12HENERGY (WF) , E24.16) 4500 FORMAT (1H , I4, 4H + 2, 20H DET. EVALUATIONS OF, F12.2, 5H SEC.) END cdxeps.f000644 000311 000121 00000000557 05306654433 012344 0ustar00krivecf1000000 000000 FUNCTION CDXEPS() REAL * 8 CDXEPS C C ** MACHINE DEPENDENT ** C EPS (SMALLEST REAL * 8 NUMBER SUCH THAT (1.D0 + EPS) .GT. 1.D0). C C* CDXEPS = 2.D0 ** (-52) C* IBM C* CDXEPS = 2.D0 ** (-56) C* VAX CDXEPS = 2.D0 ** (-52) C* CONVEX C220 RETURN END cdxfbo.f000644 000311 000121 00000000313 05307356415 012311 0ustar00krivecf1000000 000000 SUBROUTINE CDXFBO(NOUT) C C ** MACHINE DEPENDENT ** C FLUSHES BUFFER CONTENTS ON UNIT NOUT TO OUTPUT FILE. C CALL FLUSH(NOUT) C* CONVEX C220 RETURN END cdxmax.f000644 000311 000121 00000000437 05306654640 012337 0ustar00krivecf1000000 000000 FUNCTION CDXMAX() REAL * 8 CDXMAX C C ** MACHINE DEPENDENT ** C MAXIMUM REAL * 8 NUMBER REPRESENTABLE. C C* CDXMAX = 2.D0 ** (+251) C* IBM CDXMAX = 2.D0 ** (+1022) C* CONVEX C220 RETURN END cdxtol.f000644 000311 000121 00000000537 05306654743 012355 0ustar00krivecf1000000 000000 FUNCTION CDXTOL() REAL * 8 CDXTOL C C ** MACHINE DEPENDENT ** C TOL (SMALLEST REPRESENATBLE REAL * 8 NUMBER). C CDXTOL = 2.D0 ** (-1024) C* C220 C* CDXTOL = 2.D0 ** (-126) C* VAX C* CDXTOL = 2.D0 ** (-260) C* IBM RETURN END cfc000.f000644 000311 000121 00000003074 06067231550 012022 0ustar00krivecf1000000 000000 SUBROUTINE CFC000(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), F(3,NDP0), FANA(3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC000' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 F(I,IP0X) = -ALPHA(I) FANA(I) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 2.1, 95/12/24. 2.0, 92/05/22. (1.1) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc001.f000644 000311 000121 00000004214 06067231703 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), BETA(3), GAMMA(3), F(3,NDP0), 1 FANA(3,3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) C -( ALPHA(I) + BETA(I)*EXP(-GAMMA(I)*R(I)) ) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C C C LOGICAL LCALL0 DIMENSION W(3) CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC001' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -(ALPHA(I) + BETA(I)) FANA(I,1) = -ALPHA(I) FANA(I,2) = -BETA(I) FANA(I,3) = GAMMA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 1) RETURN C C C FURTHER POWERS. DO 30 IP0 = 2,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * GAMMA(I) / DFLOAT(IP0 - 1) F(I,IP0X) = -BETA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 3.1, 95/12/24. 3.0, 92/05/22. (2.2) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc002.f000644 000311 000121 00000004452 06067232004 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC002(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, ZZ, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ZZ(3), F(3,NDP0), FANA(3) C C C C C CUSP COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C INPUT ARE MASSES AND PRODUCTS OF CHARGES (ZZ) (THIS IS C NECESSARY, FOR EXAMPLE, IF SOME PAIR INTERACTION IS TO BE PUT C TO ZERO; THEN THE CORRELATION PARAMETER IS ZERO, TOO; C THIS WOULD NOT BE POSSIBLE IF THE CHARGES THEMSELVES WERE C INPUT). C THIS PROGRAM CALCULATES CUSP COEFFICIENTS TO FULL PRECISION, C WHICH IS BETTER THAN IF THE MAIN PROGRAM WOULD READ THEM IN C AND CALL CFC000. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC002' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF C IF (XM1 .LT. 0.D0) CALL ERR2(NAME, 4, 1, NOUT) IF (XM2 .LT. 0.D0) CALL ERR2(NAME, 5, 1, NOUT) IF (XM3 .LT. 0.D0) CALL ERR2(NAME, 6, 1, NOUT) C F(1,IP0X) = ZZ(1) * XM2 * XM3 / (XM2 + XM3) F(2,IP0X) = ZZ(2) * XM3 * XM1 / (XM3 + XM1) F(3,IP0X) = ZZ(3) * XM1 * XM2 / (XM1 + XM2) FANA(1) = F(1,IP0X) FANA(2) = F(2,IP0X) FANA(3) = F(3,IP0X) C IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 5.1, 95/12/24. 5.0, 92/05/22. (4.0) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc003.f000644 000311 000121 00000004037 06067230136 012024 0ustar00krivecf1000000 000000 SUBROUTINE CFC003(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, F) IMPLICIT REAL*8 (A - H, O - Z) LOGICAL LPR DIMENSION ALPHA(3), BETA(3), F(3,NDP0) C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * EXP(-BETA(I) * R(I)), C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 0,..., IPFU (ABORTING IF IPFL .GT. 0). C C CHARACTER*6 NAME DATA NAME / 'CFC003' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/05/11. O: CFC001 2.2, 91/01/16. ' / C ------------------------------------------------------------ C C LOGICAL LCALL0 DIMENSION W(3) DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 0 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 0) RETURN C C C FURTHER POWERS. DO 30 IP0 = 1,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * BETA(I) / DFLOAT(IP0) F(I,IP0X) = -ALPHA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc004.f000644 000311 000121 00000014105 06067230137 012023 0ustar00krivecf1000000 000000 SUBROUTINE CFC004(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XE, XA, XR, XN, 3 D1, D2, D, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XE(3), XA(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE. C XE(1-3) = (E1, E2, C). E1: BINDING ENERGY OF PARTICLE 1,...; C C: ASYMPTOTIC CONSTANT IN PHI = EXP(C * RHO) FOR C THE CFHHM SMOOTH HH-EXPANED PART OF W.F. C DEPENDS C ON THE CORREL. FUNCTION AND CAN ONLY BE OBTAINED A C POSTERIORI FROM THE MATRIX ELEMENTS OF THE C EFFECTIVE POTENTIAL W, CALCULATED FROM THE OUTPUT C OF THIS ROUTINE. ONE WAY TO DO IT IS TO SEE IF C THE SAME C IS OBTAINED AS WAS INPUT TO THIS C ROUTINE, AND THUS ACHIEVE SELF-CONSISTENCY. C C CAN ALSO BE PUT TO 0, IN WHICH CASE THE C OUTPUT OF THIS ROUTINE WILL BE AS IN THE CASE C OF E+E-E- (C WAS NOT TAKEN INTO ACCOUNT). C XA(1-3) VALUES OF PARAMETERS A(I). A3 IS A FREE PARAMETER, C AND XA(1), XA(2) ARE IGNORED (RESERVED FOR FUTURE C USE). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C A(I) = (A1, A2, A3); C B(I) = (B1, B2, B3); C C(I) = (C1, C2, C3); C D1, D2, D, C WHERE C A3 = XA(3) C A1 = - ROOT(2 M2 E2) - C ROOT(M2) - A3, C A2 = - ROOT(2 M1 E1) - C ROOT(M1) - A3, C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3), C D1 = A1 + A2, D2 = ROOT(M3), C D = D1 + C D2 C (D SHOULD BE NEGATIVE IF THE TRUE C IS INPUT; IF C = 0, D MAKES C NO SENSE; D ONLY SERVES AS A CHECK; HOWEVER, FROM D1 AND D2, C THE VALUE OF D WITH C FROM THE KM = 0 EQUATION USING THE C MATRIX ELEMENTS OUTPUT FROM THIS PROGRAM, CAN BE CALCULATED). C HERE M1 IS THE REDUCED MASS OF THE PARTICLE 1 WITH RESPECT TO C THE PAIR (2,3), ETC. C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION XM(3), A(3), ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC004' / CHARACTER*60 VERS DATA VERS */ ' 2.2, 92/11/26. (1.2) ' / C ------------------------------------------------------------ C DATA ZERO, ONE, TWO / 0.D0, 1.D0, 2.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XE, XA, XR, XN ENDIF C C CALCULATE B AND A, AND D. C RESULT (B) TEMPORARILY IN F(.,1+IP0OFF). XM(1) = XM1 XM(2) = XM2 XM(3) = XM3 IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM(1), XM(2), XM(3), XZ, F, FANA) XMM1 = XM(1) * (XM(2) + XM(3)) / (XM(1) + XM(2) + XM(3)) XMM2 = XM(2) * (XM(3) + XM(1)) / (XM(1) + XM(2) + XM(3)) XMM3 = XM(3) * (XM(1) + XM(2)) / (XM(1) + XM(2) + XM(3)) A(1) = - SQRT(TWO * XMM2 * XE(2)) - XE(3) * SQRT(XMM2) - XA(3) A(2) = - SQRT(TWO * XMM1 * XE(1)) - XE(3) * SQRT(XMM1) - XA(3) A(3) = XA(3) D1 = A(1) + A(2) D2 = SQRT(XMM3) D = D1 + XE(3) * D2 C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 ALPHA(I) = - A(I) BETA(I) = - (F(I,1+IP0OFF) - A(I)) GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, D1, D2, D ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HEPS., C , 3E22.14, /, E 1H , 8HA(I) , 3E22.14, /, F 1H , 8HAV. R(I), 3E22.14, /, G 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HD1,D2, D, 3E22.14) END cfc005.f000644 000311 000121 00000011466 06067230141 012026 0ustar00krivecf1000000 000000 SUBROUTINE CFC005(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XA, XAL, XR, XN, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XA(3), XAL(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C B(I) ARE PRECISE CUSP PARAMETERS CALULATED IN THIS ROUTINE. C IT IS ALSO POSSIBLE TO REQUIRE THAT A(I) EQUAL THE CUSP PARAMETER C FOR SOME I; THEN B(I) = A(I) AND F IS LINEAR IN R(I). C BUT A(I) ARE INDEPENDENT OF EACH OTHER; NO AYMPTOTIC C CONDITIONS ARE IMPOSED. (INTENDED FOR IMPROVING ON THE LINEAR C CORRELATION FUNCTION IN CASES LIKE MU-D-T IN WHICH ASYMPTOTICS C SEEM TO BE DIFFICULT TO IMPLEMENT IN CORRELATION FUNCTION.) C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V HERE, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE (NON-FATAL CHECKS CAN C BE DONE BY THE CALLING PROGRAM). C XA(1-3) = VALUES OF PARAMETERS A(I). C XAL(1-3): IF XAL(I) = 0.0, A(I) = XA(I), AS IT IS INPUT; C ELSE A(I) IS EQUATED TO B(I). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C B1, B2, B3; C C1, C2, C3, C WHERE C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3). C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE OF F EXPANSION: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC005' / CHARACTER*60 VERS DATA VERS */ ' 2.4, 93/03/16. (1.0) ' / C ------------------------------------------------------------ C DATA ZERO, ONE / 0.D0, 1.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XA, XR, XN ENDIF C C CALCULATE B (TEMPORARILY IN F(.,1+IP0OFF)). IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM1, XM2, XM3, XZ, F, FANA) C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 IF (XAL(I) .EQ. ZERO) THEN C NONLINEAR, WITH INPUT A. ALPHA(I) = - XA(I) BETA(I) = - (F(I,1+IP0OFF) - XA(I)) ELSE C LINEAR, WITH CALCULATED A = B. ALPHA(I) = - F(I,1+IP0OFF) BETA(I) = ZERO ENDIF GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, FANA ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HA(I) , 3E22.14, /, E 1H , 8HAV. R(I), 3E22.14, /, F 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END err2.f000644 000311 000121 00000000641 05213131662 011711 0ustar00krivecf1000000 000000 SUBROUTINE ERR2(NAME, NERR, ISTOP, NOUT) CHARACTER*6 NAME INTEGER NERR, ISTOP, NOUT C IF (ISTOP .NE. 1) WRITE (NOUT,1000) NERR, NAME IF (ISTOP .EQ. 1) WRITE (NOUT,1010) NERR, NAME IF (ISTOP .EQ. 1) CALL EXIT C 1000 FORMAT (1H , 16H** ERROR (W) , I16, 6H IN , A6, 5H **) 1010 FORMAT (1H , 16H**** ERROR (F) , I16, 6H IN , A6, 5H ****) RETURN END m1miof.f000644 000311 000121 00000012652 06067230215 012236 0ustar00krivecf1000000 000000 SUBROUTINE M1MIOF(MODE, NIN1, NOUT, NOUT1, 1 NDP, NDS, NSPR, 2 XOMEGA, XKAPPA, 3 IPOFF, IPXU, INUSEL, 4 MUU, NS, ISMN, EMW, EMWD) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XOMEGA(3), XKAPPA(3), 1 ISMN(2,NDS), 2 EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP) C C C INPUT/OUTPUT OF MATRIX ELEMENTS AND ACCOMPANYING DATA. C DIFFERS FROM M1MIOB IN THAT ISIS, ISN ARE NOT INPUT/OUTPUT, C TO MAKE THE CONTRACTION OF MATRICES WHICH ACTS ONLY ON ISMN, C EMW, EMWD, CONSISTENT. DIFFERS FROM M1MIOD IN THE ADJUSTMENT C OF IXPU AND NS (READS ONLY THE NUMBER OF MATRIX ELEMENTS C THAT FIT INTO EMW/D). THIS IS DONE SO THAT IPXU0, NS0 ARE C DEFINED FOR READING (ALL RECORDS MUST BE READ), AND ARE C FINALLY TRANSFERRED INTO IPXU, NS (WHICH NO LONGER SHOW C THE NUMBER OF MATRIX ELEMENTS IN THE INPUT FILE). C C MODE ACTION C C 1 FORMATTED OUTPUT. C 2 FORMATTED AND UNFORMATTED OUTPUT. C 3 UNFORMATTED INPUT (NO OUTPUT EXCEPT WARNINGS). C C NOTE THAT MATRIX ELEMENTS ARE PRINTED "UNTRANSPOSED," I.E., C THE SECOND INDEX RUNS IN ROWS, BUT THE UNFORMATTED OUTPUT C IS WITH THE FIRST INDEX RUNNING FIRST. C C NSPR IS AN INPUT PARAMETER ENSURING THAT NOT MORE THAN C NSPR ROWS/COLUMS OF THE FINAL MATRICES ARE PRINTED, TO C PREVENT VERY LARGE OUTPUT FILES. C C LOGICAL LCALL0, LOF, LOU, LIU DATA LCALL0 / .TRUE. / C CHARACTER*6 NAME DATA NAME / 'M1MIOF' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 92/07/03 (M1MIOD 1.0) (IPXU, NS ADJUSTMENT) ' / C ------------------------------------------------------------ C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (MODE .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (MODE .GT. 3) CALL ERR2(NAME, 2, 1, NOUT) C LOF = MODE .EQ. 1 .OR. MODE .EQ. 2 LOU = MODE .EQ. 2 LIU = MODE .EQ. 3 C NSPRX = NS IF (LOF .AND. NSPR .GE. 1) NSPRX = MIN(NS, NSPR) C IF (LIU) READ (NIN1) XOMEGA, XKAPPA IF (LOU) WRITE (NOUT1) XOMEGA, XKAPPA C IF (LIU) READ (NIN1) IPOFF, IPXU, INUSEL IF (LOF) WRITE (NOUT,9100) IPOFF, IPXU, INUSEL IF (LOU) WRITE (NOUT1) IPOFF, IPXU, INUSEL C IF (LIU) READ (NIN1) MUU, NS IF (LOF) WRITE (NOUT,9200) MUU, NS IF (LOU) WRITE (NOUT1) MUU, NS C IF (LIU) THEN C DEFINE IPXU0, NS0 (TEMPORARY, FOR READING). IF (IPXU .GT. NDP) CALL ERR2(NAME, 30, 0, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 31, 0, NOUT) IPXU0 = MIN(IPXU, NDP) NS0 = MIN(NS, NDS) ELSE IF (IPXU .GT. NDP) CALL ERR2(NAME, 40, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 41, 1, NOUT) ENDIF C IF (LIU) READ (NIN1) (ISMN(1,I), ISMN(2,I), I = 1,NS0) IF (LOF) WRITE (NOUT,9202) (I, ISMN(1,I), ISMN(2,I), I = 1,NS) IF (LOU) WRITE (NOUT1) (ISMN(1,I), ISMN(2,I), I = 1,NS) C C READ SEQUENTIAL FILE (ALL RECORDS). IF (LOF) WRITE (NOUT,9300) DO 22 K = 1,IPXU IP = K - IPOFF IF (LOF) WRITE (NOUT,9302) K, IP DO 20 J = 1,NS IF (LIU) THEN IF (J .LE. NS0 .AND. K .LE. IPXU0) THEN READ (NIN1) (EMW(I,J,K), I = 1,NS0) ELSE C SKIP RECORD. READ (NIN1) BUFF ENDIF ENDIF IF (LOF .AND. J .LE. NSPRX) 1 WRITE (NOUT,9304) J, ISMN(1,J), ISMN(2,J), 2 (EMW(J,I,K), I = 1,NSPRX) IF (LOU) WRITE (NOUT1) (EMW(I,J,K), I = 1,NS) 20 CONTINUE 22 CONTINUE C IF (LOF) WRITE (NOUT,9400) DO 32 K = 1,IPXU IP = K - IPOFF IF (LOF) WRITE (NOUT,9402) K, IP DO 30 J = 1,NS IF (LIU) THEN IF (J .LE. NS0 .AND. K .LE. IPXU0) THEN READ (NIN1) (EMWD(I,J,K), I = 1,NS0) ELSE C SKIP RECORD. READ (NIN1) BUFF ENDIF ENDIF IF (LOF .AND. J .LE. NSPRX) 1 WRITE (NOUT,9404) J, ISMN(1,J), ISMN(2,J), 2 (EMWD(J,I,K), I = 1,NSPRX) IF (LOU) WRITE (NOUT1) (EMWD(I,J,K), I = 1,NS) 30 CONTINUE 32 CONTINUE IF (LIU) THEN C ADJUST IPXU, NS (HERE OUTPUT PARAMETERS). IPXU = IPXU0 NS = NS0 ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 9100 FORMAT (////, A 1H , 20HIPOFF, IPXU, INUSEL , 3I8) 9200 FORMAT (/, A 1H , 16HMUU, NS , 2I8) 9202 FORMAT (/, A 1H , 16H(MU,NU) PAIRS , //, (1H , I8, 4X, 2I4)) 9300 FORMAT (////, A 1H , 20HW MATRIX ELEMENTS ) 9302 FORMAT (//, A 1H , 16H POWER INDEX , I4, 12H, POWER , I4, /) 9304 FORMAT ( A 1H , I4, 4X, 2I4, 4D14.6, /, (1H , 16X, 4D14.6)) 9400 FORMAT (////, A 1H , 20HWD MATRIX ELEMENTS ) 9402 FORMAT (//, A 1H , 16H POWER INDEX , I4, 12H, POWER , I4, /) 9404 FORMAT ( A 1H , I4, 4X, 2I4, 4D14.6, /, (1H , 16X, 4D14.6)) END m1pioh.f000644 000311 000121 00000043507 06067230216 012247 0ustar00krivecf1000000 000000 SUBROUTINE M1PIOH(NIN, NOUT, NIN1, NOUT1, MODE, LCFC, LVC, 1 NDFPAR, NDVPAR, NDP0, NDWK, 2 XMASS1, XMASS2, XMASS3, XINF, 3 MUU, IPOS, PSYM, 4 IPFL, IPFU, IPVL, IPVU, IPWU, 5 FPAR, MODF, F, FANA, VPAR, MODV, V, WK, 6 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 7 IP0OFF, IP0XU, IPOFF, IPXU) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LCFC, LVC, PSYM DIMENSION FPAR(3,NDFPAR), F(3,NDP0), FANA(3,3), 1 VPAR(3,NDVPAR), V(3,NDP0), WK(3,NDWK), 2 NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2) C C C PARAMETER INPUT/OUTPUT ROUTINE FOR MATRIX ELEMENTS. C C THIS ROUTINE PERFORMS FORMATTED AND UNFORMATTED INPUT/OUTPUT C OF PARAMETERS, NOT MATRIX ELEMENTS. IT HAS TWO INPUT AND C TWO OUTPUT CHANNELS WHICH ARE ACTIVATED ACCORDING TO THE C VALUE OF MODE. C C EXAMPLE: THE FIRST PROGRAM IN THE CHAIN USES THIS ROUTINE TO C READ PARAMETERS AND STORE THEM IN AN UNFORMATTED FILE; C THE NEXT PROGRAM USES THIS ROUTINE TO READ THOSE PARAMETERS C FROM THAT UNFORMATTED FILE, AND STORE THEM IN THE NEXT FILE, C ETC. EACH TIME THE PARAMETERS ARE ALSO PRINTED. C C C CHANNEL FILE TYPE C (UNIT NUMBER) (NO OPEN STAT. NEEDED) C C NIN FORMATTED (F), SEQUENTIAL C NOUT FORMATTED, SEQUENTIAL C NIN1 UNFORMATTED (U/F), SEQUENTIAL C NOUT1 UNFORMATTED, SEQUENTIAL C C C MODE ACTION COMMENT C C 1 F IN, F OUT USED IN M2M- C 2 F IN, F OUT, U/F OUT USED IN M2M- C 3 U/F IN, F OUT USED IN SCH. EQ. SOL. PROG. C 4 U/F IN, F OUT, U/F OUT USED IN SCH. EQ. SOL. PROG. C 5 U/F IN, F OUT AS 3, BUT CALCULATES FANA; C USED IN AVERAGES PROGRAM C C C NOTE THAT IP0OFF , IP0XU , IPOFF , IPXU ARE CALCULATED IN C THIS ROUTINE IF NECESSARY. FANA , F , V ARE CALCULATED IF C MODE = 1, 2, OR 5. C C C NEGATIVE MASSES ARE CHANGED TO XINF ("INFINITE") IMMEDIATELY C AFTER FIRST FORMATTED READ, SO THAT THEY NEVER REAPPEAR C IN ANY SUBSEQUENT FILE. C C CHARACTER*6 NAME DATA NAME / 'M1PIOH' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 92/11/26 (MODE = 5 (FANA); CFC004; 5) (M1PIOG 2.1) ' / C ------------------------------------------------------------ C C LOGICAL LCALL0, LIF, LIU, LOF, LOU, LFV DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C DEFINE ACTIONS. C --------------- C IF (MODE .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (MODE .GT. 5) CALL ERR2(NAME, 2, 1, NOUT) C LIF = MODE .EQ. 1 .OR. MODE .EQ. 2 LIU = MODE .EQ. 3 .OR. MODE .EQ. 4 .OR. MODE .EQ. 5 LOF = .TRUE. LOU = MODE .EQ. 2 .OR. MODE .EQ. 4 LFV = MODE .EQ. 1 .OR. MODE .EQ. 2 .OR. MODE .EQ. 5 C C C MASSES OF PARTICLES. C ==================== C C A NEGATIVE MASS IS PUT EQUAL TO XINF WHEN FIRST INPUT C ("INFINITE," INPUT, SEE DEFINITION ELSEWHERE). C IF (LIF) READ (NIN,1012) XMASS1, XMASS2, XMASS3 IF (LIF) THEN IF (XMASS1 .LE. 0.D0) CALL ERR2(NAME, 11, 0, NOUT) IF (XMASS2 .LE. 0.D0) CALL ERR2(NAME, 12, 0, NOUT) IF (XMASS3 .LE. 0.D0) CALL ERR2(NAME, 13, 0, NOUT) IF (XMASS1 .LT. 0.D0) XMASS1 = XINF IF (XMASS2 .LT. 0.D0) XMASS2 = XINF IF (XMASS3 .LT. 0.D0) XMASS3 = XINF ENDIF IF (LIU) READ (NIN1) XMASS1, XMASS2, XMASS3 IF (LOF) WRITE (NOUT,2020) XMASS1, XMASS2, XMASS3 IF (LOU) WRITE (NOUT1) XMASS1, XMASS2, XMASS3 C C C MAX. MU (MATRIX), IPOS, PSYM FOR STATES. C ======================================== C IF (LIF) READ (NIN,1014) MUU, IPOS, PSYM IF (LIU) READ (NIN1) MUU, IPOS, PSYM IF (LOF) WRITE (NOUT,2030) MUU, IPOS, PSYM IF (LOU) WRITE (NOUT1) MUU, IPOS, PSYM C C C F, V POWER RANGES AND MATRIX ELEMENT POWER CUTOFF ( IPWU ). C =========================================================== C C F POWERS: (IPFL,..., IPFU). C V POWERS: (IPVL,..., IPVU). C IF (LIF) READ (NIN,1010) IPFL, IPFU, IPVL, IPVU, IPWU IF (LIU) READ (NIN1) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOF) WRITE (NOUT,2040) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOU) WRITE (NOUT1) IPFL, IPFU, IPVL, IPVU, IPWU C C C STORAGE OFFSET AND NUMBER OF POWERS IN THE COMMON RANGE C OF POWERS FOR F, V (UNION OF RANGES OF F AND V). C ------------------------------------------------------- C IP0OFF = 1 - MIN(IPFL, IPVL) IP0XU = MAX(IPFU, IPVU) - MIN(IPFL, IPVL) + 1 IF (IP0XU .GT. NDP0) CALL ERR2(NAME, 21, 1, NOUT) IF (LOF) WRITE (NOUT,2042) IP0OFF, IP0XU C C STORAGE OFFSET AND NUMBER OF POWERS FOR THE HH EXPANSION C COEFFICIENTS AND FINAL MATRIX ELEMENTS. C -------------------------------------------------------- C IPOFF = -999 IPXU = -999 IF (LIF) THEN C SMALLEST AND LARGEST POWERS ( IPL , IPU ). C IPWU IS THE MAXIMUM REQUIRED POWER IN THE MATRIX ELEMENTS C OF W . C IF THE SERIES FOR F IS FINITE, THE MAXIMUM POWER, IPU0 , C IS GIVEN BY THE FORMULA BELOW. C IF THE SERIES FOR F IS INFINITE, IT CAN BE SHOWN THAT C THE HIGHEST POWER IN W WHICH IS NOT AFFECTED BY THE C CUTOFF OF POWERS IN F IS IPFU - 2 WHERE IPFU IS C THE LARGEST POWER OF F USED. C WARNING 22 APPLIES TO FINITE SERIES AND WARNS THAT NOT C ALL EXISTING POWERS IN W WILL BE CALCULATED (IGNORE C IN CASE OF INFINITE SERIES). C WARNING 23 APPLIES TO INFINITE SERIES AND WARNS THAT C MORE POWERS IN W WILL BE CALCULATED THAN ARE C UNAFFECTED BY THE CUTOFF IN F (IGNORE FOR FINITE C SERIES). C DIMENSION TESTS COME LATER IN MATRIX ELEMENT ROUTINES. C OFFSET: ARRAY INDEX = POWER + OFFSET. C IPL = MIN(IPVL, IPFL-2, 2*IPFL-2, IPFL-1) IPU0 = MAX(IPVU, IPFU-2, 2*IPFU-2, IPFU-1) IPU = MIN(IPU0, IPWU) IF (IPWU .LT. IPU0) CALL ERR2(NAME, 22, 0, NOUT) IF (IPWU .GT. MAX(IPVU, IPFU-2)) CALL ERR2(NAME, 23, 0, NOUT) IPOFF = 1 - IPL IPXU = IPU + IPOFF IF (LOF) WRITE (NOUT,2044) IPOFF, IPXU ENDIF C C C PARAMETERS OF THE CORRELATION FUNCTION. C ======================================= C C THE PROCEDURE: C (1) READ PARAMETERS USUALLY CALLED ALPHA(I), C BETA(I),..., I = 1,2,3, INTO THE ARRAY FPAR(I,K) , C K = 1,..., NFPAR . C (2) READ A MODE SWITCH ( MODF ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING FPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPFL , IPFU . C (THERE HAVE TO BE SOME BOUNDS IF THE CORRELATION C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN F(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NFPAR IF (LIU) READ (NIN1) NFPAR IF (LOF) WRITE (NOUT,2050) NFPAR IF (LOU) WRITE (NOUT1) NFPAR C IF (NFPAR .LT. 1) CALL ERR2(NAME, 31, 1, NOUT) IF (NFPAR .GT. NDFPAR) CALL ERR2(NAME, 32, 1, NOUT) C DO 30 K = 1,NFPAR C IF (LIF) READ (NIN,1100) J, (FPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (FPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2060) J, (FPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (FPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 33, 1, NOUT) IF (J .GT. NDFPAR) CALL ERR2(NAME, 34, 1, NOUT) 30 CONTINUE C IF (LIF) READ (NIN,1010) MODF IF (LIU) READ (NIN1) MODF IF (LOF) WRITE (NOUT,2062) MODF IF (LOU) WRITE (NOUT1) MODF C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE CORRELATION FUNCTION. C ---------------------------------------------------------- C C CUSP PARAMETRIZATION IS DONE BY CFC002. NOTE THAT THE C INPUT USED BY CFC002 (MASSES, CHARGES) IS INDEPENDENT OF C THE V COEFFICIENTS READ IN BELOW. THE CONSISTENCY TEST C IS DONE AFTER READING IN THE V COEFFICIENTS. C C IF (MODF.LT.0 .OR. MODF.GT.5) CALL ERR2(NAME, 35, 1, NOUT) IF (MODF .EQ. 0) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 36, 1, NOUT) CALL CFC000(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), F, FANA) ENDIF IF (MODF .EQ. 1) THEN IF (NFPAR .NE. 3) CALL ERR2(NAME, 37, 1, NOUT) CALL CFC001(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), FPAR(1,3), F, FANA) ENDIF IF (MODF .EQ. 2) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 38, 1, NOUT) CALL CFC002(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, FPAR(1,1), 3 F, FANA) ENDIF IF (MODF .EQ. 3) THEN IF (NFPAR .NE. 2) CALL ERR2(NAME, 39, 1, NOUT) CALL CFC003(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), F) ENDIF IF (MODF .EQ. 4) THEN C FPAR: XZ, XE, XA, XR, XN (SEE CFC004). IF (NFPAR .NE. 5) CALL ERR2(NAME, 40, 1, NOUT) CALL CFC004(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), D1, D2, D, F, FANA) ENDIF IF (MODF .EQ. 5) THEN IF (NFPAR .NE. 5) CALL ERR2(NAME, 41, 1, NOUT) CALL CFC005(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), F, FANA) ENDIF IF (LCFC) WRITE (NOUT,2200) NAME, FANA ENDIF C C C PARAMETERS OF THE POTENTIAL V. C ============================== C C THE PROCEDURE: C (1) READ PARAMETERS INTO THE ARRAY VPAR(I,K) , C K = 1,..., NVPAR . C (2) READ A MODE SWITCH ( MODV ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING VPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPVL , IPVU . C (THERE HAVE TO BE SOME BOUNDS IF THE POTENTIAL C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN V(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NVPAR IF (LIU) READ (NIN1) NVPAR IF (LOF) WRITE (NOUT,2070) NVPAR IF (LOU) WRITE (NOUT1) NVPAR C IF (NVPAR .LT. 1) CALL ERR2(NAME, 51, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 52, 1, NOUT) C DO 40 K = 1,NVPAR C IF (LIF) READ (NIN,1100) J, (VPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (VPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2080) J, (VPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (VPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 53, 1, NOUT) IF (J .GT. NDVPAR) CALL ERR2(NAME, 54, 1, NOUT) 40 CONTINUE C IF (LIF) READ (NIN,1010) MODV IF (LIU) READ (NIN1) MODV IF (LOF) WRITE (NOUT,2082) MODV IF (LOU) WRITE (NOUT1) MODV C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE POTENTIAL. C ----------------------------------------------- C IF (MODV.LT.0 .OR. MODV.GT.1) CALL ERR2(NAME, 55, 1, NOUT) IF (MODV .EQ. 0) THEN CALL VC000(NDVPAR, NDP0, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) ENDIF IF (MODV .EQ. 1) THEN CALL VC001(NDVPAR, NDP0, NDWK, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) ENDIF ENDIF C C IF (LIF .AND. (MODF .EQ. 2 .OR. MODF .EQ. 4 .OR. MODF .EQ. 5)) 1 THEN C C CONSISTENCY CHECK, TRUE CUSPS (ANY MODV ). C ------------------------------------------- C C TEST CUSP PARAMETERS VS. V PARAMETERS: FPAR ARE PRODUCTS C OF CHARGES IN THIS CASE (SEE CFC002), AND MUST BE EQUAL C TO THE V-COEFFICIENTS OF POWER -1. (FATAL ERRORS ONLY IF C MODF = 2 TO ENABLE FLEXIBILITY IN F.) C IF (MODF .EQ. 2) THEN ZZZ0 = 100 * CDXEPS() IERR = 1 ELSE ZZZ0 = 10 * CDXEPS() IERR = 0 ENDIF IF (IPVL .GT. -1 .OR. IPVU .LT. -1) 1 CALL ERR2(NAME, 60, 1, NOUT) ZZZ1 = V(1,-1+IP0OFF) ZZZ2 = V(2,-1+IP0OFF) ZZZ3 = V(3,-1+IP0OFF) IF (ABS(ZZZ1 - FPAR(1,1)) .GT. ABS(ZZZ0 * ZZZ1)) 1 CALL ERR2(NAME, 61, IERR, NOUT) IF (ABS(ZZZ2 - FPAR(2,1)) .GT. ABS(ZZZ0 * ZZZ2)) 1 CALL ERR2(NAME, 62, IERR, NOUT) IF (ABS(ZZZ3 - FPAR(3,1)) .GT. ABS(ZZZ0 * ZZZ3)) 1 CALL ERR2(NAME, 63, IERR, NOUT) ENDIF C C C GAUSSIAN INTEGRATION PARAMETERS. C ================================ C IF (LIF) READ (NIN,1010) (NGOA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NSUBA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NGOL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NGOL(I,2), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,2), I = 1,10) IF (LIF) READ (NIN,1030) DAS, DLS C IF (LIU) READ (NIN1) (NGOA(I), I = 1,2) IF (LIU) READ (NIN1) (NSUBA(I), I = 1,2) IF (LIU) READ (NIN1) (NGOL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NGOL(I,2), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,2), I = 1,10) IF (LIU) READ (NIN1) DAS, DLS C IF (LOF) WRITE (NOUT,2120) (NGOA(I), I = 1,2), 1 (NSUBA(I), I = 1,2), 2 (NGOL(I,1), I = 1,10), 3 (NSUBL(I,1), I = 1,10), 4 (NGOL(I,2), I = 1,10), 5 (NSUBL(I,2), I = 1,10), 6 DAS, DLS C IF (LOU) WRITE (NOUT1) (NGOA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NSUBA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NGOL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NGOL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) DAS, DLS C RETURN C C 1010 FORMAT (20I4) 1012 FORMAT (3F20.6) 1014 FORMAT (2I4, L4) 1030 FORMAT (10F8.2) 1100 FORMAT (I4, 3F20.16) C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2020 FORMAT (//, A 1H , 40HMASS1 , D28.16, /, B 1H , 40HMASS2 , D28.16, /, C 1H , 40HMASS3 , D28.16) 2030 FORMAT ( A 1H , 40HMUU; IPOS, PSYM (IGNORED) , 2I4, L4) 2040 FORMAT ( A 1H , 40HIPFL, IPFU , 2I4, /, B 1H , 40HIPVL, IPVU , 2I4, /, C 1H , 40HIPWU (CUTOFF) , I4) 2042 FORMAT ( A 1H , 40H CALCULATED: IP0OFF, IP0XU , 2I4) 2044 FORMAT ( A 1H , 40H CALCULATED: IPOFF, IPXU , 2I4) 2050 FORMAT ( A 1H , 32HNFPAR , I4) 2060 FORMAT ( A 1H , 36HJ, FPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2062 FORMAT ( A 1H , 32HMODF (F FORMULA SELECTOR) , I4) 2070 FORMAT ( A 1H , 32HNVPAR , I4) 2080 FORMAT ( A 1H , 36HJ, VPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2082 FORMAT ( A 1H , 32HMODV (V FORMULA SELECTOR) , I4) 2120 FORMAT (//, A 1H , 32HINTEGRATION PARAMETERS , /, B 1H , 32HNGOA , 2I4, /, C 1H , 32HNSUBA , 2I4, /, D 1H , 32HNGOL(.,1) , 10I4, /, E 1H , 32HNSUBL(.,1) , 10I4, /, F 1H , 32HNGOL(.,2) , 10I4, /, G 1H , 32HNSUBL(.,2) , 10I4, /, H 1H , 32HDAS, DLS , 2F12.6) 2200 FORMAT (1H , 1H-, A6, 1H-, /, A 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END m2wrda.f000644 000311 000121 00000005450 06067230263 012243 0ustar00krivecf1000000 000000 SUBROUTINE M2WRDA(NDS, NDP, 1 NOUT, LPR, 2 IPXU, NS, INUSEL, ICONTR, 3 NSX, ISMN, EMW, EMWD) IMPLICIT REAL*8 (A - H, O - Z) LOGICAL LPR DIMENSION ICONTR(NDS), ISMN(2,NDS), 1 EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP) C C C CONTRACTS THE W MATRIX BY SELECTING THE NONNEGATIVE-NU, C NEGATIVE-NU, OR ALL STATES, ACCORDING TO THE VALUE C OF THE VARIABLE INUSEL BEING 1, -1, OR 0, RESPECTIVELY. C C NOTE THAT STATES ARE ASSUMED TO BE ORDERED AS GIVEN BY ISMN, C I.E., THE NU-SELECTION IS DONE ON THE VECTOR ISMN ONLY. C C **** ISMN, EMW, EMWD CHANGED ON EXIT (EXCEPTIONAL) **** C C NS IS THE ORIGINAL NUMBER OF STATES AND NSX IS THE C OUTPUT NUMBER OF STATES. C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C CHARACTER*6 NAME DATA NAME / 'M2WRDA' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/12/02. ' / C ------------------------------------------------------------ C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (IPXU .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (IPXU .GT. NDP) CALL ERR2(NAME, 4, 1, NOUT) IF (INUSEL .LT. -1 .OR. INUSEL .GT. 1) 1 CALL ERR2(NAME, 5, 1, NOUT) C IF (INUSEL .EQ. 0) THEN C C DO NOTHING. NSX = NS IF (LPR) WRITE (NOUT,2300) 1 NAME, (I, ISMN(1,I), ISMN(2,I), I = 1,NSX) RETURN ENDIF C C DEFINE THE CONTRACTING VECTOR, CONTRACT STATE LABELS. IF (LPR) WRITE (NOUT,2200) NAME NSX = 0 DO 10 I = 1,NS IF (.NOT. ((INUSEL .EQ. -1 .AND. ISMN(2,I) .LT. 0) .OR. 1 (INUSEL .EQ. 1 .AND. ISMN(2,I) .GE. 0) )) 2 GO TO 10 NSX = NSX + 1 ICONTR(NSX) = I ISMN(1,NSX) = ISMN(1,I) ISMN(2,NSX) = ISMN(2,I) IF (LPR) WRITE (NOUT,2210) 1 NSX, ISMN(1,NSX), ISMN(2,NSX), I 10 CONTINUE IF (NSX .EQ. 0) CALL ERR2(NAME, 10, 1, NOUT) C C CONTRACT THE MATRICES. DO 26 K = 1,IPXU DO 24 JX = 1,NSX J = ICONTR(JX) DO 20 IX = 1,NSX I = ICONTR(IX) EMW(IX,JX,K) = EMW(I,J,K) EMWD(IX,JX,K) = EMWD(I,J,K) 20 CONTINUE 24 CONTINUE 26 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2200 FORMAT ( A 2H -, A6, 1H-) 2210 FORMAT ( A 1H , 10X, I4, 4X, 2I4, I8) 2300 FORMAT ( A 2H -, A6, 1H-, /, B (1H , 10X, I4, 4X, 2I4)) END tempd.f000644 000311 000121 00000002513 05575327000 012154 0ustar00krivecf1000000 000000 SUBROUTINE TEMPD(TOLD, TNEW, TDIF, NOUT, LPR) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LPR C C CONVEX TIMING ROUTINE, USING CPUTIME(), WALLTIME(). C REASON: OLD TEMPD USED ETIME(,) WHICH RETURNS STRANGE VALUES C UPON -O3. TESTING 93/04/07... C PRINTS THE CURRENT CPU TIME, THE DIFFERENCE FROM THE C REFERENCE TIME (TOLD), AND TOLD. WALLTIME FROM ZERO IS PRINTED C ONLY, ALSO ON THE FIRST CALL. C NOUT IS THE OUTPUT UNIT NUMBER. C LOGICAL INIT REAL*4 CPUTIME, WALLTIME, SZERO, X DATA INIT / .TRUE. /, SZERO / 0.0 / C IF (.NOT. INIT) GO TO 10 WRITE (NOUT,2000) INIT = .FALSE. X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2200) WALL RETURN 10 CONTINUE X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2100) TNEW, TDIF, TOLD, WALL RETURN C 2000 FORMAT (1H , 48H-TEMPD- 2.0C, 94/06/08. CONVEX TIMING ROUTINE. ) 2100 FORMAT (1H , 2X, 4HCPU , F12.2, A 8H DIF, F12.2, B 8H REF, F12.2, C 8H WALL, F12.2) 2200 FORMAT (1H , 2X, 16X, 40X, A 8H WALL, F12.2) END vc000.f000644 000311 000121 00000003315 06067230324 011673 0ustar00krivecf1000000 000000 SUBROUTINE VC000(NDVPAR, NDP0, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C R(I) POWER SERIES COEFFICIENTS OF THE POTENTIAL C C V = SUM(I=1...3) SUM(J=1...NVPAR) VPAR(I,J) * R(I)**(IPVL-1+J) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: V(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C C CHARACTER*6 NAME DATA NAME / 'VC000 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. O: CFC000 1.1, 90/03/28. ' / C ------------------------------------------------------------ LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C CHECK NUMBER OF PARAMETERS. (IT MAY NOT EXCEED THE REQUIRED C NUMBER OF POWERS AS GIVEN BY (IPVL, IPVU).) IF (NVPAR .GT. IPVU - IPVL + 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 2, 1, NOUT) C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C DO 12 J = 1,NVPAR IP0 = (IPVL - 1) + J IP0X = IP0 + IP0OFF DO 10 I = 1,3 V(I,IP0X) = VPAR(I,J) 10 CONTINUE 12 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END vc001.f000644 000311 000121 00000005470 06067230326 011702 0ustar00krivecf1000000 000000 SUBROUTINE VC001(NDVPAR, NDP0, NDWK, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WK(3,NDWK), VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C THE INPUT ARRAY VPAR IS INTERPRETED SUCH THAT C THE POTENTIAL IS A SUM OF YUKAWA TERMS: C C V = SUM(I=1...3) SUM(K=1...NVPAR/2) C VPAR(I,2*K-1) * EXP(-VPAR(I,2*K) * R(I)) / R(I) C C NVPAR MUST BE EVEN AND NDWK .GE. NVPAR / 2. C C CHARACTER*6 NAME DATA NAME / 'VC001 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. ' / C ------------------------------------------------------------ C DIMENSION S(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPVL .NE. -1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU .LT. IPVL) CALL ERR2(NAME, 2, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 3, 1, NOUT) C ZERO = 0.0D0 ONE = 1.0D0 C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C C NUMBER OF YUKAWA TERMS, FROM NUMBER OF INPUT TERMS. IF (MOD(NVPAR, 2) .NE. 0) CALL ERR2(NAME, 11, 1, NOUT) NET = NVPAR / 2 IF (NET .GT. NDWK) CALL ERR2(NAME, 12, 1, NOUT) C C NUMBER OF POWERS TO BE GENERATED. NEP = IPVU - IPVL + 1 IF (NEP .GT. NDP0) CALL ERR2(NAME, 13, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 14, 1, NOUT) C C INITIALIZE. P = ONE DO 12 K = 1,NET DO 10 I = 1,3 WK(I,K) = VPAR(I,2*K-1) 10 CONTINUE 12 CONTINUE C C LOOP OVER POWERS. DO 40 J = 1,NEP C C POWER AND ITS INDEX. IP0 = J - 2 IP0X = IP0 + IP0OFF C S(1) = ZERO S(2) = ZERO S(3) = ZERO DO 22 K = 1,NET DO 20 I = 1,3 S(I) = S(I) + WK(I,K) 20 CONTINUE 22 CONTINUE C C CALCULATE THE V COEFFICIENTS. V(1,IP0X) = P * S(1) V(2,IP0X) = P * S(2) V(3,IP0X) = P * S(3) C C UPDATE FOR THE NEXT POWER (IP0 + 1). P = P / DFLOAT(IP0 + 2) DO 32 K = 1,NET DO 30 I = 1,3 WK(I,K) = WK(I,K) * (- VPAR(I,2*K)) 30 CONTINUE 32 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) 40 CONTINUE RETURN C 2000 FORMAT (2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END bina.f000644 000311 000121 00000004002 06067232043 011746 0ustar00krivecf1000000 000000 SUBROUTINE BINA(ND1, ND2, NU, MU, B, LPR, NOUT) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION B(ND1,ND2) C C C C C BINOMIAL SYMBOLS (N ATOP M) STORED AS C B(N+3,M+1) = (N ATOP M), C FOR C N = -2,..., NU, C M = 0,..., MU. C AUXILIARY PROGRAM FOR PROGRAM COULD- . C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'BINA ' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (NU+3 .GT. ND1) CALL ERR2(NAME, 1, 1, NOUT) IF (MU+1 .GT. ND2) CALL ERR2(NAME, 2, 1, NOUT) IF (NU .LT. -2) CALL ERR2(NAME, 3, 1, NOUT) IF (MU .LT. 0) CALL ERR2(NAME, 4, 1, NOUT) C C DO 22 J = 1,ND2 DO 20 I = 1,ND1 B(I,J) = 0.D0 20 CONTINUE 22 CONTINUE M1U = MU + 1 DO 24 M1 = 1,M1U M = M1 - 1 B(1,M1) = (1 - 2 * MOD(IABS(M),2)) * (M + 1) 24 CONTINUE IF (LPR) WRITE (NOUT,2100) NAME, (B(1,M1), M1 = 1,M1U) IF (NU .EQ. -2) RETURN DO 26 M1 = 1,M1U M = M1 - 1 B(2,M1) = (1 - 2 * MOD(IABS(M),2)) 26 CONTINUE IF (LPR) WRITE (NOUT,2100) NAME, (B(2,M1), M1 = 1,M1U) IF (NU .EQ. -1) RETURN B(3,1) = 1.D0 IF (LPR) WRITE (NOUT,2100) NAME, B(3,1) IF (NU .EQ. 0) RETURN N3U = NU + 3 DO 30 N3 = 4,N3U N = N3 - 3 B(N3,1) = 1.D0 IF (N+1 .LE. M1U) B(N3,N+1) = 1.D0 MXU = MIN(N-1+1, M1U) DO 28 MX = 2,MXU B(N3,MX) = B(N3-1,MX-1) + B(N3-1,MX) 28 CONTINUE J = MIN(N+1, M1U) IF (LPR) WRITE (NOUT,2100) NAME, (B(N3,M1), M1 = 1,J) 30 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.1, 95/12/24. 1.0, 90/03/31. ) C ======================================== 2100 FORMAT ( A 1H , 1H-, A6, 1H-, 5F12.6, /, (1H , 10X, 5F12.6)) END dasum.f000644 000311 000121 00000005747 05311644770 012174 0ustar00krivecf1000000 000000 FUNCTION DASUM(N,DX,INCX) IMPLICIT REAL*8 (A-H,O-Z) C C TAKES THE SUM OF THE ABSOLUTE VALUES. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DX(1),DTEMP INTEGER I,INCX,M,MP1,N,NINCX C DASUM = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DTEMP = DTEMP + ABS(DX(I)) 10 CONTINUE DASUM = DTEMP RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,6) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + ABS(DX(I)) 30 CONTINUE IF( N .LT. 6 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,6 DTEMP = DTEMP + ABS(DX(I)) + ABS(DX(I + 1)) + ABS(DX(I + 2)) * + ABS(DX(I + 3)) + ABS(DX(I + 4)) + ABS(DX(I + 5)) 50 CONTINUE 60 DASUM = DTEMP RETURN END daxpy.f000644 000311 000121 00000006657 05311644771 012212 0ustar00krivecf1000000 000000 SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY) IMPLICIT REAL*8 (A-H,O-Z) C C CONSTANT TIMES A VECTOR PLUS A VECTOR. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DX(1),DY(1),DA INTEGER I,INCX,INCY,IXIY,M,MP1,N C IF(N.LE.0)RETURN IF (DA .EQ. 0.0D0) RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DY(IY) = DY(IY) + DA*DX(IX) IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,4) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DY(I) = DY(I) + DA*DX(I) 30 CONTINUE IF( N .LT. 4 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,4 DY(I) = DY(I) + DA*DX(I) DY(I + 1) = DY(I + 1) + DA*DX(I + 1) DY(I + 2) = DY(I + 2) + DA*DX(I + 2) DY(I + 3) = DY(I + 3) + DA*DX(I + 3) 50 CONTINUE RETURN END ddaa.f000644 000311 000121 00000045135 06070002202 011724 0ustar00krivecf1000000 000000 FUNCTION DDAA(A) IMPLICIT REAL*8 (A-H, O-Z) C C C CALCULATES THE DETERMINANT OF THE DISCONTINUITY OF THE LOGARITHMIC C DERIVATIVE OF THE WAVE FUNCTION AT Z = ZMATCH, AT A FIXED ENERGY C A**2 / 2, BY PROPAGATING THE LOGARITHMIC DERIVATIVE BETWEEN Z = 0 C AND Z = ZMATCH AND BETWEEN Z = ZTOP AND Z = ZMATCH. IT USES C GENERAL POWER-TYPE SERIES EXPANSIONS OF MATRIX ELEMENTS. C C CORRESPONDS TO THE FUNCTION D BY M. HAFTEL. C C CALLING MODES: C 1. DETERMINANT OR ENERGY SEARCH ONLY: C CALL WITH LOUTA = LOUTC = .FALSE.. C 2. WAVE FUNCTION: C 2.1. EITHER SUPPLY THE ENERGY OR CALL DD- WITH C LOUTA = LOUTC = .FALSE. TO FIND ENERGY. C 2.2. CALL DD- WITH LOUTA = .FALSE., LOUTC = .TRUE.; THIS C CALCULATES X(Z0P) AND STORES IT TO UNIT NOUTC . C STORED IS ALSO RT(-) - RT(+) AND IINTL, IINTR. C (ALL THIS IS USED BY DWFPD- ONLY; RT(-) - RT(+) C WAS PREVIOUSLY COMMUNICATED VIA COMMON THEREFORE C IT WAS NOT POSSIBLE TO RESTART PROGRAM FROM C DWFPD- WITHOUT FIRST CALLING DD-.) C 2.3. CALL DWFPD- TO PROPAGATE THE VECTORS CV. THIS READS C UNIT NOUTC. C 2.4. CALL DD- WITH LOUTA = .TRUE., LOUTC = .FALSE.; THIS C RECALCULATES THE ARRAY CN ON EACH INTERVAL AND C IMMEDIATELY CALCULATES THE WAVE FUNCTION POWER C SERIES, USING CN AND CV (INSTEAD OF STORING CN AND C LATER CALLING WFPSD-, AS WAS THE CASE WITH DDP .) C NOTE THAT THE CONTROL OF THE CALLS IS ENTIRELY WITH THE MAIN C PROGRAM; NO CHECKS OF LOUTA, LOUTC ARE DONE HERE. NOTE THAT C LOUTB IS IGNORED UNLESS LOUTA = .TRUE.. ARRAY SUM IS C RETAINED IN COMMON TO AVOID DOUBLE SPACE RESERVATIONS. C C PREVIOUS MAJOR MODIFICATIONS: C C DDU ELIMINATES SETTING CN(,,1) TO IDENTITY TOO MANY TIMES. C NOUT2 - NORMALIZED DET(E). C NOUT2A - NORMALIZED DET(E), FORMATTED. C NOUT3 - X(Z0P), CN(1,1,1) = 1, CN(1,1,2) = RT(Z0P). C C DDQ IS A MODIFICATION OF DDP NECESSARY TO AVOID A LARGE C TEMPORARY FILE (UNIT NOUTA) WHICH HELD THE ARRAY CN USED TO C CALCULATE THE WAVE FUNCTION. CN IS NOW NOT STORED IN A FILE C AND ANOTHER CALL TO THIS ROUTINE IS NECESSARY. (UNIT NOUTA C COULD REACH GIGABYTE SIZES FOR LARGE MAXIMUM K IN HH.) NOW C UNIT NOUTA HOLDS ONLY DATA FOR THE FIRST INTERVAL. THE PRICE C FOR THIS IS ONE MORE ITERATION IF WAVE FUNCTION IS REQUIRED. C C IT MAY BECOME NECESSARY TO ELIMINATE ALSO THE FILE NOUTC; THIS C HAS NOT BEEN DONE YET BECAUSE THIS INFORMATION HAS TO BE C ACCESSED IN DIFFERENT ORDERS, AND MUST BE EITHER IN AN ARRAY C OR IN A FILE. M. HAFTEL SOLVED THIS PROBLEM BY ORTHOGONALIZING C ON NOT EVERY INTERVAL, BY PAYING A CERTAIN PRICE FOR ACCURACY. C C ****************************************************************** C * DD- TRANSPOSES THE CN ON INTERVALS OTHER THAN THE FIRST AND * C * PROPAGATES RT INSTEAD OF R . TRANSPOSITIONS IN THE ORIGINAL * C * D ARE THEREFORE ELIMINATED. TRANSPOSITIONS STILL OCCUR AT * C * FILE READ/WRITE TIME AND OTHER OPERATIONS AT THE WAVE FUNCTION * C * PROPAGATION TIME (SEE UNIT NOUTC). * C ****************************************************************** C C CHARACTER*6 NAME DATA NAME / 'DDAA ' / CHARACTER*60 VERS DATA VERS */ ' 1.1C, 94/05/04; RT... TO NOUTC. DDY 1.1CC, -W 3.1, -V 1.0. ' / C ------------------------------------------------------------ C C DEFINE DIMENSIONS FOR COMMON AND DIMENSION DECLARATIONS. C ADJUST NCDMU, NCISYM, NCDP, NCDCN TO THE CALLING PROGRAM. C ****************************************************************** PARAMETER (NCDMU = 21, NCISYM = 1, NCDP = 2, NCDCN = 22, 1 NCD1 = 2, NCD2 = 65, NCDINT = 1200) C ****************************************************************** C C DERIVED PARAMETERS. COMPARED WITH CALLING PROGRAM VIA COMMON. PARAMETER (NCDS = (1 - NCISYM) * (NCDMU * (NCDMU + 1) / 2) 1 + NCISYM * (((NCDMU + 1) / 2) ** 2) , 2 NCDML = 2 * (NCDMU - 1) + 1) PARAMETER (NDBIN1 = NCDP + 3, NDBIN2 = NCDCN - 1, 1 NDZ0MP = NCDP + NCDCN + 1) C C RRLSD-/VICD-: DIMENSION P(NCDS,NCDS), P2X(NCDS,NCDS), XXX(NCDS), 1 X(NCDS,NCDS), Y(NCDS,NCDS), XY(NCDS,NCDS), 2 YX(NCDS,NCDS), XD0(NCDS,NCDS), 3 LMIN(NCDS), LMAX(NCDS,NCDML), LMAX1(NCDS,NCDML), 4 LMAXY(NCDS), LMAXXY(NCDS), LMAXYX(NCDS) LOGICAL LTVICB C RRLSD-: DIMENSION DL(NCDS,NCDS), DLT(NCDS,NCDS), 1 TW(NCDS), CU(NCDS), FAC(NCDS,NCDS), 2 CCMM(NCDS,NCDS), CCCM(NCDS), CCCP(NCDS,NCDS), 3 CCC(NCDS), CCD(NCDS,NCDS), PNEWM(NCDS,NCDS), 4 NU2(NCDS,NCDS) C RRPS-: DIMENSION PP(NCDS,NCDS,NCDCN), QQ(NCDS,NCDS,NCDCN), 1 BIN(NDBIN1,NDBIN2), Z0MPOW(NDZ0MP) C GENERAL: DIMENSION ADD(NCDS,NCDS), SUD(NCDS,NCDS), 1 P1(NCDS,NCDS), P2(NCDS,NCDS), ZML(NCDS) C MAIND-: DIMENSION INDEX(NCDS,2), IPIVOT(NCDS), PIVOT(NCDS) C DETD-: DIMENSION DR(NCD1), DMR(NCD1), NDR(NCD1), 1 Z(NCDS), WORK(NCDS), PR(NCDS), IPVT(NCDS) C LOGICAL LTEST, LTESTR, LTRRPS, LPRBIN, LPRZ0M, LTRRP1, 1 LTCPU, LOUTA, LOUTB, LOUTC, LPRWF, LTDET C C COMMON / MACH / MACHN COMMON / REFDIM / NRDS, NRDP, NRDCN, NRDML, NRDINT COMMON / MEL / WS(NCDS,NCDS,NCDP), WD(NCDS,NCDS,NCDP), 1 IPXU, IPOFF COMMON / VM / MM COMMON / SOF / MA COMMON / MU / MU(NCDS) COMMON / DETOPT / NREADE COMMON / NM / ZM, ZMATCH, TOL, DZU, ZTOP, 1 BC0, BC1, RHOUW, NM, JMAX COMMON / DETER / DM, NDP COMMON / IO / NIN, NOUT, NOUT2, NOUT3, NOUTA, NOUTB, NOUTC, 1 NOUT2A COMMON / TESTIO / LTEST, LTESTR, LTVICB, LTRRPS, LPRBIN, LPRZ0M, 1 LTCPU, LOUTA, LOUTB, LOUTC, LPRWF, LTDET COMMON / TESTZ / Z0MTTT, Z0MTTD, IPRTTT, IPCTTT COMMON / INTERV / IINT, IINTL, IINTR, IINTPR COMMON / RR / SUM(NCDS,NCDS) COMMON / COEF / CN(NCDS,NCDS,NCDCN), PM(NCDS,NCDS), 1 DML(NCDS), CV(NCDS,NCDINT), 2 WF(NCDS), WFD(NCDS), WFL(NCDS), WFDL(NCDS), 3 WFC(NCDS,NCDCN) COMMON / ZER / AA C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TEN, HALF / 0.D0, 1.D0, 10.D0, 0.5D0 / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS C C CHECK THE DIMENSIONS AGAINST THE REFERENCE DIMENSIONS C PASSED THROUGH COMMON. IF (NCDS .NE. NRDS) CALL ERR2(NAME, 1, 1, NOUT) IF (NCDP .NE. NRDP) CALL ERR2(NAME, 2, 1, NOUT) IF (NCDCN .NE. NRDCN) CALL ERR2(NAME, 3, 1, NOUT) IF (NCDML .NE. NRDML) CALL ERR2(NAME, 4, 1, NOUT) IF (NCDINT .NE. NRDINT) CALL ERR2(NAME, 5, 1, NOUT) C C OTHER DIMENSION CHECKS. IF (JMAX+1 .GT. NCDCN) CALL ERR2(NAME, 11, 1, NOUT) IF (JMAX .GT. NCD2) CALL ERR2(NAME, 12, 1, NOUT) C C TEST IPOFF; IF LARGER THAN 2, THERE ARE PROBABLY POWERS SMALLER C THAN -1 IN W; THEY ARE IGNORED, WITH A WARNING. C (THE RECURSION RELATIONS ASSUME POWERS ARE .GE. -1.) IF (LCALL0 .AND. IPOFF .GT. 2) CALL ERR2(NAME, 13, 0, NOUT) C C C INITIALIZATION. C ****************************************************************** C C SAVE THE INPUT PARAMETER (KAPPA); COMMON TRANSFERS IT TO DETD-. AA = A C C OPEN RADIAL SOLUTION STORAGE FILE (DIRECT ACCESS; READ AND WRITE C IN DIFFERENT ORDERS.) C RECL UNITS: CONVEX - BYTES, VAX - LONGWORDS, IBM - BYTES. IF (LOUTC) THEN IF (MACHN .EQ. 1) THEN C VAX. OPEN (UNIT=NOUTC, RECL=MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='UNKNOWN') ELSE IF (MACHN .EQ. 2) THEN C CONVEX (REMOVED RECORDTYPE). OPEN (UNIT=NOUTC, RECL=8*MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='UNKNOWN') ELSE IF (MACHN .EQ. 3) THEN C IBM. OPEN (UNIT=NOUTC, RECL=8*MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='UNKNOWN') ENDIF ENDIF C C C FIRST INTERVAL. C ****************************************************************** C C BOUNDARIES; STORE (POWER SERIES COEFFICIENTS BY RRLSD-). IINT = 1 Z0M = ZERO Z0P = ZM C --------------------------------------- IF (LOUTA) WRITE (NOUTA) IINT, Z0M, Z0P C --------------------------------------- C C RECURSION RELATIONS. CALL RRLSDE(NCDS, NCDML, NCDCN, NCDP, 1 MM, NM, MA, IPXU, IPOFF, ZM, AA, 2 NOUT, LTEST, LTVICB, NOUTA, LOUTA, 3 MU, LMIN, LMAX, LMAX1, LMAXY, LMAXXY, LMAXYX, 4 WS, WD, DL, DLT, NU2, X, Y, XY, YX, XD0, 5 P, P1, P2, P2X, XXX, TW, CU, FAC, 6 CCMM, CCCM, CCCP, CCC, CCD, PM, PNEWM, 7 ADD, SUM, SUD, CN) IF (LOUTA) THEN C C WAVE FUNCTION ON INTERVAL 1. DATA ARE ASSUMED TO EXIST ON C UNIT NOUTA. RESULT WRITTEN ON UNIT NOUTB. IINTL, IINTR ARE C BOTH IN COMMON AND DEFINED. CALL WFPS0A(NCDS, NCDCN, NCDINT, 1 MM, MA, NM, IINTL, IINTR, 2 NOUT, NOUTA, NOUTB, LOUTB, 3 CN, PM, DML, CV) ENDIF C C X(ZM), X'(ZM); STORE IN TRANSPOSE OF CN(.,.,1), CN(.,.,2). C (CN WILL CONTAIN TRANSPOSED X, X' AS IN THE ORIGINAL D .) CALL XSUM0A(NCDS, ZM, MM, MU, ZML, P1, P2, SUM, SUD, CN) IF (LTESTR) XZ0P = CN(1,1,1) IF (LOUTC) THEN C C STORE X(Z0P); SECOND INDEX RUNNING FIRST. C ----------------------------------------------------- DO 10 I = 1,MM IREC = 1 + MM + (IINT - 1) * MM + I WRITE (UNIT=NOUTC,REC=IREC) (CN(I,J,1), J = 1,MM) 10 CONTINUE C ----------------------------------------------------- ENDIF C C RT(ZM) (R MATRIX TRANSPOSE); STORE IN CN(.,.,2); SET C CN(.,.,1) TO IDENTITY (ONCE AND FOR ALL). CALL MAINDB(CN(1,1,1), CN(1,1,2), MM, MM, NCDS, NCDS, 1 INDEX, IPIVOT, PIVOT) DO 22 J = 1,MM DO 20 I = 1,MM CN(I,J,1) = ZERO 20 CONTINUE 22 CONTINUE DO 24 J = 1,MM CN(J,J,1) = ONE 24 CONTINUE IF (LTESTR) THEN WRITE (NOUT3,1100) Z0P, XZ0P, CN(1,1,1), CN(1,1,2) CALL CDXFBO(NOUT3) ENDIF C C IPASS = 1: INTEGRATION FROM ZM TO ZMATCH; C IPASS = -1: INTEGRATION FROM ZTOP TO ZMATCH. IPASS = 1 ICNT = 0 IINTO = IINT Z0MO = Z0M Z0PO = Z0P C C C OTHER INTERVALS. C ****************************************************************** C 30 CONTINUE IF (Z0P .EQ. ZMATCH) THEN C C MATCHING, DIRECTION REVERSAL. C ========================================================== C C REMEMBER NEIGHBORING INTERVALS. IF (Z0M .LT. ZMATCH) IINTL = IINT IF (Z0M .GT. ZMATCH) IINTR = IINT C C ANY IPASS; SUM STORES EITHER RT(-)(ZMATCH) (FOR IPASS = 1) C OR (RT(-) - RT(+)) (FOR IPASS = -1). ICNT = ICNT + 1 IF (ICNT .GT. NCD1) CALL ERR2(NAME, 21, 1, NOUT) IF (IPASS .EQ. 1) THEN DO 42 J = 1,MM DO 40 I = 1,MM SUM(I,J) = CN(I,J,2) 40 CONTINUE 42 CONTINUE ELSE DO 46 J = 1,MM DO 44 I = 1,MM SUM(I,J) = SUM(I,J) - CN(I,J,2) 44 CONTINUE 46 CONTINUE ENDIF IF (IPASS .EQ. 1) THEN C C IPASS = 1: DIRECTION REVERSAL; BOUNDARY CONDITION. C ------------------------------------------------------ C C SET X(ZTOP) = I (ALREADY DONE), C X'(ZTOP) = -(BC0 + BC1 / ZTOP) * I; C ALTHOUGH YOU ARE SPECIFYING R(ZTOP), THE EQUATIONS C HAVE A SELF-CORRECTING MECHANISM THAT WILL PRODUCE THE C CORRECT R AS YOU MOVE SUBSTANTIALLY INWARDS. C Z0P TEMPORARILY SET TO ZTOP. IPASS = - 1 DO 56 J = 1,MM DO 54 I = 1,MM CN(I,J,2) = ZERO 54 CONTINUE 56 CONTINUE DO 60 J = 1,MM CN(J,J,2) = -(BC0 + BC1 / ZTOP) 60 CONTINUE Z0P = ZTOP IF (LTESTR) THEN XZ0P = CN(1,1,1) WRITE (NOUT3,1100) Z0P, XZ0P, CN(1,1,1), CN(1,1,2) CALL CDXFBO(NOUT3) ENDIF ELSE C C IPASS = -1: DETERMINANT; PRINTOUT; EXIT (RETURN). C ------------------------------------------------------ C IF (LOUTC) THEN C C STORE DET(RT(-) - RT(+))(ZMATCH), IINTL, IINTR FOR C USE BY DWFPD- (FOR RESTART ONLY). NO TRANSPOSITION C (PREVIOUSLY THE MATRIX WAS IN COMMON). C -------------------------------------------------- IREC = 1 WRITE (UNIT=NOUTC,REC=IREC) IINTL, IINTR DO 62 I = 1,MM IREC = 1 + I WRITE (UNIT=NOUTC,REC=IREC) 1 (SUM(J,I), J = 1,MM) 62 CONTINUE C -------------------------------------------------- ENDIF C C DET(RT(-) - RT(+))(ZMATCH). CALL DETDE(SUM, ADD, MM, NCDS, DR(ICNT), 1 Z, WORK, PR, IPVT, .TRUE., LTDET) C C NORMALIZED DETERMINANT IS DR; TRUE DETERMINANT IS C DM * 10 ** NDP. DM, NDP FROM COMMON. DMR(ICNT) = DM NDR(ICNT) = NDP EN = HALF * AA ** 2 WRITE (NOUT,1002) DM, NDP, EN WRITE (NOUT2) EN, DR(ICNT) WRITE (NOUT2A,1200) EN, DR(ICNT) C C FLUSH BUFFERS (MACHINE DEP./ADJUST CDXFBO); CLOSE. CALL CDXFBO(NOUT) CALL CDXFBO(NOUT2) CALL CDXFBO(NOUT2A) IF (LOUTC) CLOSE (UNIT=NOUTC) C C NORMALIZED DETERMINANT. DDAA = DR(ICNT) IF (LCALL0) LCALL0 = .FALSE. RETURN ENDIF ENDIF C C NEW Z0P, RECURSION RELATIONS; RT(Z0P). C ============================================================== C C BOUNDARIES OF INTERVAL; TAYLOR SERIES EXPANDED ABOUT Z0M. C DO NOT GO ACROSS ZMATCH. IINT = IINT + 1 Z0M = Z0P Z0P = Z0M + IPASS * MIN(DZU, Z0M * TOL) IF (Z0P .GE. ZMATCH .AND. IPASS .EQ. 1) Z0P = ZMATCH IF (Z0P .LT. ZMATCH .AND. IPASS .NE. 1) Z0P = ZMATCH IF (JMAX .GE. 2) THEN C C C(2),..., C(JMAX) BY RECURSION. C LTRRPS USED EXTERNALLY FROM RRPS- ONLY, TO SWITCH TO TEST C ROUTINE CALL. THE TEST ROUTINE HAS A CONSTRAINT ON TEST C OUTPUT (Z0M MUST BE CLOSE TO Z0MTTT) TO AVOID LONG TEST C OUTPUT FILES. Z0P IS PASSED TO RRPS-T TO CALCULATE TERMS C OF THE POWER SERIES. IF (.NOT. LTRRPS) THEN CALL RRPSM(NCDS, NCDP, NCDCN, NDBIN1, NDBIN2, NDZ0MP, 1 WS, WD, MM, MU, IPXU, IPOFF, Z0M, JMAX, 2 AA, RHOUW, PP, QQ, ADD, BIN, Z0MPOW, 3 LTRRPS, LPRBIN, LPRZ0M, NOUT, 4 CN) ELSE LTRRP1 = ABS(Z0M - Z0MTTT) .LT. Z0MTTD CALL RRPSMT(NCDS, NCDP, NCDCN, NDBIN1, NDBIN2, NDZ0MP, 1 WS, WD, MM, MU, IPXU, IPOFF, Z0M, JMAX, 2 AA, RHOUW, PP, QQ, ADD, BIN, Z0MPOW, 3 LTRRP1, LPRBIN, LPRZ0M, NOUT, 4 CN, Z0P, IPRTTT, IPCTTT) ENDIF ENDIF IF (LOUTA) THEN C C WAVE FUNCTION POWER SERIES. RESULT WRITTEN ON UNIT NOUTB. C IINTL, IINTR ARE BOTH IN COMMON AND DEFINED. CALL WFPS1A(NCDS, NCDCN, NCDINT, 1 IINT, Z0M, Z0P, IINTO, Z0MO, Z0PO, 2 MM, JMAX, IINTL, IINTR, IINTPR, ZMATCH, 3 NOUT, LPRWF, NOUTB, LOUTB, 4 CN, CV, WF, WFD, WFL, WFDL, WFC) IINTO = IINT Z0MO = Z0M Z0PO = Z0P ENDIF C C X(Z0P), X'(Z0P), FROM PREVIOUS INTERVAL. C ADD, SUD CONTAIN TRANSPOSED X, X'. CALL XSUM1B(NCDS, NCDCN, Z0P, Z0M, MM, JMAX, CN, ADD, SUD) IF (LTESTR) XZ0P = ADD(1,1) IF (LOUTC) THEN C C STORE X(Z0P); SECOND INDEX RUNNING FIRST. C ---------------------------------------------------- DO 64 I = 1,MM IREC = 1 + MM + (IINT - 1) * MM + I WRITE (UNIT=NOUTC,REC=IREC) (ADD(I,J), J = 1,MM) 64 CONTINUE C ---------------------------------------------------- ENDIF C C COMPUTE RT(Z0P); STORE IN SUD, TRANSFER TO CN(.,.,2) C (NECESSARY BECAUSE OF XSUM1-); SETTING C(0) = I IS C UNNECESSARY. CALL MAINDB(ADD, SUD, MM, MM, NCDS, NCDS, 1 INDEX, IPIVOT, PIVOT) DO 72 J = 1,MM DO 70 I = 1,MM CN(I,J,2) = SUD(I,J) 70 CONTINUE 72 CONTINUE IF (LTESTR) THEN WRITE (NOUT3,1100) Z0P, XZ0P, CN(1,1,1), CN(1,1,2) CALL CDXFBO(NOUT3) ENDIF GO TO 30 C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 1002 FORMAT ( A 1H , 4HDET:, F24.16, B 5H 10**, I3, C 8H ENERGY, F24.16) 1100 FORMAT (1H , F16.8, 3E20.12) 1200 FORMAT (1H , 2E24.16) END ddot.f000644 000311 000121 00000006756 05311644771 012017 0ustar00krivecf1000000 000000 FUNCTION DDOT(N,DX,INCX,DY,INCY) IMPLICIT REAL*8 (A-H,O-Z) C C FORMS THE DOT PRODUCT OF TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C DDOT = 0.0D0 DTEMP = 0.0D0 IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS C NOT EQUAL TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DTEMP + DX(IX)*DY(IY) IX = IX + INCX IY = IY + INCY 10 CONTINUE DDOT = DTEMP RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DTEMP + DX(I)*DY(I) 30 CONTINUE IF( N .LT. 5 ) GO TO 60 40 MP1 = M + 1 DO 50 I = MP1,N,5 DTEMP = DTEMP + DX(I)*DY(I) + DX(I + 1)*DY(I + 1) + * DX(I + 2)*DY(I + 2) + DX(I + 3)*DY(I + 3) + DX(I + 4)*DY(I + 4) 50 CONTINUE 60 DDOT = DTEMP RETURN END detde.f000644 000311 000121 00000010426 06067230145 012132 0ustar00krivecf1000000 000000 SUBROUTINE DETDE(A, AD, N, M, D, Z, WORK, PR, IPVT, LNORM, A LTEST) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION A(M,M), AD(M,M), Z(M), WORK(M), PR(M), IPVT(M) LOGICAL LNORM, LTEST C C C DETERMINANT EVALUATION (USES LINPACK). ORIGIN: M. HAFTEL. C A = INPUT MATRIX C AD = INPUT MATRIX, BUT THIS IS DESTROYED IN COURSE OF DET C CALCULATION C N = DIMENSION OF SUBMATRIX OF A FOR WHICH DET IS CALCULATED C M = MAX DIMENSION OF A C D = NORMALIZED DETERMINANT IF LNORM = .TRUE.; ELSE ZERO. C NORMALIZATION: DIVIDE BY 10**NDP0, WHERE NDP0 = DET(2) C OF THE FIRST CALL WITH THIS OPTION (LNORM = .TRUE., C IND = 0). THIS PREVENTS OVER/UNDERFLOW. IND, NDP0 MUST C BE SAVED ACROSS CALLS. (NDP0 CAN BE DEFINED ONLY ONCE C IN A GIVEN RUN.) C * ARRAY G ELIMINATED. R. K. C * Z, WORK, PR, IPVT TO ARGUMENTS, R. K. 92/03/12 * C C CHARACTER*6 NAME DATA NAME / 'DETDE ' / CHARACTER*60 VERS DATA VERS */ ' 1.2C, 93/10/18 (DETDD 1.0) (LNORM) ' / C ------------------------------------------------------------ C DIMENSION DET(2) C COMMON / DETER / DM, NDP COMMON / IO / NIN, NOUT C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TEN / 0.D+0, 1.D+0, 10.D+0 / DATA IND, NDP0 / 0, 0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C CHECK THE DIMENSIONS AGAINST THE REFERENCE DIMENSIONS C PASSED BY THE MAIN PROGRAM. IF (N .GT. M) CALL ERR2(NAME, 1, 1, NOUT) C C COMPUTE DESTROYABLE VERSION OF D. DO 12 I = 1,N DO 10 J = 1,N AD(J,I) = A(J,I) 10 CONTINUE 12 CONTINUE C C NORMALIZE EACH COLUMN SEPARATELY. TEST OUTPUT TO LOCATE POSSIBLE C OVERFLOW. NO2 = N / 2 + 1 IF (LTEST) WRITE (NOUT,4100) A NAME, N, NO2, B (NINT(LOG10(MAX(CDXTOL(), ABS(AD(NO2,I))))), I = 1,N) DO 22 I = 1,N PR(I) = AD(NO2,I) DO 20 J = 1,N AD(J,I) = AD(J,I) / PR(I) 20 CONTINUE 22 CONTINUE IF (LTEST) WRITE (NOUT,4200) NAME C C PREPARE MATRIX FOR DETERMINANT EVALUATION. CALL DGECO(AD, M, N, IPVT, RCOND, Z) C C RCOND GIVES PRECISION INFORMATION ON THE DETERMINANT. C THE NUMBER OF PLACES ACCURACY IS APPROXIMATELY THE C NUMBER OF PLACE ACCURACY AVAILABLE ON THE MACHINE PLUS C THE EXPONENT PART OF RCOND (WHICH IS USUALLY NEGATIVE). C C DETERMINANT. THE VALUE IS DET(1) * 10**DET(2). CALL DGEDI(AD, M, N, IPVT, DET, WORK, 10) C C UNDO ROW NORMALIZATION. DO 34 I = 1,N DET(1) = DET(1) * PR(I) IF (DET(1) .EQ. ZERO) GO TO 34 30 IF (ABS(DET(1)) .GE. ONE) GO TO 32 DET(1) = DET(1) * TEN DET(2) = DET(2) - ONE GO TO 30 32 IF (ABS(DET(1)) .LT. TEN) GO TO 34 DET(1) = DET(1) / TEN DET(2) = DET(2) + ONE GO TO 32 34 CONTINUE DM = DET(1) NDP = INT(DET(2)) WRITE (NOUT,3000) NAME, DET, NDP C C OPTIONALLY NORMALIZE DETERMINANT. IF (LNORM) THEN C NORMALIZE DETERMINANT: DIVIDE BY 10**NDP0, WHERE NDP0 = DET(2) C OF THE FIRST CALL WITH THIS OPTION (LNORM = .TRUE., IND = 0). C THIS PREVENTS OVER/UNDERFLOW. IND, NDP0 MUST BE SAVED ACROSS C CALLS. (NDP0 CAN BE DEFINED ONLY ONCE IN A GIVEN RUN.) IF (IND .EQ. 0) THEN NDP0 = NDP IND = 1 ENDIF D = DM * TEN ** (NDP - NDP0) WRITE (NOUT,3200) NAME, RCOND, NDP0, D ELSE C DO NOT NORMALIZE, AND DO NOT CALCULATE D. D = ZERO WRITE (NOUT,3400) NAME, RCOND ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 3000 FORMAT ( A 2H -, A6, 1H-, 12HDET(.), NDP , 2F24.20, I8) 3200 FORMAT ( A 2H -, A6, 1H-, 24HRCOND, NDP0, N. DET.: , E12.2, I8, E24.16) 3400 FORMAT ( A 2H -, A6, 1H-, 24HRCOND: , E12.2) 4100 FORMAT ( A 2H -, A6, 1H-, 24HN, NO2, AD(NO2,.) , 2I8, /, (20I4)) 4200 FORMAT ( A 2H -, A6, 1H-, 24HNORMALIZATION FINISHED. ) END dgeco.f000644 000311 000121 00000033453 05344652030 012131 0ustar00krivecf1000000 000000 SUBROUTINE DGECO(A,LDA,N,IPVT,RCOND,Z) IMPLICIT REAL*8 (A-H,O-Z) INTEGER LDA,N,IPVT(1) REAL*8 A(LDA,1),Z(1) REAL*8 RCOND C C DGECO FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION 00060 C AND ESTIMATES THE CONDITION OF THE MATRIX. C C IF RCOND IS NOT NEEDED, DGEFA IS SLIGHTLY FASTER. C TO SOLVE A*X = B , FOLLOW DGECO BY DGESL. C TO COMPUTE INVERSE(A)*C , FOLLOW DGECO BY DGESL. C TO COMPUTE DETERMINANT(A) , FOLLOW DGECO BY DGEDI. C TO COMPUTE INVERSE(A) , FOLLOW DGECO BY DGEDI. C C ON ENTRY C C A REAL(LDA, N) 00170 C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C RCOND REAL 00370 C AN ESTIMATE OF THE RECIPROCAL CONDITION OF A . C FOR THE SYSTEM A*X = B , RELATIVE PERTURBATIONS C IN A AND B OF SIZE EPSILON MAY CAUSE C RELATIVE PERTURBATIONS IN X OF SIZE EPSILON/RCOND . C IF RCOND IS SO SMALL THAT THE LOGICAL EXPRESSION C 1.0 + RCOND .EQ. 1.0 C IS TRUE, THEN A MAY BE SINGULAR TO WORKING C PRECISION. IN PARTICULAR, RCOND IS ZERO IF C EXACT SINGULARITY IS DETECTED OR THE ESTIMATE C UNDERFLOWS. C C Z REAL(N) 00490 C A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT. C IF A IS CLOSE TO A SINGULAR MATRIX, THEN Z IS C AN APPROXIMATE NULL VECTOR IN THE SENSE THAT C NORM(A*Z) = RCOND*NORM(A)*NORM(Z) . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C LINPACK DGEFA C BLAS DAXPY,DDOT,DSCAL,DASUM C FORTRAN ABS,AMAX1,SIGN C C INTERNAL VARIABLES C REAL*8 DDOT,EK,T,WK,WKM REAL*8 ANORM,S,DASUM,SM,YNORM INTEGER INFO,J,K,KB,KP1,L C C C COMPUTE 1-NORM OF A C ANORM = 0.0D0 DO 10 J = 1, N ANORM = MAX(ANORM,DASUM(N,A(1,J),1)) 10 CONTINUE C C FACTOR C CALL DGEFA(A,LDA,N,IPVT,INFO) C C RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) . C ESTIMATE = NORM(Z)/NORM(Y) WHERE A*Z = Y AND TRANS(A)*Y = E . C TRANS(A) IS THE TRANSPOSE OF A . THE COMPONENTS OF E ARE C CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W WHERE C TRANS(U)*W = E . THE VECTORS ARE FREQUENTLY RESCALED TO AVOID C OVERFLOW. C C SOLVE TRANS(U)*W = E C EK = 1.0D0 DO 20 J = 1, N Z(J) = 0.0D0 20 CONTINUE DO 100 K = 1, N IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,-Z(K)) IF (ABS(EK-Z(K)) .LE. ABS(A(K,K))) GO TO 30 S = ABS(A(K,K))/ABS(EK-Z(K)) CALL DSCAL(N,S,Z,1) EK = S*EK 30 CONTINUE WK = EK - Z(K) WKM = -EK - Z(K) S = ABS(WK) SM = ABS(WKM) IF (A(K,K) .EQ. 0.0D0) GO TO 40 WK = WK/A(K,K) WKM = WKM/A(K,K) GO TO 50 40 CONTINUE WK = 1.0D0 WKM = 1.0D0 50 CONTINUE KP1 = K + 1 IF (KP1 .GT. N) GO TO 90 DO 60 J = KP1, N SM = SM + ABS(Z(J)+WKM*A(K,J)) Z(J) = Z(J) + WK*A(K,J) S = S + ABS(Z(J)) 60 CONTINUE IF (S .GE. SM) GO TO 80 T = WKM - WK WK = WKM DO 70 J = KP1, N Z(J) = Z(J) + T*A(K,J) 70 CONTINUE 80 CONTINUE 90 CONTINUE Z(K) = WK 100 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C C SOLVE TRANS(L)*Y = W C DO 120 KB = 1, N K = N + 1 - KB IF (K .LT. N) Z(K) = Z(K) + DDOT(N-K,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0D0) GO TO 110 S = 1.0D0/ABS(Z(K)) CALL DSCAL(N,S,Z,1) 110 CONTINUE L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T 120 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) C YNORM = 1.0D0 C C SOLVE L*V = Y C DO 140 K = 1, N L = IPVT(K) T = Z(L) Z(L) = Z(K) Z(K) = T IF (K .LT. N) CALL DAXPY(N-K,T,A(K+1,K),1,Z(K+1),1) IF (ABS(Z(K)) .LE. 1.0D0) GO TO 130 S = 1.0D0/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 130 CONTINUE 140 CONTINUE S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C C SOLVE U*Z = V C DO 160 KB = 1, N K = N + 1 - KB IF (ABS(Z(K)) .LE. ABS(A(K,K))) GO TO 150 S = ABS(A(K,K))/ABS(Z(K)) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM 150 CONTINUE IF (A(K,K) .NE. 0.0D0) Z(K) = Z(K)/A(K,K) IF (A(K,K) .EQ. 0.0D0) Z(K) = 1.0D0 T = -Z(K) CALL DAXPY(K-1,T,A(1,K),1,Z(1),1) 160 CONTINUE C MAKE ZNORM = 1.D0 S = 1.0D0/DASUM(N,Z,1) CALL DSCAL(N,S,Z,1) YNORM = S*YNORM C IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0 RETURN END dgedi.f000644 000311 000121 00000022302 05311644772 012123 0ustar00krivecf1000000 000000 SUBROUTINE DGEDI(A,LDA,N,IPVT,DET,WORK,JOB) IMPLICIT REAL*8 (A-H,O-Z) INTEGER LDA,N,IPVT(1),JOB REAL*8 A(LDA,1),DET(2),WORK(1) C C DGEDI COMPUTES THE DETERMINANT AND INVERSE OF A MATRIX C USING THE FACTORS COMPUTED BY DGECO OR DGEFA. C C ON ENTRY C C A REAL(LDA, N) 00100 C THE OUTPUT FROM DGECO OR DGEFA. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C IPVT INTEGER(N) C THE PIVOT VECTOR FROM DGECO OR DGEFA. C C WORK REAL(N) C WORK VECTOR. CONTENTS DESTROYED. C C JOB INTEGER C = 11 BOTH DETERMINANT AND INVERSE. C = 01 INVERSE ONLY. C = 10 DETERMINANT ONLY. C C ON RETURN C C A INVERSE OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE UNCHANGED. C C DET REAL(2) 00350 C DETERMINANT OF ORIGINAL MATRIX IF REQUESTED. C OTHERWISE NOT REFERENCED. C DETERMINANT = DET(1) * 10.0**DET(2) C WITH 1.0 .LE. ABS(DET(1)) .LT. 10.0 C OR DET(1) .EQ. 0.0 . C C ERROR CONDITION C C A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS C A ZERO ON THE DIAGONAL AND THE INVERSE IS REQUESTED. C IT WILL NOT OCCUR IF THE SUBROUTINES ARE CALLED CORRECTLY C AND IF DGECO HAS SET RCOND .GT. 0.0 OR DGEFA HAS SET C INFO .EQ. 0 . C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,DSWAP C FORTRAN ABS,MOD C C INTERNAL VARIABLES C REAL*8 T REAL*8 TEN INTEGER I,J,K,KB,KP1,L,NM1 C C C COMPUTE DETERMINANT C IF (JOB/10 .EQ. 0) GO TO 70 DET(1) = 1.0D0 DET(2) = 0.0D0 TEN = 10.0D0 DO 50 I = 1, N IF (IPVT(I) .NE. I) DET(1) = -DET(1) DET(1) = A(I,I)*DET(1) C ...EXIT IF (DET(1) .EQ. 0.0D0) GO TO 60 10 IF (ABS(DET(1)) .GE. 1.0D0) GO TO 20 DET(1) = TEN*DET(1) DET(2) = DET(2) - 1.0D0 GO TO 10 20 CONTINUE 30 IF (ABS(DET(1)) .LT. TEN) GO TO 40 DET(1) = DET(1)/TEN DET(2) = DET(2) + 1.0D0 GO TO 30 40 CONTINUE 50 CONTINUE 60 CONTINUE 70 CONTINUE C C COMPUTE INVERSE(U) C IF (MOD(JOB,10) .EQ. 0) GO TO 150 DO 100 K = 1, N A(K,K) = 1.0D0/A(K,K) T = -A(K,K) CALL DSCAL(K-1,T,A(1,K),1) KP1 = K + 1 IF (N .LT. KP1) GO TO 90 DO 80 J = KP1, N T = A(K,J) A(K,J) = 0.0D0 CALL DAXPY(K,T,A(1,K),1,A(1,J),1) 80 CONTINUE 90 CONTINUE 100 CONTINUE C C FORM INVERSE(U)*INVERSE(L) C NM1 = N - 1 IF (NM1 .LT. 1) GO TO 140 DO 130 KB = 1, NM1 K = N - KB KP1 = K + 1 DO 110 I = KP1, N WORK(I) = A(I,K) A(I,K) = 0.0D0 110 CONTINUE DO 120 J = KP1, N T = WORK(J) CALL DAXPY(N,T,A(1,J),1,A(1,K),1) 120 CONTINUE L = IPVT(K) IF (L .NE. K) CALL DSWAP(N,A(1,K),1,A(1,L),1) 130 CONTINUE 140 CONTINUE 150 CONTINUE RETURN END dgefa.f000644 000311 000121 00000016645 05311644772 012132 0ustar00krivecf1000000 000000 SUBROUTINE DGEFA(A,LDA,N,IPVT,INFO) IMPLICIT REAL*8 (A-H,O-Z) INTEGER LDA,N,IPVT(1),INFO REAL*8 A(LDA,1) C C DGEFA FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION. 00050 C C DGEFA IS USUALLY CALLED BY DGECO, BUT IT CAN BE CALLED C DIRECTLY WITH A SAVING IN TIME IF RCOND IS NOT NEEDED. C (TIME FOR DGECO) = (1 + 9/N)*(TIME FOR DGEFA) . C C ON ENTRY C C A REAL(LDA, N) 00130 C THE MATRIX TO BE FACTORED. C C LDA INTEGER C THE LEADING DIMENSION OF THE ARRAY A . C C N INTEGER C THE ORDER OF THE MATRIX A . C C ON RETURN C C A AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS C WHICH WERE USED TO OBTAIN IT. C THE FACTORIZATION CAN BE WRITTEN A = L*U WHERE C L IS A PRODUCT OF PERMUTATION AND UNIT LOWER C TRIANGULAR MATRICES AND U IS UPPER TRIANGULAR. C C IPVT INTEGER(N) C AN INTEGER VECTOR OF PIVOT INDICES. C C INFO INTEGER C = 0 NORMAL VALUE. C = K IF U(K,K) .EQ. 0.0 . THIS IS NOT AN ERROR C CONDITION FOR THIS SUBROUTINE, BUT IT DOES C INDICATE THAT DGESL OR DGEDI WILL DIVIDE BY ZERO C IF CALLED. USE RCOND IN DGECO FOR A RELIABLE C INDICATION OF SINGULARITY. C C LINPACK. THIS VERSION DATED 08/14/78 . C CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB. C C SUBROUTINES AND FUNCTIONS C C BLAS DAXPY,DSCAL,IDAMAX C C INTERNAL VARIABLES C REAL*8 T INTEGER IDAMAX,J,K,KP1,L,NM1 C C C GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING C INFO = 0 NM1 = N - 1 IF (NM1 .LT. 1) GO TO 70 DO 60 K = 1, NM1 KP1 = K + 1 C C FIND L = PIVOT INDEX C L = IDAMAX(N-K+1,A(K,K),1) + K - 1 IPVT(K) = L C C ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED C IF (A(L,K) .EQ. 0.0D0) GO TO 40 C C INTERCHANGE IF NECESSARY C IF (L .EQ. K) GO TO 10 T = A(L,K) A(L,K) = A(K,K) A(K,K) = T 10 CONTINUE C C COMPUTE MULTIPLIERS C T = -1.0D0/A(K,K) CALL DSCAL(N-K,T,A(K+1,K),1) C C ROW ELIMINATION WITH COLUMN INDEXING C DO 30 J = KP1, N T = A(L,J) IF (L .EQ. K) GO TO 20 A(L,J) = A(K,J) A(K,J) = T 20 CONTINUE CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1) 30 CONTINUE GO TO 50 40 CONTINUE INFO = K 50 CONTINUE 60 CONTINUE 70 CONTINUE IPVT(N) = N IF (A(N,N) .EQ. 0.0D0) INFO = N RETURN END dm1de.f000644 000311 000121 00000011712 06067230147 012040 0ustar00krivecf1000000 000000 SUBROUTINE DM1DE(ND, NOUT, 1 N, A, A1, B, C, BD, CD, 2 INDEX, IPIVOT, PIVOT, PIVOTX, 3 Z, WORK, PR, IPVT, LDOUBL, 4 LPR, LPRMAT, LTDET, I0D, J0, X) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION A(ND,ND), A1(ND,ND), B(ND,ND), C(ND), 1 INDEX(ND,2), IPIVOT(ND), PIVOT(ND), 2 Z(ND), WORK(ND), PR(ND), IPVT(ND) C ************** REAL*16 BD(ND,ND), CD(ND), PIVOTX(ND) C ************** DIMENSION X(ND) LOGICAL LDOUBL, LPR, LPRMAT, LTDET C C C A SOLUTION OF THE SYSTEM A X = 0 WHERE DET(A) IS NEARLY C ZERO. C C THIS OCCURS FOR EXAMPLE IF DET(A) IS NOT EXACTLY C ZERO TO NUMERICAL INACCURACIES IN ITS CALCULATION. C C AN INHOMOGENEOUS SYSTEM IS MADE OUT OF THE ORIGINAL C ONE BY SETTING X(J0) = 1, AND IGNORING THE J0-TH EQUATION. C C THE PRESENT VERSION SETS J0 = 1 AND I0 = N - I0D, WHERE I0D C IS AN INPUT PARAMETER (A CHOICE OF PRINCIPLE IS I0 = N, THE C LAST EQUATION IGNORED). C C PARAMETERS (SUBSET): C I0D - INPUT. UNCHANGED. C J0 - OUTPUT. UNCHANGED. C ARRAYS: C A - INPUT MATRIX. UNCHANGED ON EXIT. C X - OUTPUT SOLUTION VECTOR. C ... - ALL OTHER ARRAYS ARE WORKING ARRAYS. C C (AN AUXILIARY WAVE FUNCTION MATCHING ROUTINE - PART OF THE C ORIGINAL ROUTINE D FROM THE WAVE FUNCTION PACKAGE.) C C CHARACTER*6 NAME DATA NAME / 'DM1DE ' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 94/10/20. -D 1.4, 94/10/19. I0D; SOLUTION TEST ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE / 1.D0 / C C COMMON / DETER / DM, NDP C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (N .GT. ND) CALL ERR2(NAME, 1, 1, NOUT) IF (N .LE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (I0D .LT. 0) CALL ERR2(NAME, 3, 1, NOUT) IF (I0D .GE. N) CALL ERR2(NAME, 4, 1, NOUT) C C DEFINE THE IGNORED ROW AND THE TRANSFERRED COLUMN OF A . I0 = N - I0D J0 = 1 C C CONVERT HOMOGENEOUS EQUATION TO INHOMOGENEOUS WITH THE C RIGHT HAND SIDE EQUAL TO J0-TH COLUMN OF A . IP = 0 DO 22 I = 1,N C C SKIP I0-TH ROW OF MATRIX. IF (I .EQ. I0) GO TO 22 IP = IP + 1 JP = 0 DO 20 J = 1,N C C SKIP J0-TH COLUMN OF A . IF (J .EQ. J0) GO TO 20 JP = JP + 1 B(IP,JP) = A(I,J) 20 CONTINUE C C TRANSFER J0-TH COLUMN TO RHS. C(IP) = -A(I,J0) 22 CONTINUE IF (LPR) THEN C C TEST OUTPUT (LOG SCALE TO MAKE IT SHORT). WRITE (NOUT,3010) NAME DO 24 I = 1,N WRITE (NOUT,3020) I, 1 (NINT(LOG10(MAX(CDXTOL(), ABS(A(I,J))))), J = 1,N) 24 CONTINUE WRITE (NOUT,3012) NAME N1 = N - 1 DO 26 I = 1,N1 WRITE (NOUT,3020) I, 1 (NINT(LOG10(MAX(CDXTOL(), ABS(B(I,J))))), J = 1,N1), 2 NINT(LOG10(MAX(CDXTOL(), ABS(C(I) )))) 26 CONTINUE ENDIF C C COMPUTE DETERMINANT OF REDUCED MATRIX; LINPACK WILL RETURN C A VARIABLE WHICH GIVES ESTIMATE OF PRECISION OF SOLUTION. C DO NOT NORMALIZE DETERMINANT (WOULD USE NORMALIZATION FROM C ITERATION IF PERFORMED) (DX RETURNED AS 0 BY DETDE). WRITE (NOUT,3102) NAME N1 = N - 1 CALL DETDE(B, A1, N1, ND, DX, Z, WORK, PR, IPVT, .FALSE., LTDET) WRITE (NOUT,3100) NAME C C COMPUTE SOLUTION X . THE J0-TH ELEMENT IS 1. CALL MAIXDC(B, C, BD, CD, N1, 1, ND, 1, LDOUBL, 1 INDEX, IPIVOT, PIVOT, PIVOTX, LPRMAT) WRITE (NOUT,3110) NAME, I0, J0 IP = 0 DO 28 I = 1,N C C SKIP J0-TH ELEMENT. IF (I .EQ. J0) GO TO 28 IP = IP + 1 X(I) = C(IP) 28 CONTINUE X(J0) = ONE WRITE (NOUT,3120) NAME, I0, J0 IF (LPR) THEN C C TEST THE SOLUTION BY MULTIPLYING A * X. DO 32 J = 1,N DO 30 I = 1,N C(I) = A(I,J) * X(J) 30 CONTINUE 32 CONTINUE WRITE (NOUT,3200) NAME, (I, X(I), C(I), I = 1,N) ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 3010 FORMAT ( A 2H -, A6, 1H-, 28HORIGINAL MATRIX: ) 3012 FORMAT ( A 2H -, A6, 1H-, 28HREDUCED MATRIX; R.H.S.: ) 3020 FORMAT ( A 1H , I4, /, (20I4)) 3100 FORMAT ( A 2H -, A6, 1H-, 28HDETD- FINISHED. ) 3102 FORMAT ( A 2H -, A6, 1H-, 32HDETD- UNN. DET. OF RED. MATRIX: ) 3110 FORMAT ( A 2H -, A6, 1H-, 28HMAIXD- FINISHED. , 2I8) 3120 FORMAT ( A 2H -, A6, 1H-, 28HFINISHED. , 2I8) 3200 FORMAT ( A 2H -, A6, 1H-, 28HX; A * X (TEST) , /, B (1H , I4, E24.16, E12.4)) END dscal.f000644 000311 000121 00000005771 05311644772 012150 0ustar00krivecf1000000 000000 SUBROUTINE DSCAL(N,DA,DX,INCX) IMPLICIT REAL*8 (A-H,O-Z) C C SCALES A VECTOR BY A CONSTANT. C USES UNROLLED LOOPS FOR INCREMENT EQUAL TO ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DA,DX(1) INTEGER I,INCX,M,MP1,N,NINCX C IF(N.LE.0)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C NINCX = N*INCX DO 10 I = 1,NINCX,INCX DX(I) = DA*DX(I) 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,5) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DX(I) = DA*DX(I) 30 CONTINUE IF( N .LT. 5 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,5 DX(I) = DA*DX(I) DX(I + 1) = DA*DX(I + 1) DX(I + 2) = DA*DX(I + 2) DX(I + 3) = DA*DX(I + 3) DX(I + 4) = DA*DX(I + 4) 50 CONTINUE RETURN END dswap.f000644 000311 000121 00000007767 05311644772 012207 0ustar00krivecf1000000 000000 SUBROUTINE DSWAP(N,DX,INCX,DY,INCY) IMPLICIT REAL*8 (A-H,O-Z) C C INTERCHANGES TWO VECTORS. C USES UNROLLED LOOPS FOR INCREMENTS EQUAL ONE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DX(1),DY(1),DTEMP INTEGER I,INCX,INCY,IX,IY,M,MP1,N C IF(N.LE.0)RETURN IF(INCX.EQ.1.AND.INCY.EQ.1)GO TO 20 C C CODE FOR UNEQUAL INCREMENTS OR EQUAL INCREMENTS NOT EQUAL C TO 1 C IX = 1 IY = 1 IF(INCX.LT.0)IX = (-N+1)*INCX + 1 IF(INCY.LT.0)IY = (-N+1)*INCY + 1 DO 10 I = 1,N DTEMP = DX(IX) DX(IX) = DY(IY) DY(IY) = DTEMP IX = IX + INCX IY = IY + INCY 10 CONTINUE RETURN C C CODE FOR BOTH INCREMENTS EQUAL TO 1 C C C CLEAN-UP LOOP C 20 M = MOD(N,3) IF( M .EQ. 0 ) GO TO 40 DO 30 I = 1,M DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP 30 CONTINUE IF( N .LT. 3 ) RETURN 40 MP1 = M + 1 DO 50 I = MP1,N,3 DTEMP = DX(I) DX(I) = DY(I) DY(I) = DTEMP DTEMP = DX(I + 1) DX(I + 1) = DY(I + 1) DY(I + 1) = DTEMP DTEMP = DX(I + 2) DX(I + 2) = DY(I + 2) DY(I + 2) = DTEMP 50 CONTINUE RETURN END dwfpdf.f000644 000311 000121 00000024673 06067230151 012325 0ustar00krivecf1000000 000000 SUBROUTINE DWFPDF(NDS, NDINT, NOUT, NOUTC, 1 ZMATCH, MM, RR, IBL, IBR, 2 XX, RX, RX1, RXL, RXR, RXLD, RXRD, 3 INDEX, IPIVOT, PIVOT, PIVOTX, 4 Z, WORK, PR, IPVT, LDOUBL, LDOUBM, 5 CHI0, CWFD, 6 LPR, LPRXX, LPRCV, LPRCVM, LPRMAT, LTDET, 7 I0D, J0, CV) IMPLICIT REAL*8 (A-H, O-Z) C DIMENSION RR(NDS,NDS), XX(NDS,NDS), 1 RX(NDS,NDS), RX1(NDS,NDS), RXL(NDS,NDS), RXR(NDS), 2 INDEX(NDS,2), IPIVOT(NDS), PIVOT(NDS), 3 Z(NDS), WORK(NDS), PR(NDS), IPVT(NDS), 4 CHI0(NDS), CV(NDS,NDINT) C ************** REAL*16 RXLD(NDS,NDS), RXRD(NDS), CWFD(NDS), PIVOTX(NDS) C ************** LOGICAL LDOUBL, LDOUBM, LPR, LPRXX, LPRCV, LPRCVM, LPRMAT, A LTDET C C C FINDS THE MATCHING VECTORS GIVING THE WAVE FUNCTION AT C Z = ZMATCH AND PROPAGATES THESE VECTORS TOWARD Z = ZTOP AND Z = 0. C C INPUT: C MM C OUTPUT: C CV - MATCHING VECTORS. C OTHER ARRAYS ARE WORKING ARRAYS: C RR - (R(-) - R(+))(ZMATCH) TRANSPOSE. THIS IS READ FROM C FILE (NO TRANSPOSITIONS). C XX - READ FROM FILE (NOT TRANSPOSED, BUT WAS WRITTEN C TRANSPOSED - CHECK WRITING ROUTINE DD--). C C IBL, IBR ARE LEFT AND RIGHT INTERVAL AT Z = ZMATCH (IBR IS ALSO C THE LAST INTERVAL OF THE PORPAGATION). C C IBL, IBR FROM FILE OVERRIDE IBL, IBR PASSED AS FORMAL ARGUMENTS. C C (IF RESTART IS FROM THIS ROUTINE, IBL, IBR ARE UNDEFINED AT C CALL TIME. IBL, IBR ARE THEN RETURNED, AND PUT IN COMMON BY C CALLING PROGRAM, TO BE PASSED TO DD--. IF RESTART IS BY CALLING C DD-- FIRST, IBL, IBR ARE DEFINED ON INPUT AND COMPARED WITH C FILE VALUES; WARNING MESSAGES ARE ISSUED.) C C CHARACTER*6 NAME DATA NAME / 'DWFPDF' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 94/10/20 -E 1.1C, 94/09/29. 1.1 93/10/20. DM1DE ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / C COMMON / MACH / MACHN COMMON / DETER / DM, NDP C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (MM .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (MM .LE. 1) CALL ERR2(NAME, 2, 1, NOUT) C C OPEN RADIAL SOLUTION STORAGE FILE (DIRECT ACCESS). C RECL UNITS: CONVEX - BYTES, VAX - LONGWORDS, IBM - BYTES. IF (MACHN .EQ. 1) THEN C VAX. OPEN (UNIT=NOUTC, RECL=MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='OLD') ELSE IF (MACHN .EQ. 2) THEN C CONVEX (REMOVED RECORDTYPE). OPEN (UNIT=NOUTC, RECL=8*MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='OLD') ELSE IF (MACHN .EQ. 3) THEN C IBM. OPEN (UNIT=NOUTC, RECL=8*MM, 1 ACCESS='DIRECT', FORM='UNFORMATTED', 2 STATUS='OLD') ENDIF C C C CALCULATE CV(+). C ================ C C READ IBL, IBR. WARNINGS ONLY; OVERWRITE IBL, IBR. C ------------------------------------- IREC = 1 READ (UNIT=NOUTC,REC=IREC) IBLX, IBRX C ------------------------------------- IF (IBLX .NE. IBL) CALL ERR2(NAME, 31, 0, NOUT) IF (IBRX .NE. IBR) CALL ERR2(NAME, 32, 0, NOUT) IBL = IBLX IBR = IBRX IF (IBL .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (IBL .GT. IBR) CALL ERR2(NAME, 4, 1, NOUT) IF (IBR .GT. NDINT) CALL ERR2(NAME, 5, 1, NOUT) C C READ RT(-) - RT(+). NO TRANSPOSITION. C -------------------------------------------------- DO 10 I = 1,MM IREC = 1 + I READ (UNIT=NOUTC,REC=IREC) (RR(J,I), J = 1,MM) 10 CONTINUE C -------------------------------------------------- C C READ X(+). XX CONTAINS UNTRANSPOSED X(+). C -------------------------------------------------- DO 20 I = 1,MM IREC = 1 + MM + (IBR - 1) * MM + I READ (UNIT=NOUTC,REC=IREC) (XX(J,I), J = 1,MM) 20 CONTINUE C -------------------------------------------------- C C (R(-) - R(+)) * X(+)(ZMATCH). DO 24 J = 1,MM DO 22 I = 1,MM RX(I,J) = ZERO 22 CONTINUE 24 CONTINUE DO 30 J = 1,MM DO 28 I = 1,MM DO 26 K = 1,MM RX(I,J) = RX(I,J) + RR(K,I) * XX(K,J) 26 CONTINUE 28 CONTINUE 30 CONTINUE IF (LPRXX) THEN C OUTPUT RR, X(+). WRITE (NOUT,3050) NAME DO 32 I = 1,MM WRITE (NOUT,3020) I, (RR(J,I), J = 1,MM) 32 CONTINUE WRITE (NOUT,3052) NAME DO 34 I = 1,MM WRITE (NOUT,3020) I, (XX(I,J), J = 1,MM) 34 CONTINUE ENDIF C C SOLVE THE SYSTEM FOR CV(+) . C (J0 IS DEFINED IN DM1D- ; THIS COULD BE CHANGED BY C READING IT FROM INPUT.) C CONTINUITY OF XPHYS, XPHYS' AT Z = ZMATCH IS ENSURED BY C (R(-) - R(+)) X(+) CV(+) = 0. C THIS REQUIRES DET(R(-) - R(+)) = 0. C THIS IS NEVER TRUE EXACTLY; IT IS ASSUMED THE DETERMINANT C IS SMALL. METHOD OF SOLUTION: C WE SET CV(+)(1) = 1, AND IGNORE THE N-I0D-TH (USUALLY LAST) C EQUATION. (THE LAST EQUATION WILL BE SATISFIED ONLY TO THE C DEGREE THAT THE DETERMINANT IS SMALL.) C ( RX IS THE ONLY INPUT FOR DM1D- ; OTHER ARRAYS ARE WORKING C ARRAYS ONLY.) CALL DM1DE(NDS, NOUT, 1 MM, RX, RX1, RXL, RXR, RXLD, RXRD, 2 INDEX, IPIVOT, PIVOT, PIVOTX, Z, WORK, PR, IPVT, 3 LDOUBM, LPRCVM, LPRMAT, LTDET, I0D, J0, CV(1,IBR)) IF (LPR) WRITE (NOUT,3000) NAME, DM, NDP IF (LPRCV) WRITE (NOUT,3032) IBR, (CV(I,IBR), I = 1,MM) C C COMPUTE XPHYS(+)(ZMATCH) AND STORE IN CHI0 . DO 42 I = 1,MM CHI0(I) = ZERO DO 40 K = 1,MM CHI0(I) = CHI0(I) + XX(I,K) * CV(K,IBR) 40 CONTINUE 42 CONTINUE C C C CALCULATE CV(-). C ================ C C READ X(-). XX CONTAINS UNTRANSPOSED X(-). C -------------------------------------------------- DO 44 I = 1,MM IREC = 1 + MM + (IBL - 1) * MM + I READ (UNIT=NOUTC,REC=IREC) (XX(J,I), J = 1,MM) 44 CONTINUE C -------------------------------------------------- IF (LPRXX) THEN C OUTPUT X(-). WRITE (NOUT,3010) NAME DO 46 I = 1,MM WRITE (NOUT,3020) I, (XX(I,J), J = 1,MM) 46 CONTINUE ENDIF C C COMPUTE DET(X(-)) FOR LINPACK ESTIMATE OF PRECISION. C DO NOT NORMALIZE. DXL = 0 AS RETURNED BY DETDE. CALL DETDE(XX, RX1, MM, NDS, DXL, Z, WORK, PR, IPVT, .FALSE., A LTDET) IF (LPR) WRITE (NOUT,3002) NAME, DM, NDP C C SET RHS OF X(-) * CV(-) = XPHYS(+) ; THIS ENFORCES WAVE C FUNCTION CONTINUITY AT Z = ZMATCH. DO 48 I = 1,MM CV(I,IBL) = CHI0(I) 48 CONTINUE C C COMPUTE CV(-) INTO CV(IBL). CALL MAIXDC(XX, CV(1,IBL), RXLD, CWFD, MM, 1, NDS, 1, LDOUBL, 1 INDEX, IPIVOT, PIVOT, PIVOTX, LPRMAT) IF (LPRCV) THEN C OUTPUT CV(-). WRITE (NOUT,3012) NAME WRITE (NOUT,3032) IBL, (CV(I,IBL), I = 1,MM) ENDIF C C C PROPAGATE THE WAVE FUNCTION. C ============================ C C COMPUTE CV IN OTHER INTERVALS; FIRST IN THE INTERVALS C RIGHT OF ZMATCH (ZONE 1) AND THEN IN THE INTERVALS C LEFT OF ZMATCH (ZONE 2); ALWAYS PROCEED AWAY FROM ZMATCH. C SET INTERVAL NUMBER LIMITS FOR EACH ZONE. IF (LPRCV) WRITE (NOUT,3030) NAME, IBL, IBR DO 56 IZONE = 1,2 C C LOOP OVER INTERVALS. IF (IZONE .EQ. 1) THEN IB1X = IBR - 1 IB2X = IBL + 1 ELSE IB1X = IBL - 1 IB2X = 1 ENDIF NBX = IB1X - IB2X + 1 IF (NBX .LE. 0) GO TO 56 DO 54 IBX = 1,NBX IBP = IB1X - IBX + 1 DO 50 I = 1,MM CV(I,IBP) = CV(I,IBP+1) 50 CONTINUE C C READ X(IBP). XX CONTAINS UNTRANSPOSED X(IBP). C -------------------------------------------------- DO 52 I = 1,MM IREC = 1 + MM + (IBP - 1) * MM + I READ (UNIT=NOUTC,REC=IREC) (XX(J,I), J = 1,MM) 52 CONTINUE C -------------------------------------------------- C C COMPUTE CV(IBP); IT SATISFIES C X(AT BOUNDARY FOR NEW INTERVAL) * CV(IBP) = C XPHYS(AT BOUNDARY FOR PREVIOUS INTERVAL); C XX(IBP) = X(Z0P) (LAST Z OF INTERVAL IBP). CALL MAIXDC(XX, CV(1,IBP), 1 RXLD, CWFD, MM, 1, NDS, 1, LDOUBL, 2 INDEX, IPIVOT, PIVOT, PIVOTX, LPRMAT) IF (LPRCV) WRITE (NOUT,3032) IBP, (CV(I,IBP), I = 1,MM) 54 CONTINUE 56 CONTINUE C C COMPUTE MEASURE OF DISCONTINUITY AT Z = ZMATCH. DISC = ZERO DO 62 I = 1,MM DO 60 J = 1,MM DISC = DISC + CHI0(I) * CHI0(J) * RR(J,I) 60 CONTINUE 62 CONTINUE DISC = -ZMATCH * DISC IF (LPR) THEN C PRINT CV COEFFICIENTS FOR INTERVALS 1, IBL, AND IBR. WRITE (NOUT,3040) NAME, DISC DO 64 I = 1,MM WRITE (NOUT,3042) I, CV(I,1), CV(I,IBL), CV(I,IBR) 64 CONTINUE END IF CLOSE (UNIT=NOUTC) RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 3000 FORMAT ( A 2H -, A6, 1H-, 32HCV(+) SYSTEM SOLUTION: DET. = , B F24.16, 5H 10**, I3) 3002 FORMAT ( A 2H -, A6, 1H-, 32HDETERMINANT OF X(-): , B F24.16, 5H 10**, I3) 3010 FORMAT ( A 2H -, A6, 1H-, 28HX(-) MATRIX: ) 3012 FORMAT ( A 2H -, A6, 1H-, 28HCV(-) SOLUTION: ) 3020 FORMAT ( A 1H , I4, 4D16.8, /, (D21.8, 3D16.8)) 3030 FORMAT ( A 2H -, A6, 1H-, 12HIBL, IBR: , 2I4, /, B 1H , 44HWF PROPAGATION: LINEAR COMBINATION VECTORS: ) 3032 FORMAT ( A 1H , I4, 4D16.8, /, (D21.8, 3D16.8)) 3040 FORMAT ( A 2H -, A6, 1H-, 28HDISCONTINUITY AT Z = ZMATCH:, D12.3, /, B 1H , 48HLINEAR COMBINATION VECTORS CV(1), CV(-), CV(+): ) 3042 FORMAT ( A 1H , I4, 3D16.8) 3050 FORMAT ( A 2H -, A6, 1H-, 28HR(-) - R(+) MATRIX: ) 3052 FORMAT ( A 2H -, A6, 1H-, 28HX(+) MATRIX: ) END epioa.f000644 000311 000121 00000010225 06067230153 012136 0ustar00krivecf1000000 000000 SUBROUTINE EPIOA(MODE, NIN, NOUT, NIN1, NOUT1, 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, A, B, EPSP, TOL, DZU, 3 ZM, ZMATCH, ZTOP, NHH, 4 LMOD, ENXL, ENXU, ENXS, 5 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT) IMPLICIT REAL*8 (A-H, O-Z) C C READS / WRITES PARAMETERS FOR THE ENERGY SEARCH. C MODE = 1 USED IN COULDR, MODE = 2 USED IN AVERAGES PROGRAM. C CHARACTER*6 NAME DATA NAME / 'EPIOA ' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/10/24. ' / C ------------------------------------------------------------ C LOGICAL LCALL0, LIF, LIU, LOF, LOU DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (MODE .LT. 1 .OR. MODE .GT. 2) CALL ERR2(NAME, 1, 1, NOUT) C LIF = MODE .EQ. 1 LOF = MODE .EQ. 1 .OR. MODE .EQ. 2 LIU = MODE .EQ. 2 LOU = MODE .EQ. 1 C IF (LIF) THEN READ (NIN,1020) IPWUU, NSU, INUSEL READ (NIN,1020) NM, JMAX READ (NIN,1030) BC0, BC1, RHOUW READ (NIN,1032) A, B READ (NIN,1040) EPSP, TOL, DZU READ (NIN,1030) ZM, ZMATCH, ZTOP READ (NIN,1020) NHH READ (NIN,1020) LMOD READ (NIN,1032) ENXL, ENXU, ENXS READ (NIN,1020) IPIO READ (NIN,1034) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF C IF (LIU) THEN READ (NIN1) IPWUU, NSU, INUSEL READ (NIN1) NM, JMAX READ (NIN1) BC0, BC1, RHOUW READ (NIN1) A, B READ (NIN1) EPSP, TOL, DZU READ (NIN1) ZM, ZMATCH, ZTOP READ (NIN1) NHH READ (NIN1) LMOD READ (NIN1) ENXL, ENXU, ENXS READ (NIN1) IPIO READ (NIN1) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF C IF (LOF) WRITE (NOUT,4100) 1 IPWUU, NSU, INUSEL, NM, JMAX, 2 BC0, BC1, RHOUW, 3 A, B, 4 EPSP, TOL, DZU, 5 ZM, ZMATCH, ZTOP, 6 NHH, 7 LMOD, ENXL, ENXU, ENXS, 8 IPIO, Z0MTTT, Z0MTTD, IPRTTT, IPCTTT C IF (LOU) THEN WRITE (NOUT1) IPWUU, NSU, INUSEL WRITE (NOUT1) NM, JMAX WRITE (NOUT1) BC0, BC1, RHOUW WRITE (NOUT1) A, B WRITE (NOUT1) EPSP, TOL, DZU WRITE (NOUT1) ZM, ZMATCH, ZTOP WRITE (NOUT1) NHH WRITE (NOUT1) LMOD WRITE (NOUT1) ENXL, ENXU, ENXS WRITE (NOUT1) IPIO WRITE (NOUT1) Z0MTTT, Z0MTTD, IPRTTT, IPCTTT ENDIF RETURN C 1020 FORMAT (20I4) 1030 FORMAT (10F8.2) 1032 FORMAT (4F16.12) 1034 FORMAT (2F8.2, 2I4) 1040 FORMAT (5D16.7) C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 4100 FORMAT ( 1 1H , 20HIPWUU, NSU, INUSEL , 2I8, I4, /, 2 1H , 20HNM, JMAX , 2I4, /, 3 1H , 20HBC0, BC1, RHOUW , 2F12.4, F12.2, /, 4 1H , 20HA, B , 2F20.12, /, 5 1H , 20HEPSP, TOL, DZU , D16.4, F12.6, F12.2, //, 6 1H , 20HZM, ZMATCH, ZTOP , F12.4, 2F12.2, /, 7 1H , 20HNHH , I8, //, 8 1H , 20HLMOD , I4, /, 9 1H , 20HENXL, ENXU, ENXS , 3F18.12, /, A 1H , 20HIPIO , I4, /, B 1H , 20H(Z0MTTT, Z0MTTD),R,C, 2F12.6, 2I4) END ewf2zc.f000644 000311 000121 00000013665 06067230160 012252 0ustar00krivecf1000000 000000 SUBROUTINE EWF2ZC(F, A, B, ITCU, HH, EPSF, EPSP, FF, Z, P, NZ, 1 ENXL, ENXU, ENXS, NOUT, NIN20, 2 NREADE, IPROG, ITC, 3 LXLAST, LTEST, LTIF) IMPLICIT REAL*8 (A-H,O-Z) DIMENSION FF(NZ), Z(NZ), P(NZ) LOGICAL LXLAST, LTEST, LTIF C C THIS ROUTINE EITHER TABULATES OR CALCULATES A ZERO OF C FUNCTION F(X). C IT IS DERIVED FROM AND HAS SIMILAR CALLING SEQUENCE AS C THE ROUTINE ZEROD- (OR ZERO BY M. HAFTEL), BUT CAN CALL C EITHER ZEROD- ITSELF OR OTHER ROUTINES FOR FINDING ZEROS. C PURPOSE: TO ENABLE TESTING OF DIFFERENT ZERO FINDING C ALGORITHMS WITHOUT CHANGING THE CALLING PROGRAM. C COMMON / ZER / APPEARS IN DETD- AND ZEROD-. C C NREADE - 0: CALCULATE FIRST NZ ZEROS OF F(X) BETWEEN A AND B. C 1: TABULATE F(X) WITH E = ENXL (ENXS) ENXU. C 2: TABULATE F(X) WITH E = ENXL (1 + 10**-N), C N = 2 (ENXS) ENXU. C 3: TABULATE F(X) WITH E READ FROM A FILE. ENXL/U/S C SHOULD HAVE INTEGER VALUES ON INPUT. C THE FIRST ENXL RECORDS ARE SKIPPED, THEN THE C SUBSEQUENT ENERGIES NUMBERED 1 (ENXS) ENXU ARE USED. C IPROG - 0: CALL ZEROD-. C 100: CALL ZLI2-. C 200: CALL ZLI3-. C 1-6: CALL Z1PM- (IPROG = IFN IN IF1PM-). C EXTERNAL F COMMON / ZER / BTR LOGICAL LCALL0 C ------------------------------------------------------------------ CHARACTER*6 NAME DATA NAME / 'EWF2ZC' / CHARACTER*60 VERS DATA VERS */ ' 2.3, 93/12/02. -B 1.0, -A 3.1. READ E. ' / C ............................................................ C ------------------------------------------------------------------ DATA LCALL0 / .TRUE. /, 1 ZERO, HALF, ONE, TWO, TEN 2 / 0.D+0, 0.5D+0, 1.D+0, 2.D+0, 10.D+0 / C ------------------------------------------------------------------ IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (NREADE .EQ. 1) THEN C -------------------------------------------------------------- C TABULATION: ENERGY = ENXL (ENXS) ENXU. ENERGY = ENXL 10 CONTINUE BTR = SQRT(TWO * ENERGY) DETER = F(BTR) ENERGY = ENERGY + ENXS IF (ENERGY .GT. ENXU) RETURN GO TO 10 ELSE IF (NREADE .EQ. 2) THEN C -------------------------------------------------------------- C TABULATION, ENERGY = ENXL (1 + 10**-N), N = 2 (ENXS) ENXU. NU = ENXU + HALF NS = ENXS + HALF IF (NU .LT. 2) CALL ERR2(NAME, 21, 1, NOUT) IF (NS .LT. 1) CALL ERR2(NAME, 22, 1, NOUT) DO 20 N = 2,NU,NS ENERGY = ENXL * (ONE + TEN ** (- N)) BTR = SQRT(TWO * ENERGY) DETER = F(BTR) 20 CONTINUE ELSE IF (NREADE .EQ. 3) THEN C -------------------------------------------------------------- C DETERMINANT TABULATION, READ E-VALUES (UNFORMATTED). C READ E FROM FILE OF A PREVIOUS RUN. SKIP THE FIRST ENXL VALUES C (INTEGER PART OF ENXL), THEN USE THE NEXT ENXU ENERGIES WITH C STEP ENXS. WRITE (NOUT,2100) NAME NSKIP = ENXL + HALF IF (NSKIP .GT. 0) THEN DO 30 I = 1,NSKIP READ (NIN20,ERR=34,END=36) ENERGY WRITE (NOUT,2104) NAME, ENERGY 30 CONTINUE ENDIF NU = ENXU + HALF NS = ENXS + HALF IF (NU .LT. 1) CALL ERR2(NAME, 31, 1, NOUT) IF (NS .LT. 1) CALL ERR2(NAME, 32, 1, NOUT) N = 0 32 CONTINUE READ (NIN20,ERR=34,END=36) ENERGY N = N + 1 IF (MOD(N, NS) .EQ. 1 .OR. NS .EQ. 1) THEN WRITE (NOUT,2102) NAME, ENERGY CALL CDXFBO(NOUT) BTR = SQRT(TWO * ENERGY) DETER = F(BTR) IF (N .GE. NU) RETURN ELSE WRITE (NOUT,2104) NAME, ENERGY CALL CDXFBO(NOUT) ENDIF GO TO 32 34 CONTINUE WRITE (NOUT,2110) NAME RETURN 36 CONTINUE WRITE (NOUT,2112) NAME ELSE IF (NREADE .EQ. 0) THEN C -------------------------------------------------------------- C SEARCH FOR ZERO OF F(X). WRITE (NOUT,2002) IPROG IF (IPROG .EQ. 0) THEN C BTR DEFINED VIA COMMON. CALL ZERODC(F, A, B, ITCU, HH, EPSF, EPSP, FF, 1 Z, P, NZ, NOUT) ELSE IF (IPROG .EQ. 100) THEN CALL ZLI2A(F, A, B, EPSP, EPSF, ITCU, 1 IFAIL, LTEST, NOUT, FF(1), Z(1)) ELSE IF (IPROG .EQ. 200) THEN CALL ZLI3A(F, A, B, EPSP, EPSF, LXLAST, ITCU, 1 IFAIL, LTEST, NOUT, FF(1), Z(1), ITC) ELSE IF (IPROG .GE. 1 .AND. IPROG .LE. 6) THEN CALL Z1PMA(F, A, B, EPSP, EPSF, ITCU, 1 IPROG, IFAIL, LTEST, LTIF, NOUT, FF(1), Z(1)) ELSE CALL ERR2(NAME, 1, 1, NOUT) ENDIF C DEFINE BTR. BTR = Z(1) WRITE (NOUT,2004) NAME, IPROG, IFAIL ELSE CALL ERR2(NAME, 0, 1, NOUT) ENDIF C 2000 FORMAT (2H -, A6, 1H-, A60) 2002 FORMAT (//, 1 1H , 40H NREADE = 0: SEARCH FOR ZERO. , /, 2 1H , 12H IPROG = , I4) 2004 FORMAT (2H -, A6, 1H-, 8HIPROG = , I4, 12H, IFAIL = , I4) 2100 FORMAT (2H -, A6, 1H-, 16HENERGIES INPUT. ) 2102 FORMAT (2H -, A6, 1H-, 8HENERGY , F24.16) 2104 FORMAT (2H -, A6, 1H-, 8HENERGY , F24.16, 12H: SKIPPED ) 2110 FORMAT (2H -, A6, 1H-, 16HREAD ERROR. ) 2112 FORMAT (2H -, A6, 1H-, 16HEND OF FILE. ) END idamax.f000644 000311 000121 00000005320 05311644774 012315 0ustar00krivecf1000000 000000 INTEGER FUNCTION IDAMAX(N,DX,INCX) IMPLICIT REAL*8 (A-H,O-Z) C C FINDS THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE. C JACK DONGARRA, LINPACK, 3/11/78. C REAL*8 DX(1),DMAX INTEGER I,INCX,IX,N C IDAMAX = 0 IF( N .LT. 1 ) RETURN IDAMAX = 1 IF(N.EQ.1)RETURN IF(INCX.EQ.1)GO TO 20 C C CODE FOR INCREMENT NOT EQUAL TO 1 C IX = 1 DMAX = ABS(DX(1)) IX = IX + INCX DO 10 I = 2,N IF(ABS(DX(IX)).LE.DMAX) GO TO 5 IDAMAX = I DMAX = ABS(DX(IX)) 5 IX = IX + INCX 10 CONTINUE RETURN C C CODE FOR INCREMENT EQUAL TO 1 C 20 DMAX = ABS(DX(1)) DO 30 I = 2,N IF(ABS(DX(I)).LE.DMAX) GO TO 30 IDAMAX = I DMAX = ABS(DX(I)) 30 CONTINUE RETURN END if1pma.f000644 000311 000121 00000004603 06067230171 012221 0ustar00krivecf1000000 000000 SUBROUTINE IF1PMA(X0, X1, X2, F0, F1, F2, D1, D2, D20, D, 1 IFN, LTEST, NOUT, X3) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LTEST C C C ONE ITERATION OF A C ONE-POINT ITERATION FUNCTION (I.F.) WITH MEMORY (TRAUB 1964). C NO CHECKS ARE DONE, THE FUNCTION MUST BE WELL BEHAVED. C THIS IS NOT A HIGH SPEED ROUTINE. C C X., F. - ABSCISSA AND FUNCTION VALUES. C D1 - DIVIDED DIFFERENCE F(X1,X0). C D2 - DIVIDED DIFFERENCE F(X2,X1). C D20 - DIVIDED DIFFERENCE F(X2,X0). C D - SECOND ORDER D. D. F(X2,X1,X0). C IFN - NUMBER OF ITERATION FUNCTION (TRAUB 1964): C SEE COMMENTS BELOW. C X3 - ITERATION FOR X. C C CHARACTER*6 NAME DATA NAME / 'IF1PMA' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 92/11/26. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ONE, TWO, FOUR / 1.D+00, 2.D+00, 4.D+00 / C .. IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. IF (LTEST) WRITE (NOUT,3000) 1 NAME, X0, X1, X2, F0, F1, F2, D1, D2, D20, D C ..ITERATION. IF (IFN .EQ. 1) THEN C ..12.3.1. (SECANT). X3 = X2 - F2 / D2 RETURN ELSE IF (IFN .EQ. 2) THEN C ..12.3.2. X3 = X2 - F2 / D2 1 + F2 * F1 / (F2 - F0) * (ONE / D2 - ONE / D1) RETURN ELSE IF (IFN .EQ. 3) THEN C ..12.3.4. Z = D2 + (X2 - X1) * D X3 = X2 - TWO * F2 / (Z + SQRT(Z ** 2 - FOUR * F2 * D)) RETURN ELSE IF (IFN .EQ. 4) THEN C ..12.3.5. X3 = X2 - F2 * (ONE / D2 + ONE / D20 - ONE / D1) RETURN ELSE IF (IFN .EQ. 5) THEN C ..12.3.7. X3 = X2 - F2 / (D2 + D20 - D1) RETURN ELSE IF (IFN .EQ. 6) THEN C ..12.3.10. X3 = X2 - F2 / (D2 - F1 * D / D2) RETURN ELSE CALL ERR2(NAME, 1, 0, NOUT) RETURN ENDIF C 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-, /, 1 1H , 8HX0,X1,X2, 4X, 3E22.14, /, 2 1H , 8HF0,F1,F2, 4X, 3E22.14, /, 3 1H , 8HD1,2,D20, 4X, 3E22.14, /, 4 1H , 8HD , 4X, E22.14) END lselc.f000644 000311 000121 00000004477 06067232175 012165 0ustar00krivecf1000000 000000 SUBROUTINE LSELC(NDS, NDML, NOUT, 1 MM, MU, IM, IX, NM, NX, LMIN, LMAX, LMAX1) C DIMENSION MU(NDS), 1 LMIN(NDS), LMAX(NDS,NDML), LMAX1(NDS,NDML) C C C C C MODIFIED VERSION OF ROUTINE LSELEC BY M. HAFTEL. C NOTE THE CHANGE OF THE SECOND DIMENSION OF LMAX , LMAX1 . C C C C C* ================================================================== C* SUBROUTINE LSELEC( IM, IX, NM,NX, LMIN, LMAX, LMAX1 ) C* COMMON/MU/MU(169) C* COMMON/VM/MM C* DIMENSION LMIN(169),LMAX(169,169),LMAX1(169,169) C* ================================================================== C* C C LMIN(I)=SMALLEST L SUCH THAT MU(L)>MU(I) C LMAX(I,N)=LARGEST L SUCH THAT MU(L).LE.MU(I)+N C LMAX1(I,N)=LARGEST L SUCH THAT MU(L) MU(I) C LMAX(I,N) = LARGEST K SUCH THAT MU(K) .LE. MU(I) + N C LMAX1(I,N) = LARGEST K SUCH THAT MU(K) < MU(I) + N CALL LSELC(NDS, NDML, NOUT, 1 MM, MU, 1, MM, 1, ML, LMIN, LMAX, LMAX1) IF (LTEST) THEN DO 3141 I = 1,MM WRITE (NOUT,3144) 1 NAME, I, MU(I), LMIN(I), 2 (LMAX(I,J), LMAX1(I,J), J = 1,ML) 3141 CONTINUE ENDIF C C C INITIALIZE AND STORE CERTAIN MATRICES FOR LATER USE DO 2 I = 1,MM DO 3 K = 1,MM C C DL WILL BE UNITY UNLESS N+MU(I) = MU(K); C THEN IT WILL BE 0. DL(K, I ) = ONE NU2( K, I ) = MU( K ) ** 2 C C DLT WILL BE UNITY WHEN N+MU(I) = MU(K); OTHERWISE 0. DLT( K, I ) = ZERO C C x(K,I)(ZM)= C SUM(L)(SUM(N)(C(K,L;N)*ZM**N)*ZM**MU(L)* C SUM(M)((P**M)(L,I)*LN(ZM)**M/M!)); C THE QUANTITY CONTAINED FROM SUM(N) TO...MU(L) WILL C BE STORED IN THE ARRAY ELEMENT SUM(K,L); A CORRESPONDING C QUANTITY USED IN COMPUTING x'(K,I) WILL BE STORED IN C SUD(K,L); INITIALIZE SUD(K,I) = ZERO SUM(K,I) = ZERO C C INITIALIZE C(0) CN( K, I , 1 ) = ZERO C C INITIALIZE C(-1) TO ZERO; THIS WILL EVENTUALLY BE USED C TO STORE C(N-2) CCMM(K,I) = ZERO C C INITIALIZE P P(K,I) = ZERO 3 CONTINUE C C C(0) IS THE IDENTITY MATRIX (DENOTED AS I) CN(I, I, 1 ) = ONE TW( I ) = ONE / ( TWO * MU( I ) ) CU( I ) = MU( I ) - CON 2 CONTINUE C C LOOP OVER N; IN EACH N VALUE :(1) THE NEEDED P(K,I) VALUES WILL BE C COMPUTED FOR N+MU(I)=MU(K); (2) CONTRIBUTIONS TO THE SUM AND SUD C ARRAYS WILL BE COMPUTED COMING FROM C(N-1)**ZM**(N-1); (3) C(N) C WILL BE EVALUATED C ****************************************************** C * DANGEROUS LOOP - CORRECT ONLY WITHOUT OPTIMIZATION * C * BY FC-COMPILER ON CONVEX (USE OPT. LEVEL -O0). * C ****************************************************** NMP1 = NM + 1 DO 1 N = 1,NMP1 NMOD = MOD(N,2) IF (N .LE. ML) THEN C C CONSIDER N VALUES WHERE THE POSSIBILITY EXISTS C THAT N+MU(I) = MU(K) DO 28 I = 1, MM C C LM,LX ARE THE MINIMUM AND MAXIMUM VALUES OF K SUCH C THAT MU(K) = MU(I)+N LM = LMAX1( I, N ) + 1 LX = LMAX( I, N ) IF (LX .GE. LM) THEN C C DL(K,I) = 1 UNLESS MU(K) = MU(I)+N (THEN = 0) C AND DLT = 1-DL; AND, DL(K,I) ALWAYS = 1 C (AND DLT = 0) FOR N.GE.ML DO 31 K = LM, LX DL( K, I ) = ZERO DLT( K, I ) = ONE NU2( K, I ) = IZERO 31 CONTINUE ENDIF IF (N .GT. 1) THEN C C THIS SECTION CORRECTS VALUES OF C DL, DLT, NU2 CHANGED ON PREVIOUS VALUE OF N LM = LMAX1( I, N - 1 ) + 1 LX = LMAX( I, N - 1 ) IF (LX .GE. LM) THEN DO 35 K = LM, LX DL( K, I ) = ONE DLT( K, I ) = ZERO NU2( K, I ) = MU( K ) ** 2 35 CONTINUE ENDIF ENDIF 28 CONTINUE ENDIF C C ALL VALUES OF N: C COMPUTE DENOMINATOR IN RECURSION RELATION DO 36 I = 1, MM NMU2 = ( N + MU( I ) ) ** 2 DO 37 K = 1, MM FAC( K, I ) = DL( K, I ) / ( NMU2 - NU2( K, I ) ) 37 CONTINUE 36 CONTINUE ZMN1 = ZM ** (N - 1) C C C CONSIDER N ONLY IF N+MU(I) = MU(K) POSSIBILITY EXISTS. C ------------------------------------------------------ C IF (NMOD .NE. 0 .OR. N + 2 .GT. 2 * MA) GO TO 74 M1 = 1 C C LOOP OVER ARRAY ELEMENTS K,I RESTICTED TO MU(I)+N=MU(K) C COMPUTE NEEDED P(K,I) ARRAY ELEMENTS (MU(I)+N=MU(K)) C AND CONTRIBUTIONS TO SUM, SUD COMING FROM C(K,I;N-1) C COMING FROM THE RESTRICTED SET OF ARRAY ELEMENTS DO 20 I = 1,MM IM = I IX = I KM = LMAX1( I, N ) + 1 KX = LMAX( I, N ) IF (KX .LT. KM) GO TO 20 C C NOTE VIC-- NOW CALLED ONLY ONCE FOR EACH I CALL VICDF(NDS, NDCN, NDP, NDML, 1 MM, N, M1, IM, IX, KM, KX, ML, 2 LMIN, LMAX, LMAX1, LMAXY, LMAXXY, LMAXYX, 3 MU, CN, P, P2X, XXX, 4 WS, WD, AA, IPXU, IPOFF, 5 X, Y, XY, YX, XD0, 6 NOUT, LTVICB) NMU = N + MU( I ) C C COMPUTE C(N-2) MATRIX ELEMENTS AND STORE IN CCCM DO 39 K = KM, KX CCCM(K) = ZERO C C 2*(N+MU(I))(CP)(K,I) TERM IN EQ(10) PHYS LETT 78A Y( K, I ) = Y( K, I ) * NMU 39 CONTINUE IF (N.EQ.1) GO TO 82 C C C(N-2) DO 81 K = KM,KX CCCM(K) = CN(K,I,N-1) 81 CONTINUE 82 CONTINUE C C C(N) DO 42 K = KM, KX CCC( K ) = CN( K, I, N ) 42 CONTINUE DO 45 K = KM, KX C C EVALUATION OF CONTRIBUTIONS TO FACTORS IN x,x' C COMING FROM SUM, SUD ARRAYS SUM( K, I ) = SUM( K, I ) + CCC( K ) * ZMN1 SUD(K,I) = SUD(K,I)+CCC(K)*ZMN1*(NMU-1) C C COMPUTE NEW P MATRIX ELEMENTS P(K,I) = 1 ((0.25D0 * CCCM(K) + 2 ZZZ0 * X(K,I) - 3 TWO * Y(K,I)) + 4 ZZZ0 * XY(K,I) + 5 ZZZ0 * XD0(K,I) - 6 YX(K,I)) * 7 TW(K) C IF (LTEST) WRITE (NOUT,3100) NAME, 1 N, K, I, P(K,I), X(K,I), X(K,I), XD0(K,I), 2 Y(K,I), YX(K,I), XY(K,I) 45 CONTINUE C C COMPUTE C(K,I;N) FOR RESTICTED K,I C (THESE WILL REMAIN ZERO) DO 48 K = KM, KX CN( K, I , N + 1 ) = ZERO 48 CONTINUE 20 CONTINUE 74 CONTINUE C C C SECOND CONTRIBUTION TO SUM, SUD COMING FOR ALL N VALUES. C -------------------------------------------------------- C C K,I NOW NOT RESTRICTED M1 = 2 IM = 1 IX = MM KM = 1 KX = MM C C NOTE THAT VIC-- IS NOW CALLED ONLY ONCE FOR EACH N CALL VICDF(NDS, NDCN, NDP, NDML, 1 MM, N, M1, IM, IX, KM, KX, ML, 2 LMIN, LMAX, LMAX1, LMAXY, LMAXXY, LMAXYX, 3 MU, CN, P, P2X, XXX, 4 WS, WD, AA, IPXU, IPOFF, 5 X, Y, XY, YX, XD0, 6 NOUT, LTVICB) C C INCLUDE N+MU(I) FACTOR FOR 2*(MU(I)+N)*(CP)(K,I) TERM DO 52 I = 1, MM NMU = N + MU( I ) DO 51 K = 1, MM Y( K, I ) = Y( K, I )*NMU 51 CONTINUE 52 CONTINUE C C CCD CONTAINS C(N-1) DO 56 I = 1, MM DO 55 K = 1, MM CCD( K, I ) = CN( K, I, N) 55 CONTINUE 56 CONTINUE C C COMPUTE CONTRIBUTION TO SUM, SUD C THE USE OF MANY ARRAYS (E.G. CCD,CCCP,ETC) IS TO TAKE C ADVANTAGE OF THE VECTORIZING CAPABILITIES OF THE COMPUTER C THESE MAY NOT BE ADVANTAGEOUS ON (SCALAR) COMPUTERS C USUAL COMPUTATION OF C(N-1)*ZM**(N-1) DO 59 I = 1, MM DO 58 K = 1, MM ADD( K, I ) = CCD( K, I ) * ZMN1 58 CONTINUE 59 CONTINUE C C C(N-2) DO 61 I = 1, MM CNU = N + CU( I ) NMU = N + MU(I) IF (N .LE. 1) THEN DO 86 K = 1,MM CCCM(K) = CCMM(K,I) 86 CONTINUE GO TO 87 ENDIF DO 91 K = 1,MM CCCM(K) = CN(K,I,N-1) 91 CONTINUE C C COMPUTE CONTRIBUTIONS TO SUM, SUD ARRAYS 87 CONTINUE DO 62 K = 1, MM C C CCCP CONTAINS C(N-1) WHICH BECOMES C(N-2) FOR NEXT C VALUE OF N CCCP(K, I ) = CCD( K, I ) C C CONTRIBS TO SUM, SUD; DL FACTOR ASSURES THAT THE C CONTRIBUTION FOR MU(I)+N=MU(K) IS NOT COUNTED TWICE; C IT WAS ALREADY COMPUTED WHEN P ELEMENTS WERE C CALCULATED SUM( K, I ) = SUM( K, I ) + ADD( K, I ) * DL( K, I ) SUD(K,I) = SUD(K,I)+ADD(K,I)*DL(K,I)*(NMU-1) C C RECURSION RELATION FOR C(N) CCD(K,I) = 1 ((0.25D0 * CCCM(K) + 2 ZZZ0 * X(K,I) - 3 TWO * Y(K,I)) + 4 ZZZ0 * XY(K,I) + 5 ZZZ0 * XD0(K,I) - 6 YX(K,I)) * 7 FAC(K,I) C IF (LTEST) WRITE (NOUT,3110) NAME, 1 N, K, I, CCD(K,I), X(K,I), X(K,I), XD0(K,I), 2 Y(K,I), YX(K,I), XY(K,I) 62 CONTINUE 61 CONTINUE C C COMPUTE C(N); C NOTE THAT THE USE OF DL, DLT ONLY CHANGES C IF C MU(K).NE.MU(I)+N; IF MU(I)+N = MU(K), C(K,I;N) IS ZERO DO 66 I = 1, MM DO 65 K = 1, MM CN(K,I,N+1) = CCD(K,I) * DL(K,I) + DLT(K,I) * 1 CN(K,I,N+1) 65 CONTINUE 66 CONTINUE 1 CONTINUE C IF (LTEST) WRITE (NOUT,3120) 1 ((NAME, I, J, SUM(I,J), SUD(I,J), I = 1,MM), J = 1,MM) C IF (LOUTA) THEN C STORE CN . C ------------------------------------------- DO 302 K = 1,NMP1 DO 300 J = 1,MM WRITE (NOUTA) (CN(I,J,K), I = 1,MM) 300 CONTINUE 302 CONTINUE C ------------------------------------------- ENDIF C C COMPUTE LN(ZM). ALOGZ = LOG(ZM) C C INITIALIZE P**M * (LN(ZM))**M/M!, P**M, C P**M * (LN(ZM))**(M-1) / (M-1)!. DO 94 J = 1,MM DO 95 I = 1,MM P1(I,J) = ZERO PM(I,J) = ZERO P2(I,J) = ZERO 95 CONTINUE PM(J,J) = ONE P1(J,J) = ONE 94 CONTINUE C C INITIALIZE (LN(ZM))**M/M!, (LN(ZM))**(M-1)/M! P1C = ONE P2C = ONE / ALOGZ C C INITIALIZE P**M AGAIN DO 96 J = 1,MM DO 97 I = 1,MM PNEWM(I,J) = ZERO 97 CONTINUE 96 CONTINUE C C BEGIN SUMMATION OVER M. C (MM TO MA IN LOOP 98, 90/11/19 (MAIL BY M. HAFTEL).) MMM1 = MM-1 DO 98 M = 1,MA IF (LOUTA) THEN C STORE UPDATED ARRAY PM . C ------------------------------------- DO 304 I = 1,MM WRITE (NOUTA) (PM(L,I), L = 1,MM) 304 CONTINUE C ------------------------------------- ENDIF C C (LN(ZM))**M/M! P1C = P1C*ALOGZ/M C C (LN(ZM))**(M-1)/M! P2C = P2C*ALOGZ/M IF (MM.LT.2) GO TO 98 C C COMPUTE P**M FROM P**(M-1) DO 99 J = 1,MMM1 JP1 = J+1 DO 102 I = JP1,MM PNEWM(I,J) = ZERO IM1 = I-1 DO 103 K = J,IM1 PNEWM(I,J) = PNEWM(I,J)+P(I,K)*PM(K,J) 103 CONTINUE 102 CONTINUE 99 CONTINUE C C COMPUTE CONTRIBS TO THE M SUMMATION OF P**M*(LN(ZM))**M/M!, C P**M*(LN(ZM))**(M-1)/(M-1)! DO 104 J = 1,MM DO 105 I = 1,MM C C UPDATE PM TO P**M PM(I,J) = PNEWM(I,J) P1(I,J) = P1(I,J)+PM(I,J)*P1C P2(I,J) = P2(I,J)+PM(I,J)*P2C*M 105 CONTINUE 104 CONTINUE 98 CONTINUE RETURN C C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 3100 FORMAT ( 1 2H -, A6, 6H-P-NKI, 3I2, 7F8.5) 3110 FORMAT ( 1 2H -, A6, 6H-C-NKI, 3I2, 7F8.5) 3120 FORMAT ( A 2H -, A6, 1H-, 8HSUM, SUD, 2I4, 2F16.8) 3144 FORMAT ( A 2H -, A6, 1H-, 8HMU,LMIN&, 3I4, 2I4, / (1H , 30X, 2I4)) END rrpsm.f000644 000311 000121 00000030551 06067234060 012211 0ustar00krivecf1000000 000000 SUBROUTINE RRPSM(NCDS, NCDP, NCDCN, NDBIN1, NDBIN2, NDZ0MP, 1 WS, WD, MM, MU, IPXU, IPOFF, Z0M, JMAX, AA, 2 RHOUW, PP, QQ, RR, BIN, Z0MPOW, 3 LTEST, LPRBIN, LPRZ0M, NOUT, 4 CNT) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LTEST, LPRBIN, LPRZ0M DIMENSION WS(NCDS,NCDS,NCDP), WD(NCDS,NCDS,NCDP), 1 MU(NCDS), 2 PP(NCDS,NCDS,NCDCN), QQ(NCDS,NCDS,NCDCN), 3 RR(NCDS,NCDS), BIN(NDBIN1,NDBIN2), Z0MPOW(NDZ0MP), 4 CNT(NCDS,NCDS,NCDCN) C C C C C COEFFICIENTS OF THE POWER SERIES OF THE SOLUTION OF C THE SYSTEM OF EQUATIONS FOR INTERVALS PAST THE FIRST C (PURE POWER SERIES). C C ****************************************************************** C * USES UNTRANSPOSED W ; RETURNS CNT WHICH IS TRANSPOSED WITH * C * RESPECT TO USAGE IN E.G. RRPSH . * C ****************************************************************** C C 93/03/01: DISTRIBUTED RECURSION LOOP; CNT(,,1) NOT USED. C C RRPSK 1.0: C OPTIMIZED MARCH 1992; 30 PERCENT FASTER LOOPS, 20 PERCENT FASTER C ENTIRE PROGRAM PACKAGE, DUE TO ARRAY RR . NOW ALMOST INDEPENDENT C OF 70-74 LOOP PERMUTATIONS, BOTH FOR -O2 AND FOR -O3; -O2 FASTER. C C RHOUW: POSITIVE: RHO-CUTOFF FOR W. C NEGATIVE: Z-CUTOFF FOR W. C C **** NOTE **** ON ENTRY, C(0) AND C(1) MUST BE PRESENT IN CNT . C C C GENERALIZATION OF RECURSION RELATIONS FOR ANY POWER SERIES C OF THE EFFECTIVE POTENTIAL (SEE D OR DD- ): C C HERE WE USE NOTATION WHICH FOR THE MOST PART HAS NO C CONNECTION WITH THE NOTATION IN THE ORIGINAL ROUTINE D C BY M. HAFTEL WHICH WAS THE SOURCE OF DD- . C AT THE END WE MAKE THE CONNECTION WITH DD- , C PUTTING THE DD- VARIABLES IN QUOTES. C C C SCHROEDINGER EQUATION: (DD/DZZ) X + P (D/DZ) X + QX = 0, C IN THE VARIABLE Z = 2 KAPPA RHO. C C THE POWER SERIES FOR P AND Q ARE: C C P = SUM(M=-1,...) P(M) Z**M; C Q = SUM(M=-2,...) Q(M) Z**M, C C WHERE C C 2 WD(M) C P(M) = DELTA(M,-1) - ----------------; C (2 KAPPA)**(M+1) C C 1 2 2 WS(M) C Q(M) = - - DELTA(M,0) - "MU" DELTA(M,-2) - ----------------, C 4 (2 KAPPA)**(M+2) C C C WHERE "MU" IS THE NOTATION FOR THE DIAGONAL MATRIX WITH ELEMENTS C (2 MU + 2) WHERE (MU,NU) ARE THE STATE QUANTUM NUMBERS, AND C WS AND WD ARE COEFFICIENT MATRICES OF THE EFFECTIVE POTENTIAL C W (DENOTED W-BAR IN THE PAPERS): C C C W = SUM(M=-1,IPU) WS(M) RHO**M + C C D C SUM(M=0,IPU) WD(M) RHO**M -----. C D RHO C C C HERE IPU IS THE LARGEST COMMON UPPER BOUND ON POWERS C IN THE POTENTIAL IF THE POWER SERIES IS FINITE; IT ACTS C AS A CUTOFF IF THE POWER SERIES IS INFINITE. C C FIRST, THE MATRICES P AND Q ARE EXPANDED ABOUT Z = Z0: C C P = SUM(R=0,INFTY) PP(R) (Z - Z0)**R; C Q = SUM(R=0,INFTY) QQ(R) (Z - Z0)**R, C C WHERE C C PP(R) = SUM(M=-1,IPU) BIN(M;R) P(M) Z0**(M-R), C QQ(R) = SUM(M=-2,IPU) BIN(M;R) Q(M) Z0**(M-R), C C AND BIN(M;R) IS THE BINOMIAL COEFFICIENT (M ATOP R) C (NOTE BIN(0;R) = DELTA(R,0)). C C THE RECURSION RELATION IS: C C C 1 P-2 P-2 C C = - -------- (SUM (P-R-2) PP(R+1) + SUM QQ(R)) C . C P P(P - 1) R=-1 R=0 P-R-2 C C C TO GENERALIZE, OBSERVE THAT IN THE PROGRAM, P = "NNN", C R + 2 = "M1", Z0 = "Z0M", IPU = "IPXU" - "IPOFF"; AND C C C (-1)**(R+1) C "PT" = ----------- + DELTA(R,-1) "PT1"; C Z0**(R+2) C C C 1 (R+1) (-1)**(R+1) 2 C "QT" = - - DELTA(R,0) - ----------------- DELTA(R.GE.0) MU + C 4 Z0**(R+2) C C C (-1)**R C --------- "QT1" + DELTA(R,0) "QT2", C Z0**(R+1) C C WHERE C C "PT1" = - 2 WD(0) / 2 KAPPA, C "QT1" = - 2 WS(-1) / 2 KAPPA, C "QT2" = - 2 WS(0) / (2 KAPPA)**2. C C FINALLY, THE GENERALIZATION IS C C C DELTA (R,-1) "PT1" --> C C IPU M-R-1 2 WD(M) C SUM BIN(M;R+1) Z0 (- ----------------); C M=0 (2 KAPPA)**(M+1) C C C "QT1" --> "QT1" (UNCHANGED); C C C DELTA(R,0) "QT2" --> C C IPU M-R 2 WS(M) C SUM BIN(M;R) Z0 (- ----------------). C M=0 (2 KAPPA)**(M+2) C C C BECAUSE THE NEW "PT1", "QT1" ARE FUNCTIONS OF R, C THEY MUST BE CALCULATED INSIDE THE "M1" LOOP. C C IF THESE QUANTITIES WERE CALCULATED IN THE ORIGINAL LOOPS, C THEY WOULD BE REPEATED FOR EACH P, ALTHOUGH THEY DO NOT DEPEND C ON P. THEY CAN BE CALCULATED IN ADVANCE AND STORED, BUT THEY C REQUIRE TWICE AS MUCH SPACE AS CNT , WHICH IS ALREADY C (USUALLY) THE LARGEST ARRAY IN THE PROGRAM. NEVERTHELESS, C THIS VERSION IS WRITTEN USING THIS ADVANCE CALCULATION C AND STORAGE. C C R AND P LOOPS CANNOT BE EXCHANGED (WHICH WOULD AVOID LARGE C STORAGE SPACE), BECAUSE IF THE R LOOP IS OUTSIDE, THE CNT C ELEMENTS APPEARING IN THE INNER LOOP ARE NOT YET FINISHED C (SUMMED OVER R). C C C C CHARACTER*6 NAME DATA NAME / 'RRPSM ' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 95/12/24. 1.0, 93/05/14 (-L 2.0) STREAMLN; DST M1 LOOP' / C ------------------------------------------------------------ C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DATA ZERO, ONE, TWO / 0.D0, 1.D0, 2.D0 / C C C C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS C C IF (MM .GT. NCDS) CALL ERR2(NAME, 1, 1, NOUT) IF (IPXU .GT. NCDP) CALL ERR2(NAME, 2, 1, NOUT) IF (JMAX+1 .GT. NCDCN) CALL ERR2(NAME, 3, 1, NOUT) IF (ABS(AA) .LT. CDXTOL()) CALL ERR2(NAME, 4, 1, NOUT) C C C TEST IPOFF ; IF LARGER THAN 2, THERE ARE PROBABLY C POWERS LESS THAN -1 IN W; THESE POWERS WILL BE IGNORED BY THIS C ROUTINE; WARNING ONLY IS ISSUED HERE. C (THE RECURSION RELATIONS ASSUME POWERS ARE .GE. -1.) IF (LCALL0 .AND. IPOFF .GT. 2) CALL ERR2(NAME, 11, 0, NOUT) C C C JMAX SHOULD BE .GE. 2; IF NOT, WARNING; RETURN. IF (LCALL0 .AND. JMAX .LT. 2) CALL ERR2(NAME, 21, 0, NOUT) IF (LCALL0) LCALL0 = .FALSE. IF (JMAX .LT. 2) RETURN C C C Z PAST WHICH W WILL BE TAKEN AS ZERO. IF RHOUW IS NONNEGATIVE, C IT IS ASSUMED TO REPRESENT A RHO-VALUE. IF IT IS NEGATIVE, C IT IS ASSUMED TO REPRESENT A Z-VALUE. IF (RHOUW .GE. ZERO) ZUW = TWO * AA * RHOUW IF (RHOUW .LT. ZERO) ZUW = -RHOUW C C JMAX1 = JMAX + 1 ZZZ4 = ONE / (TWO * AA) C C C BINOMIAL COEFFICIENTS AND POWERS OF Z0M. IPU = IPXU - IPOFF JRU = JMAX - 2 + 1 CALL BINA(NDBIN1, NDBIN2, IPU, JRU, BIN, LPRBIN, NOUT) IPOWL = - JMAX IPOWU = IPU C POWERS OF RHO SHOULD BE CALCULATED INSTEAD; PERHAPS IN LOG SCALE. CALL POWA(NDZ0MP, IPOWL, IPOWU, Z0M, LPRZ0M, NOUT, 1 Z0MPOW, NZ0MOF) C C C CALCULATE AND STORE ALL PP, QQ. M1 IS R+2 (SEE COMMENT). DO 68 M1 = 1,JMAX JR = M1 - 2 C C C CALCULATE PP(R+1). ZZZ51 = BIN(-1+3,JR+1+1) * Z0MPOW(-JR-2+NZ0MOF) DO 22 I = 1,MM DO 20 J = 1,MM PP(J,I,M1) = ZERO 20 CONTINUE 22 CONTINUE DO 24 I = 1,MM PP(I,I,M1) = ZZZ51 24 CONTINUE IF (Z0M .LE. ZUW) THEN C C SMALLEST POWER (IP) IS R + 1 BECAUSE IT APPEARS AS THE C UPPER ARGUMENT OF BINOMIAL COEFFICIENT AND IS ASSUMED C TO BE .GE. 0. (IN OTHER WORDS, HERE WE IGNORE NEGATIVE C POWERS IN WD.) IPXL = JR + 1 + IPOFF IF (IPXL .LE. IPXU) THEN DO 34 IPX = IPXL,IPXU IP = IPX - IPOFF ZZZ52 = - BIN(IP+3,JR+1+1) 1 * Z0MPOW(IP-JR-1+NZ0MOF) 2 * ZZZ4 ** (IP+1) DO 32 I = 1,MM DO 30 J = 1,MM PP(J,I,M1) = PP(J,I,M1) 1 + ZZZ52 * WD(J,I,IPX) 30 CONTINUE 32 CONTINUE 34 CONTINUE ENDIF ENDIF C C C CALCULATE QQ(R) (IF R .GE. 0); ZERO QQ ALSO IF R .LT. 0. DO 42 I = 1,MM DO 40 J = 1,MM QQ(J,I,M1) = ZERO 40 CONTINUE 42 CONTINUE IF (JR .LT. 0) GO TO 66 C C C ENERGY AND CENTRIFUGAL TERMS. IF (JR .EQ. 0) THEN ZZZ61 = -0.25D0 DO 50 I = 1,MM QQ(I,I,M1) = ZZZ61 50 CONTINUE ENDIF IF (JR .GE. 0) THEN ZZZ62 = -BIN(-2+3,JR+1) * Z0MPOW(-JR-2+NZ0MOF) DO 52 I = 1,MM QQ(I,I,M1) = QQ(I,I,M1) + ZZZ62 * MU(I) ** 2 52 CONTINUE ENDIF IF (Z0M .GT. ZUW) GO TO 66 C C POWER (IP) IS ASSUMED TO BE .GE. -1. ALL R .GE. 0 ARE C ALLOWED BY THE BINOMIAL COEFFICIENT IF IP = -1, ELSE C IP MUST BE .GE. R. (IN OTHER WORDS, POWERS .LT. -1 ARE C IGNORED HERE.) IPXL = -1 + IPOFF IF (IPXL .GT. IPXU) CALL ERR2(NAME, 31, 1, NOUT) DO 64 IPX = IPXL,IPXU IP = IPX - IPOFF IF (IP .GE. 0 .AND. JR .GT. IP) GO TO 64 ZZZ63 = - BIN(IP+3,JR+1) * Z0MPOW(IP-JR+NZ0MOF) 1 * ZZZ4 ** (IP+2) DO 62 I = 1,MM DO 60 J = 1,MM QQ(J,I,M1) = QQ(J,I,M1) + ZZZ63 * WS(J,I,IPX) 60 CONTINUE 62 CONTINUE 64 CONTINUE 66 CONTINUE 68 CONTINUE C C C CALCULATE CNT . N1 IS P+1 OF COMMENT. DO 124 N1 = 3,JMAX1 C C C RESET CNT (**** DO NOT RESET C(0), C(1) ****). DO 72 J = 1,MM DO 70 I = 1,MM CNT(I,J,N1) = ZERO 70 CONTINUE 72 CONTINUE JP = N1 - 1 C C C SUM OVER R (R = -1,..., JP-2). C C FIRST LOOP: EXCLUDE CN(,,1). JP1 = JP - 1 DO 90 M1 = 1,JP1 JR = M1 - 2 ZZZ72 = JP - JR - 2 DO 82 K = 1,MM DO 80 J = 1,MM RR(J,K) = ZZZ72 * PP(J,K,M1) + QQ(J,K,M1) 80 CONTINUE 82 CONTINUE DO 88 J = 1,MM DO 86 I = 1,MM DO 84 K = 1,MM CNT(I,J,N1) = CNT(I,J,N1) 1 + CNT(I,K,N1-JR-2) * RR(J,K) 84 CONTINUE 86 CONTINUE 88 CONTINUE 90 CONTINUE C C SECOND LOOP: CN(1) = I ONLY (IMPLICIT). M1 = JP JR = M1 - 2 ZZZ72 = JP - JR - 2 DO 104 K = 1,MM DO 102 J = 1,MM RR(J,K) = ZZZ72 * PP(J,K,M1) + QQ(J,K,M1) 102 CONTINUE 104 CONTINUE DO 108 J = 1,MM DO 106 I = 1,MM CNT(I,J,N1) = CNT(I,J,N1) + RR(J,I) 106 CONTINUE 108 CONTINUE C C C FINISH C(JP) . ZZZ71 = - ONE / DFLOAT(JP * (JP - 1)) DO 122 J = 1,MM DO 120 I = 1,MM CNT(I,J,N1) = ZZZ71 * CNT(I,J,N1) 120 CONTINUE 122 CONTINUE 124 CONTINUE C C C TEST OUTPUT. IF (.NOT.LTEST) RETURN WRITE (NOUT,4100) NAME, Z0M DO 132 K = 1,JMAX1 WRITE (NOUT,4110) K DO 130 I = 1,MM WRITE (NOUT,4120) (CNT(I,J,K), J = 1,MM) 130 CONTINUE 132 CONTINUE RETURN C C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 4100 FORMAT (//, 1H , 80(1H-), /, A 1H , 1H-, A6, 1H-, 4HZ0M , F12.6) 4110 FORMAT (/, A 1H , 4H K , I4) 4120 FORMAT ( A (1H , 8X, 4F16.8)) END rrpsmt.f000644 000311 000121 00000017115 06067230312 012372 0ustar00krivecf1000000 000000 SUBROUTINE RRPSMT(NCDS, NCDP, NCDCN, NDBIN1, NDBIN2, NDZ0MP, 1 WS, WD, MM, MU, IPXU, IPOFF, Z0M, JMAX, AA, 2 RHOUW, PP, QQ, RR, BIN, Z0MPOW, 3 LTEST, LPRBIN, LPRZ0M, NOUT, 4 CNT, Z0P, IPR, IPC) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LTEST, LPRBIN, LPRZ0M DIMENSION WS(NCDS,NCDS,NCDP), WD(NCDS,NCDS,NCDP), 1 MU(NCDS), 2 PP(NCDS,NCDS,NCDCN), QQ(NCDS,NCDS,NCDCN), 3 RR(NCDS,NCDS), BIN(NDBIN1,NDBIN2), Z0MPOW(NDZ0MP), 4 CNT(NCDS,NCDS,NCDCN) C C C C C TEST VERSION OF RRPSM. C C C C CHARACTER*6 NAME DATA NAME / 'RRPSMT' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 93/09/15 (RRPSM 1.0, RRPSLT 1.1) ' / C ------------------------------------------------------------ C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DATA ZERO, ONE, TWO / 0.D0, 1.D0, 2.D0 / C C C C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS C C IF (MM .GT. NCDS) CALL ERR2(NAME, 1, 1, NOUT) IF (IPXU .GT. NCDP) CALL ERR2(NAME, 2, 1, NOUT) IF (JMAX+1 .GT. NCDCN) CALL ERR2(NAME, 3, 1, NOUT) IF (ABS(AA) .LT. CDXTOL()) CALL ERR2(NAME, 4, 1, NOUT) C C C TEST IPOFF ; IF LARGER THAN 2, THERE ARE PROBABLY C POWERS LESS THAN -1 IN W; THESE POWERS WILL BE IGNORED BY THIS C ROUTINE; WARNING ONLY IS ISSUED HERE. C (THE RECURSION RELATIONS ASSUME POWERS ARE .GE. -1.) IF (LCALL0 .AND. IPOFF .GT. 2) CALL ERR2(NAME, 11, 0, NOUT) C C C JMAX SHOULD BE .GE. 2; IF NOT, WARNING; RETURN. IF (LCALL0 .AND. JMAX .LT. 2) CALL ERR2(NAME, 21, 0, NOUT) IF (LCALL0) LCALL0 = .FALSE. IF (JMAX .LT. 2) RETURN C C C Z PAST WHICH W WILL BE TAKEN AS ZERO. IF RHOUW IS NONNEGATIVE, C IT IS ASSUMED TO REPRESENT A RHO-VALUE. IF IT IS NEGATIVE, C IT IS ASSUMED TO REPRESENT A Z-VALUE. IF (RHOUW .GE. ZERO) ZUW = TWO * AA * RHOUW IF (RHOUW .LT. ZERO) ZUW = -RHOUW C C JMAX1 = JMAX + 1 ZZZ4 = ONE / (TWO * AA) C C C BINOMIAL COEFFICIENTS AND POWERS OF Z0M. IPU = IPXU - IPOFF JRU = JMAX - 2 + 1 CALL BINA(NDBIN1, NDBIN2, IPU, JRU, BIN, LPRBIN, NOUT) IPOWL = - JMAX IPOWU = IPU C POWERS OF RHO SHOULD BE CALCULATED INSTEAD; PERHAPS IN LOG SCALE. CALL POWA(NDZ0MP, IPOWL, IPOWU, Z0M, LPRZ0M, NOUT, 1 Z0MPOW, NZ0MOF) C C C CALCULATE AND STORE ALL PP, QQ. M1 IS R+2 (SEE COMMENT). DO 68 M1 = 1,JMAX JR = M1 - 2 C C C CALCULATE PP(R+1). ZZZ51 = BIN(-1+3,JR+1+1) * Z0MPOW(-JR-2+NZ0MOF) DO 22 I = 1,MM DO 20 J = 1,MM PP(J,I,M1) = ZERO 20 CONTINUE 22 CONTINUE DO 24 I = 1,MM PP(I,I,M1) = ZZZ51 24 CONTINUE IF (Z0M .LE. ZUW) THEN C C SMALLEST POWER (IP) IS R + 1 BECAUSE IT APPEARS AS THE C UPPER ARGUMENT OF BINOMIAL COEFFICIENT AND IS ASSUMED C TO BE .GE. 0. (IN OTHER WORDS, HERE WE IGNORE NEGATIVE C POWERS IN WD.) IPXL = JR + 1 + IPOFF IF (IPXL .LE. IPXU) THEN DO 34 IPX = IPXL,IPXU IP = IPX - IPOFF ZZZ52 = - BIN(IP+3,JR+1+1) 1 * Z0MPOW(IP-JR-1+NZ0MOF) 2 * ZZZ4 ** (IP+1) DO 32 I = 1,MM DO 30 J = 1,MM PP(J,I,M1) = PP(J,I,M1) 1 + ZZZ52 * WD(J,I,IPX) 30 CONTINUE 32 CONTINUE 34 CONTINUE ENDIF ENDIF C C C CALCULATE QQ(R) (IF R .GE. 0); ZERO QQ ALSO IF R .LT. 0. DO 42 I = 1,MM DO 40 J = 1,MM QQ(J,I,M1) = ZERO 40 CONTINUE 42 CONTINUE IF (JR .LT. 0) GO TO 66 C C C ENERGY AND CENTRIFUGAL TERMS. IF (JR .EQ. 0) THEN ZZZ61 = -0.25D0 DO 50 I = 1,MM QQ(I,I,M1) = ZZZ61 50 CONTINUE ENDIF IF (JR .GE. 0) THEN ZZZ62 = -BIN(-2+3,JR+1) * Z0MPOW(-JR-2+NZ0MOF) DO 52 I = 1,MM QQ(I,I,M1) = QQ(I,I,M1) + ZZZ62 * MU(I) ** 2 52 CONTINUE ENDIF IF (Z0M .GT. ZUW) GO TO 66 C C POWER (IP) IS ASSUMED TO BE .GE. -1. ALL R .GE. 0 ARE C ALLOWED BY THE BINOMIAL COEFFICIENT IF IP = -1, ELSE C IP MUST BE .GE. R. (IN OTHER WORDS, POWERS .LT. -1 ARE C IGNORED HERE.) IPXL = -1 + IPOFF IF (IPXL .GT. IPXU) CALL ERR2(NAME, 31, 1, NOUT) DO 64 IPX = IPXL,IPXU IP = IPX - IPOFF IF (IP .GE. 0 .AND. JR .GT. IP) GO TO 64 ZZZ63 = - BIN(IP+3,JR+1) * Z0MPOW(IP-JR+NZ0MOF) 1 * ZZZ4 ** (IP+2) DO 62 I = 1,MM DO 60 J = 1,MM QQ(J,I,M1) = QQ(J,I,M1) + ZZZ63 * WS(J,I,IPX) 60 CONTINUE 62 CONTINUE 64 CONTINUE 66 CONTINUE 68 CONTINUE C C C CALCULATE CNT . N1 IS P+1 OF COMMENT. DO 124 N1 = 3,JMAX1 C C C RESET CNT (**** DO NOT RESET C(0), C(1) ****). DO 72 J = 1,MM DO 70 I = 1,MM CNT(I,J,N1) = ZERO 70 CONTINUE 72 CONTINUE JP = N1 - 1 C C C SUM OVER R (R = -1,..., JP-2). C C FIRST LOOP: EXCLUDE CN(,,1). JP1 = JP - 1 DO 90 M1 = 1,JP1 JR = M1 - 2 ZZZ72 = JP - JR - 2 DO 82 K = 1,MM DO 80 J = 1,MM RR(J,K) = ZZZ72 * PP(J,K,M1) + QQ(J,K,M1) 80 CONTINUE 82 CONTINUE DO 88 J = 1,MM DO 86 I = 1,MM DO 84 K = 1,MM CNT(I,J,N1) = CNT(I,J,N1) 1 + CNT(I,K,N1-JR-2) * RR(J,K) 84 CONTINUE 86 CONTINUE 88 CONTINUE 90 CONTINUE C C SECOND LOOP: CN(1) = I ONLY (IMPLICIT). M1 = JP JR = M1 - 2 ZZZ72 = JP - JR - 2 DO 104 K = 1,MM DO 102 J = 1,MM RR(J,K) = ZZZ72 * PP(J,K,M1) + QQ(J,K,M1) 102 CONTINUE 104 CONTINUE DO 108 J = 1,MM DO 106 I = 1,MM CNT(I,J,N1) = CNT(I,J,N1) + RR(J,I) 106 CONTINUE 108 CONTINUE C C C FINISH C(JP) . ZZZ71 = - ONE / DFLOAT(JP * (JP - 1)) DO 122 J = 1,MM DO 120 I = 1,MM CNT(I,J,N1) = ZZZ71 * CNT(I,J,N1) 120 CONTINUE 122 CONTINUE 124 CONTINUE C C C TEST OUTPUT. IF (.NOT.LTEST) RETURN WRITE (NOUT,4100) NAME, Z0M ZZZ81 = ONE ZZZ83 = ZERO DO 130 K = 1,JMAX1 K1 = K - 1 ZZZ82 = CNT(IPR,IPC,K) * ZZZ81 ZZZ83 = ZZZ83 + ZZZ82 WRITE (NOUT,5200) K1, ZZZ81, CNT(IPR,IPC,K), ZZZ82, ZZZ83 ZZZ81 = ZZZ81 * (Z0P - Z0M) 130 CONTINUE CALL CDXFBO(NOUT) RETURN C C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 4100 FORMAT (1H , 80(1H-), /, A 2H -, A6, 1H-, 4HZ0M , F12.6) 5200 FORMAT (1H , 4HCNT , I4, 4E16.8) END vicdf.f000644 000311 000121 00000025452 06067230330 012141 0ustar00krivecf1000000 000000 SUBROUTINE VICDF(NDMM, NDCN, NDP, NDML, 1 MM, N, M1, IM, IX, KM, KX, ML, 2 LMIN, LMAX, LMAX1, LMAXY, LMAXXY, LMAXYX, 3 MU, CN, P, P2, XXX, 4 WS, WD, ZKAPPA, IPXU, IPOFF, 5 X, Y, XY, YX, XD0, 6 NOUT, LTEST) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LTEST DIMENSION LMIN(NDMM), LMAX(NDMM,NDML), LMAX1(NDMM,NDML), 1 LMAXY(NDMM), LMAXXY(NDMM), LMAXYX(NDMM), 2 MU(NDMM), CN(NDMM,NDMM,NDCN), P(NDMM,NDMM), 3 P2(NDMM,NDMM), XXX(NDMM), 4 WS(NDMM,NDMM,NDP), WD(NDMM,NDMM,NDP), 5 X(NDMM,NDMM), Y(NDMM,NDMM), XY(NDMM,NDMM), 6 YX(NDMM,NDMM), XD0(NDMM,NDMM) C C C C C MODIFIED SUBROUTINE VICTOR BY M. HAFTEL. C CALCULATES THE SAME (MODIFIED) QUANTITIES AS VICTOR , BUT C FOR GENERAL POWER EXPANSIONS OF MATRIX ELEMENTS (SUM OVER C POWERS IS INTERNAL TO THIS SUBROUTINE.) C C ****************************************************************** C * THIS VERSION I G N O R E S POWERS SMALLER THAN -1 IN W . * C * THIS VERSION USES UNTRANSPOSED W . * C * CN IS THE SAME AS IN THE ROUTINES WHICH USE TRANSPOSED W . * C ****************************************************************** C C MODIFICATION MADE UNDER ASSUMPTION THAT AT THE TIME OF C CALL OF THIS ROUTINE THE RECURSIVELY CALCULATED CN C IS AVAILABLE FOR ALL N NEEDED. C C C GENERALIZATION TO POWER SERIES IN EFFECTIVE POTENTIAL: C C REPLACEMENTS (IPX = STORAGE INDEX FOR POWER IP; C NOTE THAT WS , WD ARE ALREADY MULTIPLIED BY 2, AS IN C THE HAFTEL PROGRAM): C C C X(K,I) --> SUM(IP=-1,...,N-2) (2 KAPPA)**(-IP-1) C WS(K,M,IPX) CN(M,I,N-IP-2+1); C C XW0(K,I) --> 0 (ELIMINATED); C C (N+MU(I)-1) XD0(K,I) --> SUM(IP=0,...,N-1) C (2 KAPPA)**(-IP) C WD(K,M,IPX) CN(M,I,N-IP-1+1) C (N+MU(I)-IP-1); C C XY(K,I) --> SUM(IP) (2 KAPPA)**(-IP) C WD(K,J,IPX) CN(J,L,N+MU(I)-MU(L)-IP-1+1) C P(L,I); C C Y(K,I) UNCHANGED; C C YX(K,I) UNCHANGED. C C C C CHARACTER*6 NAME DATA NAME / 'VICDF ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 93/05/18. O: VICDE 1.0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS C C IF (LTEST) WRITE (NOUT,4010) NAME, 1 MM, N, M1, IM, IX, KM, KX, ML C C C DIMENSION CHECKS. C CHECK THAT W HAS POWERS LARGER THAN -2 (BASIC ASSUMPTION). C C IF (LCALL0 .AND. IPOFF .GT. 2) CALL ERR2(NAME, 11, 0, NOUT) IF (LCALL0) LCALL0 = .FALSE. IF (IPXU .GT. NDP) CALL ERR2(NAME, 12, 1, NOUT) IF (N+1 .GT. NDCN) CALL ERR2(NAME, 13, 1, NOUT) IF (MM .GT. NDMM) CALL ERR2(NAME, 14, 1, NOUT) IF (ML .GT. NDML) CALL ERR2(NAME, 15, 1, NOUT) C C C INITIALIZE ARRAYS C C DO 1 I = IM, IX DO 1 K = KM, KX X(K,I) = 0.D0 Y(K,I) = 0.D0 XD0(K,I) = 0.D0 XY(K,I) = 0.D0 1 YX(K,I) = 0.D0 C C IF (N - ML) 2, 2, 3 C C CALCULATION OF MAXIMUM L INDICES FOR INTERMEDIATE SUMS IN C CALCULATIONS OF Y,XY,YX C THESE ARE CALCULATED FOR N .LE.ML AND THEN C STORED FOR USE FOR N>ML C COMPUTE INTERMEDIATE SUM LIMITS C 2 DO 4 I = IM, IX I1 = I + 1 LMAXY(I) = LMAX(I,N) * (M1 - 1) + LMAX1(I,N) * (2-M1) LMAXXY(I) = LMAX1(I,N) LMAXYX(I) = LMAX(I,N) C C THE MATRIX P**2 NEED ONLY BE CALCULATED FOR N.LE.ML AND THEN C STORED FOR LATER USE FOR N>ML I2 = I + 2 C C SELECTION RULE ON INDICES OF P2 BECAUSE OF THE PROPERTIES OF P IF (I2 .GT. MM) GO TO 37 DO 6 L = 1, MM L1 = L - 1 P2(L,I) = 0.D0 IF (I1 .GT. L1 ) GO TO 6 IF (L .LT. LMIN(I) ) GO TO 6 IF (L .GT. LMAXYX(I) ) GO TO 37 DO 7 M = I1, L1 7 P2(L,I) = P2(L,I) + P(L,M) * P(M,I) 6 CONTINUE 37 CONTINUE 4 CONTINUE IF (LTEST) WRITE (NOUT,4100) NAME, 1 (I, LMAXY(I), LMAXXY(I), LMAXYX(I), I = IM,IX) IF (.NOT.LTEST) GO TO 4114 DO 4112 L = 1,MM WRITE (NOUT,4110) NAME, L, (P2(L,I), I = IM,IX) 4112 CONTINUE 4114 CONTINUE 3 CONTINUE C C C FIX FINAL INDEX (I) FOR ALL ARRAYS DO 8 I = IM,IX C C FROM CC AND CCM ASSIGNMENTS ABOVE IT IS CONCLUDED THAT C C(0) TO C(N) ARE AVAILABLE IN CN(.,.,1) TO CN(.,.,N+1), C AND WILL BE USED ACCORDINGLY. IF STATEMENTS WILL BE USED C TO PREVENT GOING INTO THE BASEMENT. C C NOTE - WS , WD ARE TRANSPOSED WITH RESPECT TO THE C HAFTEL PROGRAM. C IF (N .LT. 1) GO TO 170 DO 160 IPX = 1,IPXU C C POWER. IP = IPX - IPOFF C **** IP FROM -1: BASIC ASSUMPTION. **** IF (.NOT.(IP .GE. -1 .AND. IP .LE. N - 2)) GO TO 130 C C C REPLACEMENT FOR (X + XW0/(2*KAPPA)). C THIS WILL BE PASSED TO CALLING PROGRAM IN ARRAY X , C AND ARRAY XW0 IS ELIMINATED. C C ZZZ0 = 1.D0 / (2.D0 * ZKAPPA)**(IP+1) IPX1 = (N - IP - 2) + 1 DO 120 M = 1,MM DO 110 K = KM,KX X(K,I) = X(K,I) + 1 WS(K,M,IPX) * CN(M,I,IPX1) * ZZZ0 110 CONTINUE 120 CONTINUE 130 CONTINUE C **** IP FROM 0: BASIC ASSUMPTION. **** IF (.NOT.(IP .GE. 0 .AND. IP .LE. N - 1)) GO TO 160 C C C REPLACEMENT FOR XD0 . C THIS WILL BE PASSED TO CALLING PROGRAM IN ARRAY XD0 C AS BEFORE. C C ZZZ1 = DFLOAT(N + MU(I) - IP - 1) 1 / (2.D0 * ZKAPPA)**IP IPX1 = (N - IP - 1) + 1 DO 150 M = 1,MM DO 140 K = KM,KX XD0(K,I) = XD0(K,I) + 1 WD(K,M,IPX) * CN(M,I,IPX1) * ZZZ1 140 CONTINUE 150 CONTINUE IF (LTEST) WRITE (NOUT,4020) 1 (NAME, M, I, IPX1, CN(M,I,IPX1), M = 1,MM) 160 CONTINUE 170 CONTINUE C C C C IS NOT USED ANYMORE. NOTE LMIN(I) .GE. I . C Y , YX MUST NOW BE SKIPPED IF JJ .LT. 1 . C C CALCULATION OF Y ARRAY C LM = LMIN(I) LX = LMAXY(I) IF (LM .GT. LX ) GO TO 39 DO 31 L = LM, LX JJ = (N + MU(I) - MU(L)) + 1 IF (JJ .LT. 1) GO TO 31 C THIS TEST IS PROBABLY REDUNDANT. IF (JJ .GT. N) CALL ERR2(NAME, 21, 1, NOUT) PP = P(L,I) DO 32 K = KM, KX 32 Y(K,I) = Y(K,I) + PP * CN(K,L,JJ) 31 CONTINUE C C CALCULATION OF YX ARRAY C 39 LM = MAX(I + 2,LMIN(I) ) LX = LMAXYX(I) IF (LM .GT. LX ) GO TO 40 DO 33 L = LM, LX JJ = (N + MU(I) - MU(L)) + 1 IF (JJ .LT. 1) GO TO 33 C THIS TEST IS PROBABLY REDUNDANT. IF (JJ .GT. N) CALL ERR2(NAME, 31, 1, NOUT) PP = P2(L,I) DO 34 K = KM, KX 34 YX(K,I) = YX(K,I) + PP * CN(K,L,JJ) 33 CONTINUE C C TRANSFER FROM ABOVE. 40 CONTINUE C C C REPLACEMENT FOR XY . C THIS WILL BE PASSED TO CALLING PROGRAM IN ARRAY XY AS BEFORE. C C **** NOTE: **** C C IN THE ORIGINAL VERSION, CT WAS DEFINED THROUGH CN ONLY C FOR THE ELEMENTS CT(KM...KX,I...MM) , AND WAS UNDEFINED C OTHERWISE ( CT APPEARED IN DIMENSION , NOT IN COMMON ). C NEVERTHELESS, IN THE XY CALCULATION THE ELEMENTS C CT(1...MM,I...LX) WERE USED (SEE ABOVE). C C IN THE NEW VERSION (BELOW), ONLY THE ELEMENTS C CN(KM...KX,.,.) ARE USED. C THIS IS PROBABLY OK BUT WAS NOT POINTED OUT BY M. HAFTEL ON C 19 MARCH 1990 WHEN THE CT WAS SUGGESTED TO BE DISCARDED. C C IF (N .LT. 1) GO TO 250 C C THE FOLLOWING UPPER BOUND ON L IS STILL LARGE ENOUGH C BECAUSE FOR POWERS IN THE POTENTIAL LARGER THAN 0, C THE CN INDEX WILL BE SMALLER THAN THAT ALLOWED BY LX ; C BUT IT IS NECESSARY TO USE IF TO PREVENT IT FROM C BECOMING LESS THAN 1 (THE NEW RANGE FOR L IS SMALLER C THAN THE OLD RANGE). LX = LMAXXY(I) IF (I .GT. LX) GO TO 250 DO 240 IPX = 1,IPXU C POWER. IP = IPX - IPOFF C **** IP FROM 0: BASIC ASSUMPTION. **** IF (.NOT.(IP .GE. 0)) GO TO 240 ZZZ2 = 1.D0 / (2.D0 * ZKAPPA)**IP C C AUXILIARY ARRAY. DO 200 M = KM,KX XXX(M) = 0.D0 200 CONTINUE DO 212 L = I,LX C INDEX OF CN, SKIP (UPPER BOUND N IS OK). IPX1 = (N - IP + MU(I) - MU(L) - 1) + 1 IF (IPX1 .GT. 0) THEN C (NO REPETITION IN XXX CALCULATION). DO 210 M = KM,KX XXX(M) = XXX(M) + CN(M,L,IPX1) * P(L,I) 210 CONTINUE ENDIF 212 CONTINUE C MULTIPLY HERE TO AVOID OVERFLOW. DO 214 M = KM,KX XXX(M) = XXX(M) * ZZZ2 214 CONTINUE DO 222 M = KM,KX DO 220 K = KM,KX XY(K,I) = XY(K,I) + 1 WD(K,M,IPX) * XXX(M) 220 CONTINUE 222 CONTINUE 240 CONTINUE 250 CONTINUE 8 CONTINUE RETURN C C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 4010 FORMAT ( A 1H , 1H-, A6, 1H-, B 32H MM N M1 IM IX KM KX ML, /, C 1H , 8X, 8I4) 4020 FORMAT ( A 1H , 1H-, A6, 1H-, B 8HCN (XD0), 3I4, F16.8) 4100 FORMAT ( A 1H , 1H-, A6, 1H-, B 12HLMAXY/XY/YX , /, C (1H , I4, 4X, 3I4)) 4110 FORMAT ( A 1H , 1H-, A6, 1H-, B 12HP2 , /, C I4, 5F12.6, /, (1H , 4X, 5F12.6)) END wfps0a.f000644 000311 000121 00000006016 06067230331 012242 0ustar00krivecf1000000 000000 SUBROUTINE WFPS0A(NDS, NDCN, NDINT, 1 MM, MA, NM, IBL, IBR, 2 NOUT, NOUTA, NOUTB, LOUTB, 3 CN, PM, DML, CV) IMPLICIT REAL*8 (A - H, O - Z) DIMENSION CN(NDS,NDS,NDCN), PM(NDS,NDS), DML(NDS), 1 CV(NDS,NDINT) LOGICAL LOUTB C C C CALCULATES WAVE FUNCTION POWER SERIES ON INTERVAL 1. C SOME INPUT IS ONLY NEEDED TO WRITE IT TO UNIT NOUTB, TO KEEP C WRITE STATEMENTS TOGETHER. C C ****************************************************************** C * ON THE FIRST INTERVAL, CN IS THE SAME AS IN THE ORIGINAL D . * C ****************************************************************** C C CHARACTER*6 NAME DATA NAME / 'WFPS0A' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/08/14. O: WFPSDA 1.5, 91/07/24. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C CHECK DIMENSIONS. NOTE THAT THE CHECK OF NM IS THE C CONSEQUENCE OF THE DEFINITIONS IN RRLSDD. IF (MM .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (NM + 1 + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) IF (IBR .GT. NDINT) CALL ERR2(NAME, 3, 1, NOUT) IF (MA .LE. 0) CALL ERR2(NAME, 4, 1, NOUT) C C INITIALIZE. NMP1 = NM + 1 REWIND NOUTA C C READ INTERVAL DATA. READ (NOUTA) IINT, Z0M, Z0P IF (IINT .NE. 1) CALL ERR2(NAME, 11, 1, NOUT) C --------------------------------------- IF (LOUTB) THEN WRITE (NOUTB) IBL, IBR WRITE (NOUTB) (CV(I,IBL), I = 1,MM) WRITE (NOUTB) (CV(I,IBR), I = 1,MM) WRITE (NOUTB) IINT, Z0M, Z0P ENDIF C --------------------------------------- C READ ARRAYS CN, PM, MULTIPLY BY CV. DO 12 K = 1,NMP1 DO 10 J = 1,MM READ (NOUTA) (CN(I,J,K), I = 1,MM) 10 CONTINUE 12 CONTINUE DO 28 M = 1,MA DO 20 J = 1,MM READ (NOUTA) (PM(I,J), I = 1,MM) 20 CONTINUE DO 22 I = 1,MM DML(I) = ZERO 22 CONTINUE DO 26 J = 1,MM DO 24 I = 1,MM DML(I) = DML(I) + PM(I,J) * CV(J,IINT) 24 CONTINUE 26 CONTINUE C C STORE PRODUCT. C ------------------------------------------- IF (LOUTB) WRITE (NOUTB) (DML(I), I = 1,MM) C ------------------------------------------- 28 CONTINUE IF (LOUTB) THEN C STORE CN . C ------------------------------------------- DO 42 K = 1,NMP1 DO 40 J = 1,MM WRITE (NOUTB) (CN(I,J,K), I = 1,MM) 40 CONTINUE 42 CONTINUE C ------------------------------------------- ENDIF RETURN C 4000 FORMAT ( A 2H -, A6, 1H-, A60) END wfps1a.f000644 000311 000121 00000012720 06067230333 012244 0ustar00krivecf1000000 000000 SUBROUTINE WFPS1A(NDS, NDCN, NDINT, 1 IINT, Z0M, Z0P, IINTO, Z0MO, Z0PO, 2 MM, JMAX, IBL, IBR, IINTPR, ZMATCH, 3 NOUT, LPR, NOUTB, LOUTB, 4 CN, CV, WF, WFD, WFL, WFDL, WFC) IMPLICIT REAL*8 (A - H, O - Z) DIMENSION CN(NDS,NDS,NDCN), CV(NDS,NDINT), 1 WF(NDS), WFD(NDS), WFL(NDS), WFDL(NDS), 2 WFC(NDS,NDCN) LOGICAL LPR, LOUTB C C C WAVE FUNCTION POWER SERIES ON AN INTERVAL OTHER THAN 1 AND C OPTIONALLY OUTPUTS DISCONTINUITY OF WAVE FUNCTION AT INTERVAL C BOUNDARY. C C ****************************************************************** C * CN IS TRANSPOSED RELATIVE TO ORIGINAL D . * C ****************************************************************** C C CHARACTER*6 NAME DATA NAME / 'WFPS1A' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/08/14. O: WFPSDA 1.5, 91/07/24. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS C C CHECK DIMENSIONS. IF (MM .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) IF (IBR .GT. NDINT) CALL ERR2(NAME, 3, 1, NOUT) C C INITIALIZE. JMAX1 = JMAX + 1 IF (IINT - IINTO .NE. 1) CALL ERR2(NAME, 31, 1, NOUT) IF (IINT .NE. IBL + 1 .AND. Z0M .NE. Z0PO) 1 CALL ERR2(NAME, 32, 1, NOUT) IF (LCALL0) WRITE (NOUT,3000) NAME C C WAVE FUNCTION COMPARISONS WHICH MUST BE DONE BEFORE WFC IS C REDEFINED. C ------------------------------------------------------------------ C IF (LPR .AND. IINT .GE. 3 .AND. IINT .NE. IBL + 1 1 .AND. MOD(IINT, IINTPR) .EQ. 0) THEN C C ON CERTAIN INTERVALS, EXCEPT ON THE SECOND INTERVAL AND C EXCEPT ON THE FARTHEST INTERVAL (AT Z = ZTOP, NUMBER C IBL + 1), CALCULATE WAVE FUNCTION AT END OF PREVIOUS C INTERVAL; USE POWER SERIES ARRAY AS DEFINED ON PREVIOUS C CALL (IBL: INTERVAL LEFT OF Z = ZMATCH). DZO = Z0PO - Z0MO CALL WFSDA(NDS, NDCN, 1 MM, JMAX, DZO, NOUT, 2 WFC, WF, WFD) ENDIF IF (LPR .AND. IINT .EQ. IBL + 1) THEN C C IF PREVIOUS INTERVAL WAS THE ONE LEFT OF Z = ZMATCH, C CALCULATE WF AT Z = ZMATCH FOR LATER COMPARISON. IF (Z0PO .NE. ZMATCH) CALL ERR2(NAME, 41, 1, NOUT) DZO = Z0PO - Z0MO CALL WFSDA(NDS, NDCN, 1 MM, JMAX, DZO, NOUT, 2 WFC, WFL, WFDL) ENDIF C C MULTIPLY BY CV TO GET WAVE FUNCTION POWER SERIES ON C THE PRESENT INTERVAL. C ------------------------------------------------------------------ C DO 66 K = 1,JMAX1 DO 60 I = 1,MM WFC(I,K) = ZERO 60 CONTINUE DO 64 J = 1,MM DO 62 I = 1,MM WFC(I,K) = WFC(I,K) + CV(J,IINT) * CN(J,I,K) 62 CONTINUE 64 CONTINUE 66 CONTINUE IF (LOUTB) THEN C STORE POWER SERIES. C -------------------------------------- WRITE (NOUTB) IINT, Z0M, Z0P DO 70 J = 1,JMAX1 WRITE (NOUTB) (WFC(I,J), I = 1,MM) 70 CONTINUE C -------------------------------------- ENDIF C C WAVE FUNCTION COMPARISONS AFTER WFC WAS REDEFINED. C ------------------------------------------------------------------ C IF (LPR .AND. IINT .GE. 3 .AND. IINT .NE. IBL + 1 1 .AND. MOD(IINT, IINTPR) .EQ. 0) THEN C C FOR COMPARISON, PRINT WAVE FUNCTION AT END OF PREVIOUS C INTERVAL AND AT BEGINNING OF PRESENT INTERVAL. C (EXCEPTIONS: INTERVALS 2 AND IBL + 1.) WRITE (NOUT,3002) IINT, Z0M DO 80 I = 1,MM Z1 = WF(I) - WFC(I,1) Z2 = WFD(I) - WFC(I,2) WRITE (NOUT,3004) 1 I, WF(I), WFC(I,1), Z1, WFD(I), WFC(I,2), Z2 80 CONTINUE ENDIF IF (LPR .AND. IINT .EQ. IBR) THEN C C WAVE FUNCTION ON INTERVAL RIGHT OF Z = ZMATCH, AT Z = ZMATCH, C USING THE LAST POWER SERIES ARRAY. C COMPARE LEFT AND RIGHT VALUES AT Z = ZMATCH. IF (Z0P .NE. ZMATCH) CALL ERR2(NAME, 51, 1, NOUT) DZ = Z0P - Z0M CALL WFSDA(NDS, NDCN, 1 MM, JMAX, DZ, NOUT, 2 WFC, WF, WFD) WRITE (NOUT,3020) NAME DO 90 I = 1,MM Z1 = WF(I) - WFL(I) Z2 = WFD(I) - WFDL(I) WRITE (NOUT,3022) 1 I, WFL(I), WF(I), Z1, WFDL(I), WFD(I), Z2 90 CONTINUE ENDIF IF (LCALL0) LCALL0 = .FALSE. RETURN C 4000 FORMAT ( A 2H -, A6, 1H-, A60) 3000 FORMAT ( A 2H -, A6, 1H-, 40HWAVE FUNCTION DISCONTINUITIES , /, B 1H , 4X, 34H WF(LEFT) WF(RIGHT) DIFF., C 34H DERIV(LEFT) DERIV(RIGHT) DIFF.) 3002 FORMAT ( A 1H , 16H INTERVAL, Z:, I4, F16.4) 3004 FORMAT ( A 1H , I4, 2(2D12.4, D10.2)) 3020 FORMAT ( A 2H -, A6, 1H-, B 44HWAVE FUNCTION DISCONTINUITY AT Z = ZMATCH , /, C 1H , 4X, 34H WF(LEFT) WF(RIGHT) DIFF., D 34H DERIV(LEFT) DERIV(RIGHT) DIFF.) 3022 FORMAT ( A 1H , I4, 2(2D12.4, D10.2)) END wfsda.f000644 000311 000121 00000002663 06067230335 012156 0ustar00krivecf1000000 000000 SUBROUTINE WFSDA(NDS, NDCN, 1 N, JMAX, DZ, NOUT, 2 WFC, WF, WFD) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WFC(NDS,NDCN), WF(NDS), WFD(NDS) C C C SUM OF WAVE FUNCTION AND DERIVATIVE POWER SERIES. C C CHARACTER*6 NAME DATA NAME / 'WFSDA ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/03/06. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,4000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C CHECK DIMENSIONS. IF (N .LE. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (JMAX .LE. 0) CALL ERR2(NAME, 3, 1, NOUT) IF (JMAX+1 .GT. NDCN) CALL ERR2(NAME, 4, 1, NOUT) C ZERO = 0.D0 ONE = 1.D0 C DO 20 I = 1,N WF(I) = WFC(I,1) WFD(I) = ZERO 20 CONTINUE IF (JMAX .GE. 1) THEN JMAX1 = JMAX + 1 DZX = ONE DO 24 K = 2,JMAX1 DO 22 I = 1,N WF(I) = WF(I) + (WFC(I,K) * DZX) * DZ WFD(I) = WFD(I) + (K - 1) * (WFC(I,K) * DZX) 22 CONTINUE DZX = DZX * DZ 24 CONTINUE ENDIF RETURN C 4000 FORMAT ( A 2H -, A6, 1H-, A60) END xsum0a.f000644 000311 000121 00000002475 06067230357 012274 0ustar00krivecf1000000 000000 SUBROUTINE XSUM0A(NDS, ZM, NS, MU, ZML, P1, P2, S, SD, CN) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION MU(NDS), ZML(NDS), P1(NDS,NDS), P2(NDS,NDS), 1 S(NDS,NDS), SD(NDS,NDS), CN(NDS,NDS,2) C C SOLUTION AND ITS DERIVATIVE AT Z = ZM (INTERVAL 1). C CHARACTER*6 NAME DATA NAME / 'XSUM0A' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/08/14. O: DDP 2.0, 91/03/14. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO / 0.D0 / C IF (NS .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) C C ZM**MU. DO 10 L = 1,NS ZML(L) = ZM ** MU(L) 10 CONTINUE C C X(ZM), X'(ZM); STORE IN TRANSPOSE OF CN(.,.,1), CN(.,.,2). C (CN WILL CONTAIN TRANSPOSED X, X' AS IN THE ORIGINAL D ; NO C CHANGE HERE.) DO 24 J = 1,NS DO 22 I = 1,NS C0 = ZERO C1 = ZERO DO 20 L = 1,NS C0 = C0 + S(I,L) * ZML(L) * P1(L,J) C1 = C1 + (SD(I,L) * P1(L,J) + S(I,L) * P2(L,J)) 1 * ZML(L) / ZM 20 CONTINUE CN(J,I,1) = C0 CN(J,I,2) = C1 22 CONTINUE 24 CONTINUE RETURN END xsum1b.f000644 000311 000121 00000002721 06067230361 012263 0ustar00krivecf1000000 000000 SUBROUTINE XSUM1B(NDS, NDCN, Z0P, Z0M, NS, JMAX, CN, S, SD) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION CN(NDS,NDS,NDCN), S(NDS,NDS), SD(NDS,NDS) C C SOLUTION AND ITS DERIVATIVE AT Z = Z0P (ANY INTERVAL EXCEPT 1). C CHARACTER*6 NAME DATA NAME / 'XSUM1B' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 92/03/26. XSUM1A 1.0. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO, ONE / 0.D0, 1.D0 / C IF (NS .GT. NDS) CALL ERR2(NAME, 1, 1, NOUT) IF (JMAX + 1 .GT. NDCN) CALL ERR2(NAME, 2, 1, NOUT) C C X(Z0P), X'(Z0P) FROM PREVIOUS INTERVAL. C S, SD CONTAIN TRANSPOSED X, X'. DO 12 J = 1,NS DO 10 I = 1,NS S(I,J) = ZERO 10 CONTINUE 12 CONTINUE DO 16 J = 1,NS DO 14 I = 1,NS SD(I,J) = ZERO 14 CONTINUE 16 CONTINUE JMAX1 = JMAX + 1 DZ = Z0P - Z0M DZN = ONE DO 28 N1 = 1,JMAX1 DO 22 J = 1,NS DO 20 I = 1,NS S(I,J) = S(I,J) + CN(I,J,N1) * DZN 20 CONTINUE 22 CONTINUE DO 26 J = 1,NS DO 24 I = 1,NS SD(I,J) = SD(I,J) + CN(I,J,N1) * (DZN * (N1 - 1) / DZ) 24 CONTINUE 26 CONTINUE DZN = DZN * DZ 28 CONTINUE RETURN END z1pma.f000644 000311 000121 00000005465 06067230363 012106 0ustar00krivecf1000000 000000 SUBROUTINE Z1PMA(F, A, B, ABSX, ABSF, ITCU, 1 IFN, IFAIL, LTEST, LTIF, NOUT, F3, X3) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LTEST, LTIF C C C FINDS A ZERO OF F(X) IN THE INTERVAL (A, B) BY ONE OF THE C ONE-POINT I.F. WITH MEMORY (TRAUB 1964) C METHODS. FORMULAS WITH A TWO POINT MEMORY CAN BE USED. C NO CHECKS ARE DONE, THE FUNCTION MUST BE WELL BEHAVED. C THIS IS NOT A HIGH SPEED ROUTINE. C C F - FUNCTION F(X). C A, B - INITIAL INTERVAL; F(A), F(B) MUST BE OF OPPOSITE C SIGNS. C ABSX - STOP IF LATEST TWO POINTS ARE CLOSER THAN ABSX. C ABSF - STOP IF ABS(F(X)) IS LESS THAN ABSF. C ITCU - MAX. ALLOWED NUMBER OF ITERATIONS. C IFN - NUMBER OF ITERATION FUNCTION (TRAUB 1964): C 1-... (SEE IF1PM-). C IFAIL - 0: OK. C 2: F(A), F(B) HAVE THE SAME SIGN. C F3 - FUNCTION VALUE AT X3. C X3 - APPROXIMATION TO ZERO. C C CHARACTER*6 NAME DATA NAME / 'Z1PMA ' / CHARACTER*60 VERS DATA VERS */ ' 1.4, 92/04/16. ' / C ............................................................ C EXTERNAL F LOGICAL LCALL0, LINI DATA LCALL0 / .TRUE. /, ZERO, ONE / 0.D0, 1.D0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (ABS(B - A) .LT. CDXTOL()) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C ..INITIALIZE, CHECK SIGN CHANGE. IFAIL = 0 X0 = A X1 = B F0 = F(X0) F1 = F(X1) IF ((SIGN(ONE, F0) * SIGN(ONE, F1)) .GT. ZERO) THEN CALL ERR2(NAME, 2, 0, NOUT) IFAIL = 2 RETURN ENDIF C ..THIRD POINT BY LINEAR INTERPOLATION (2 MEMORIES). X2 = X1 - (X1 - X0) * F1 / (F1 - F0) F2 = F(X2) C ..ITERATION. ITC = 1 10 CONTINUE ITC = ITC + 1 C ..DIVIDED DIFFERENCES. D1 = (F1 - F0) / (X1 - X0) D2 = (F2 - F1) / (X2 - X1) D20 = (F2 - F0) / (X2 - X0) D = (D2 - D1) / (X2 - X0) C ..CALL ITERATION FUNCTION ROUTINE. CALL IF1PMA(X0, X1, X2, F0, F1, F2, D1, D2, D20, D, 1 IFN, LTIF, NOUT, X3) C ..NEW FUNCTION VALUE. F3 = F(X3) IF (LTEST) WRITE (NOUT,3000) NAME, ITC, X3, F3 C ..STOPPING CRITERIA. IF (ITC .GE. ITCU) RETURN IF (ABS(F3) .LT. ABSF) RETURN IF (ABS(X3 - X2) .LT. ABSX) RETURN C ..UPDATE ITERATION POINTS. X0 = X1 X1 = X2 X2 = X3 F0 = F1 F1 = F2 F2 = F3 GO TO 10 C 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-, 8HIT,X3,F3, 14X, I4, 2E22.14) END zerodc.f000644 000311 000121 00000020363 06067230365 012340 0ustar00krivecf1000000 000000 SUBROUTINE ZERODC(F, A, B, LMAX, HH, EPSF, EPSP, FF, Z, P, N, 1 NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION FF(N), Z(N), P(N) C C VERSION OF ZERO BY M. HAFTEL - TABULATING MODE REMOVED. C CALCULATES FIRST N ZEROS OF FUNCTION F(X) BETWEEN X = A AND B. C COMMON / ZER / BTR DIMENSION FS(3), FRS(3), FR(3), X(3) LOGICAL LCALL0 C CHARACTER*6 NAME DATA NAME / 'ZERODC' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 92/11/26 (ZERODB 2.1) ' / C ............................................................ DATA LCALL0 / .TRUE. / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C INITIALIZE ITERATION COUNTING PARAMETERS M = 0 L = 0 C COMPUTE LIMITS ON KAPPA BMIN = A BMAX = B C INITIALIZE PREVIOUS VALUE OF FUNCTION F (WHICH IS THE DETERMINANT C COMPUTED BY FUNCTION D IN THE PRESENT VERSION) FPREV=0.0D0 C COMPUTE MAXIMUM NUMBER OF FUNCTION EVALUATIONS IN FIRST PHASE NTRIAL = ( BMAX - BMIN ) / HH + 1 C SEARCH=0 INDICATES THAT A ZERO HAS NOT BEEN FOUND YET 5 SEARCH = 0.D0 C C THE METHOD TO FIND ZEROS IS AS FOLLOWS: C IN THE FIRST PHASE THE INTERVAL IS DIVIDED INTO NTRIAL STEPS C AND THE STEP ARE SUCESSIVELY SEARCHED FOR WHICH F(X) CHANGES SIGN C THIS GIVES A LOWER AND UPPER BOUND ON THE DESIRED X C THEN THESE X VALUES (TWO OF THEM) AND THEIR F(X) VALUES C ARE USED TO FIND AN IMPROVED X VALUE (CALL X0) BY FINDING C THAT VALUE OF X WHERE A LINEARLY INTERPOLATED VALUE OF F(X) C WOULD GIVE ZERO C THEN THE IMPROVED X0 VALUE IS USED IN THE SAME PROCEDURE USING C LINEAR INTERPOLATION AND THE PROCESS IS REPEATED C C EVERYTHING DOWN TO STATEMENT 10 FINDS A GIVEN ZERO OF F(X) C INITIALIZE FIRST PHASE C POINTS ARE LOOPED OVER ONLY IN GROUPS OF 2; THE LOOP IS REPEATED C UNTIL A SIGN CHANGE IS FOUND NFUN = 2 ATRIAL = NTRIAL C NFIND INDICATES PHASE OF SEARCH (1 OR 2) NFIND = 1 C INTERVAL BETWEEN EVALUATIONS; DELTA, IN GENERAL, IS USED TO CHANGE C THE VALUE OF X (X INDICATES THE INDEPENDENT VARIABLE, WHICH IS C THE BTR VARIABLE IN THE PROGRAM AND CORRESPONDS TO KAPPA) DELTA = ( BMAX - BMIN ) / ( NTRIAL - 1 ) NTRI = NTRIAL BTR = BMIN - DELTA ITRIAL = 0 NINC=0 C COMPUTE QUANTITIES THAT TEST WHETHER TOO MANY ITERATIONS HAVE TAKEN C PLACE ALM=LMAX NINCM=2.D0*SQRT(ALM)+3 C C BEGINNING OF FIRST PHASE C LOOP OVER X POINTS UNTIL SIGN CHANGE OCCURS 12 DO 2 IFUN = 1, NFUN MFU = IFUN C UPDATE X; THE FOLLOWING SECTION OF CODE EVALUATES F(X) IN EITHER PHASE; C IN PHASE 2 THE LOOP IS NEVER COMPLETED AND SUCCESSIVE EVALUATIONS OF C F(X) ARE EXECUTED BY RETURNING TO STATEMENT 25 25 BTR = BTR + DELTA C INCREMENT ITERATION COUNT ITRIAL = ITRIAL + 1 IF ( ITRIAL . LE . NTRI.AND.NINC.LE.NINCM ) GO TO 11 C IF TOO MANY ITERATIONS HAVE OCCURED, GIVE UP M1 = M + 1 IF (NFIND .EQ. 2) WRITE (NOUT,1000) M1, ITRIAL GO TO 35 C EVALUATE NEW F(X) AND COMPUTE SIGN DIFFERENCE WITH PREVIOUS VALUE 11 SD = 0.D0 H = 0.D0 X( MFU ) = BTR FR( MFU ) = F( BTR ) C NINC INCREASE IF ABS(F(X)) INCREASE; TOO MANY SUCCESSIVE INCREASES C AND THE PROGRAM WILL GIVE UP IF (ABS(FR(MFU)).GE.ABS(FPREV).AND.NFIND.EQ.2) NINC=NINC+1 C RESET NINC TO ZERO IF ABS(F(X)) DECREASES IF (ABS(FR(MFU)).LT.ABS(FPREV).OR.NFIND.EQ.1) NINC=0 FPREV=FR(MFU) C COMPUTE SIGN OF NEW F(X) FS( MFU ) = SIGN( 1.0D0, FR( MFU ) ) C PROVISION FOR EXACT ZERO IF ( FR( MFU ) . EQ . 0.D0 ) GO TO 10 IF ( NFIND . EQ . 1 ) GO TO 16 IF ( NFIND . EQ . 2 . AND . ITRIAL . EQ . 1 ) GO TO 16 IF ( FS( 3 ) - FRS( 3 ) ) 18, 17, 18 C THIS SECTION IS FOR SECOND AND FOLLOWING VALUES OF X FOR PHASE 2 C REVISION OF THE MINIMUM AND MAXIMUM VALUES (XL,XG) THAT X CAN C BE FOR F(X)=0 18 IF ( X( 3 ) . LT . XL ) GO TO 16 XL = X( 3 ) FL = FR( 3 ) SL = FS( 3 ) GO TO 16 17 IF ( X( 3 ) . GT . XG ) GO TO 16 XG = X( 3 ) FG = FR( 3 ) SG = FS( 3 ) C END OF SECTION; COMPUTE SIGN OF NEWEST F(X) 16 FRS( MFU ) =SIGN( 1.0D0, FR( IFUN ) ) GO TO ( 23, 4 ), NFIND C PHASE 1 C COMPUTE DIFFERENCE IN SIGN OF LAST TWO F(X)'S (PHASE 1 ONLY) 23 IF ( ITRIAL . GT . 1.D0 ) SD = FRS( 1 ) - FRS( 2 ) C IF NO SIGN CHANGE, CONSIDER NEXT X VALUE IF ( ABS( SD ) . LT . 1.D0 ) GO TO 2 C INITIALIZE CALCULATION IN PREPARATION FOR PHASE 2 (SIGN HAS JUST C CHANGED) C CALCULATION OF FIRST "IMPROVED VALUE" OF X WHEN A SIGN CHANGE C IN F(X) IS DETECTED OVER AN INTERVAL IN THE INITIAL SEARCH C NFIND = 2 C ITERATION MAXIMUM CONTROL VARIABLE FOR PHASE 2 NTRI = LMAX C IMPROVED X X0 = X( 1 ) + ( X( 1 ) - X( 2 ) ) * FR( 1 ) / ( FR(2) - FR( 1) ) C X (BTR) NEED NOT BE CHANGED WHEN PROCEEDING TO ST. 25 FOR BEGINNING C OF PHASE 2 DELTA = 0.D0 ITRIAL = 0.D0 BTR = X0 MFU = 3 GO TO 25 C THIS SECTION OF CODE IS ENCOUNTERED AFTER FIRST F(X) EVALUATION OF PHASE C 2 4 IF ( ITRIAL . GT . 1 ) GO TO 13 C COMPUTE LIMITS ON INTERVAL OF X WHERE F(X) CAN BE ZERO IFU = 1 IFUP = 2 SD = FRS( 2 ) - FRS( 3 ) IF ( ABS( SD ) . GT . 1.D0 ) IFU = 2 IF ( IFU . EQ . 2 ) IFUP = 1 XL = X( IFU ) XG = X( IFUP ) FL = FR( IFU ) FG = FR( IFUP ) SL = SIGN(1.0D0, FL ) SG = SIGN(1.0D0, FG ) IF ( FS( 3 ) - FRS( 3 ) ) 20, 21, 20 21 XG = X( 3 ) FG = FR( 3 ) SG = FS( 3 ) GO TO 13 20 XL = X( 3 ) FL = FR( 3 ) SL = FS( 3 ) C C CALCULATION OF IMPROVED X0 BY LINEAR EXTRAPOLATION (PHASE 2) C 13 H = ABS( X( 3 ) - X( IFU ) ) C IF INTERVAL IN WHICH X CAN BE ZERO IS SMALLER THAN SPECIFIED VALUE, C THEN RECORD THIS AS ZERO POINT IF ( H . LT . EPSP ) GO TO 10 HF = ABS( FR( 3 ) ) C RECORD ZERO POINT IF FUNCTION VALUE IS LESS THAN SPECIFIED MINIMUM IF ( HF . LT . EPSF ) GO TO 10 C COMPUTE IMPROVED X (X0) X0 = X( 3 ) + ( X( 3 ) - X( IFU ) ) * FR( 3 ) / ( FR( IFU ) - 1 FR( 3 ) ) C TEST ON WHETHER THE IMPROVED X0 FALLS WITHIN THE KNOWN C MINIMUM AND MAXIMUM VALUES C IF NOT AN ALTERNATE PREVIOUSLY CALCULATED X0 (WHICH IS EITHER C XL OR XG) IS USED TO LINEARLY EXTAPOLATE WHICH ASSURES A X0 C WITHIN THE REQUIRED BOUNDS C IF ( X0 . GE . XL . AND . X0 . LE . XG ) GO TO 14 C IT DOESN'T FALL IN REQUIRED BOUNDS; DO AN ALTERNATE EXTRAPOLATION XT = XL FT = FL IF ( FS( 3 ) . EQ . FRS( 3 ) ) GO TO 15 XT = XG FT = FG 15 X0 = X( 3 ) + ( X( 3 ) - XT ) * FR( 3 ) / ( FT - FR( 3 ) ) C UPDATE X FOR NEXT ITERATION 14 BTR = X0 C USE THE PREVIOUS X POINT AS A NEW POINT TO BE USED IN EXTRAPOLATION C X( IFU ) = X( 3 ) FR( IFU ) = FR( 3 ) FRS( IFU ) = FRS( 3 ) FS( IFU ) = FS( 3 ) C CARRY OUT NEXT ITERATION (PHASE 2) GO TO 25 2 CONTINUE C CARRY OUT NEXT EVALUATION (PHASE 1) GO TO 12 C RECORD POSITION OF ZERO 10 SEARCH = BTR C CALCULATION OF WHETHER ADDITIONAL ZEROS ARE DESIRED C IF SO , THE LAST SEARCHED X VALUE OF THE INITIAL SEARCH BECOMES C THE NEW LOWER LIMIT FOR A COMPLETELY NEW SEARCH C 35 ZZ = SEARCH IF ( ZZ ) 8, 6, 8 C RECORD ZERO NUMBER (Z), VALUE OF FUNCTION (FF, WHICH SHOULD BE CLOSE C TO ZERO), AND UNCERTAINTY IN POSITION OF ZERO (P) 8 M = M + 1 Z( M ) = ZZ FF( M ) = FR( MFU ) P( M ) = H C RESET MINIMUM X FOR NEXT SEARCH BMIN = X( IFUN ) C BEGIN SEARCH FOR NEXT ZERO, IF REQUESTED IF ( M . LT . N ) GO TO 5 C COME HERE IF NO ZEROS HAVE BEEN FOUND 6 IF (M .EQ. 0) WRITE (NOUT,3) RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 1000 FORMAT(1H , 'ROOT NUMBER',I5, 'NOT ENOUGH ITERATIONS L=', I5 ) 3 FORMAT(1H , 'NO ZEROS FOUND ' ) END zli2a.f000644 000311 000121 00000010542 06067230367 012073 0ustar00krivecf1000000 000000 SUBROUTINE ZLI2A(F, A, B, ABSX, ABSF, ITCU, 1 IFAIL, LTEST, NOUT, F2, X2) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LTEST C C C FINDS A ZERO OF F(X) IN THE INTERVAL (A, B) BY A COMBINATION OF C REGULA FALSI AND SECANT C METHODS. NO CHECKS ARE DONE, THE FUNCTION MUST BE WELL BEHAVED. C HAS A FOOLPROOF STOPPING CRITERION: IT ITERATES AS LONG AS THE C SIGN-CHANGE INTERVAL IS DECREASING, ASSUMING THAT THE INCREASE C OF THE SIGN-CHANGE INTERVAL SIGNALS ONSET OF NOISE. C C SIGN-CHANGE INTERVAL IS UPDATED ON EACH STEP. C C THE INTERPOLATION METHOD IS THAT EACH TIME WHEN X2 IS CALCULATED C FROM X0 AND X1, THE NEXT STEP USES EITHER (X0, X2) OR (X1, X2), C WHICHEVER INTERVAL IS SMALLER. C IF X2 FALLS OUTSIDE THE LATEST SIGN-CHANGE INTERVAL, THE OTHER C PAIR IS USED. IN THIS CASE, IF THERE IS NOISE, X2 MIGHT STILL C FALL OUTSIDE - BUT THEN THE ROUTINE RETURNS. C C THIS ROUTINE CONVERGES MUCH FASTER ON SMOOTH FUNCTIONS THAN C ZLI1- WHICH ALWAYS USES THE SIGN-CHANGE INTERVAL AS THE NEXT C INTERVAL: FOR THE FUNCTION SQRT(X) - 1 IT FINDS THE ZERO TO C 10 DECIMAL PLACES IN 5 ITERATIONS WHILE ZLI1- NEEDS 12 ITERATIONS. C (ZEROD- BY M. HAFTEL ALSO NEEDS 5 ITERATIONS WHICH DIFFER C SLIGHTLY.) C C F - FUNCTION F(X). C A, B - INITIAL INTERVAL; F(A), F(B) MUST BE OF OPPOSITE C SIGNS. C ABSX - STOP IF X INTERVAL IS LESS THAN ABSX. C ABSF - STOP IF ABS(F(X)) IS LESS THAN ABSF. C IFAIL - 0: OK. C 2: F(A), F(B) HAVE THE SAME SIGN. C F2 - FUNCTION VALUE AT X2. C X2 - APPROXIMATION TO ZERO. C C CHARACTER*6 NAME DATA NAME / 'ZLI2A ' / CHARACTER*60 VERS DATA VERS */ ' 3.6, 92/11/26. O: ZLI1A 1.0, 92/03/02. ' / C ------------------------------------------------------------ C EXTERNAL F LOGICAL LCALL0, LINI DATA LCALL0 / .TRUE. /, ZERO, ONE / 0.D0, 1.D0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (ABS(B - A) .LT. CDXTOL()) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C C INITIALIZE. IFAIL = 0 X0 = A X1 = B F0 = F(X0) F1 = F(X1) IF ((SIGN(ONE, F0) * SIGN(ONE, F1)) .GT. ZERO) THEN CALL ERR2(NAME, 2, 0, NOUT) IFAIL = 2 RETURN ENDIF C C START INTERPOLATION. IF (LTEST) WRITE (NOUT,3000) NAME XL = MIN(X0, X1) XU = MAX(X0, X1) DNEW = ABS(XL - XU) LINI = .TRUE. ITC = 0 10 CONTINUE ITC = ITC + 1 C C STOP IF ALLOWED NUMBER OF ITERATIONS EXCEEDED. IF (ITC .GE. ITCU) RETURN C DOLD = DNEW C C INTERPOLATE. X2 = X1 - (X1 - X0) * F1 / (F1 - F0) C C CHECK THAT X2 IS IN (XL, XU); ELSE USE AUXILIARY INTERVAL. IF (X2 .LT. XL .OR. X2 .GT. XU) THEN IF (LINI) CALL ERR2(NAME, 3, 1, NOUT) X2 = X1A - (X1A - X0A) * F1A / (F1A - F0A) ENDIF C F2 = F(X2) IF (LTEST) WRITE (NOUT,3010) X0, X1, X2 IF (LINI) LINI = .FALSE. C C STOP IF F(X2) IS SMALL ENOUGH. IF (ABS(F2) .LT. ABSF) RETURN C C UPDATE SMALLEST INTERVAL ON WHICH FUNCTION CHANGES SIGN. IF ((SIGN(ONE, F2) * SIGN(ONE, F0)) .GT. ZERO) THEN XL = MIN(X1, X2) XU = MAX(X1, X2) ELSE XL = MIN(X0, X2) XU = MAX(X0, X2) ENDIF C C STOP IF INTERVAL HAS INCREASED OR IS SMALL ENOUGH. DNEW = ABS(XL - XU) IF ((DNEW .GT. DOLD) .OR. 1 (DNEW .LT. ABSX) ) RETURN C C INTERVAL FOR NEXT STEP (THE SMALLER ONE); AUXILIARY INTERVAL. IF (ABS(X0 - X2) .LT. ABS(X1 - X2)) THEN C NEXT (X0, X2); AUXILIARY (X2, X1). X0A = X2 X1A = X1 X1 = X2 F0A = F2 F1A = F1 F1 = F2 ELSE C NEXT (X2, X1); AUXILIARY (X0, X2). X0A = X0 X1A = X2 X0 = X2 F0A = F0 F1A = F2 F0 = F2 ENDIF GO TO 10 C 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-) 3010 FORMAT (1H , 12HX0, X1, X2 , 3E22.14) END zli3a.f000644 000311 000121 00000014634 06067230371 012075 0ustar00krivecf1000000 000000 SUBROUTINE ZLI3A(F, A, B, ABSX, ABSF, LXLAST, ITCU, 1 IFAIL, LTEST, NOUT, F3, X3, ITC) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL LXLAST, LTEST C C C FINDS A ZERO OF F(X) IN THE INTERVAL (A, B) BY A COMBINATION OF C INVERSE QUADRATIC, SECANT, AND BISECTION METHODS C (SIMILAR TO THE BRENT'S METHOD, SEE NUMERICAL RECIPES). C NO CHECKS ARE DONE, THE FUNCTION MUST BE WELL BEHAVED. C NOTES ON DEVELOPMENT: C V 1.*: HAS A FOOLPROOF STOPPING CRITERION: IT ITERATES AS LONG C AS THE SIGN-CHANGE INTERVAL IS DECREASING, ASSUMING THAT THE C INCREASE OF THE SIGN-CHANGE INTERVAL SIGNALS ONSET OF NOISE. C V 2.*: THE ABOVE CRITERION FAILED IN SOME CASES WITH PROGRAM C EWF2C BECAUSE THE QUADRATIC INTERPOLATION KEPT GIVING POINTS C ON THE LEFT OF THE ZERO (FUNCTION VALUE SIGN WAS CONSTANT) C FOR ABOUT SIX ITERATIONS, AND THE SIGN-CHANGE INTERVAL C REMAINED ESENTIALLY THE SAME, AS WITH THE REGULA FALSE. THIS C VERSION HAS AN OPTION TO STOP IF THE LAST TWO ITERATES C DIFFER BY LESS THAT ABSX (THIS IS DANGEROUS SINCE IT C IS NOT CONTROLLED BY THE SIGN-CHANGE CRITERION). C C F - FUNCTION F(X). C A, B - INITIAL INTERVAL; F(A), F(B) MUST BE OF OPPOSITE C SIGNS. C ABSX - STOP IF X INTERVAL IS LESS THAN ABSX. C ABSF - STOP IF ABS(F(X)) IS LESS THAN ABSF. C LXLAST - STOP IF LAST TWO ITERATES DIFFER BY LESS THAN ABSX. C ITCU - MAXIMUM NUMBER OF ITERATIONS. C IFAIL - 0: OK. C 2: F(A), F(B) HAVE THE SAME SIGN. C F3 - (OUTPUT) FUNCTION VALUE AT X3. C X3 - (OUTPUT) APPROXIMATION TO ZERO. C ITC - (OUTPUT) NUMBER OF ITERATIONS EXCLUDING THE INITIAL C TWO F EVALUATIONS. C C CHARACTER*6 NAME DATA NAME / 'ZLI3A ' / CHARACTER*60 VERS DATA VERS */ ' 2.2, 92/11/26 (ZLI2A 3.4) ' / C ------------------------------------------------------------ C EXTERNAL F LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, HALF / 0.D+0, 1.D+0, 0.5D+0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (ABS(B - A) .LT. CDXTOL()) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C C INITIALIZE, TEST FOR SIGN CHANGE. IF (LTEST) WRITE (NOUT,3000) NAME IFAIL = 0 X0 = A X1 = B F0 = F(X0) F1 = F(X1) IF (LTEST) WRITE (NOUT,3010) X0, X1, F0, F1 IF (SIGN(ONE, F0) * SIGN(ONE, F1) .GT. ZERO) THEN CALL ERR2(NAME, 2, 0, NOUT) IFAIL = 2 RETURN ENDIF XA = X0 XB = X1 FA = F0 C C LINEAR INTERPOLATION. ITC = 1 X2 = X1 - (X1 - X0) * F1 / (F1 - F0) F2 = F(X2) IF (ABS(F2) .LT. ABSF) RETURN IF (SIGN(ONE, F2) * SIGN(ONE, FA) .LT. ZERO) THEN XB = X2 ELSE XA = X2 FA = F2 ENDIF DOLD = ABS(XB - XA) FOLD = ABS(F2) IF (LTEST) WRITE (NOUT,3012) ITC, X2, F2 IF (LTEST) WRITE (NOUT,3020) ITC, XA, XB 10 CONTINUE ITC = ITC + 1 C C INTERPOLATION. IF (ABS(F0) .GT. CDXTOL() .AND. 1 ABS(F1) .GT. CDXTOL() ) THEN R = F2 / F1 S = F2 / F0 T = F0 / F1 P = S * (R - ONE) * (X2 - X0) + R * (R - T) * (X1 - X2) Q = (R - ONE) * (S - ONE) * (T - ONE) IF (ABS(P) .LT. ABS(Q * DOLD)) THEN C INVERSE QUADRATIC. X3 = X2 + P / Q IF (LTEST) WRITE (NOUT,3030) ITC, X3 IF ((X3 - XA) * (X3 - XB) .LT. ZERO) GO TO 12 ELSE IF (LTEST) WRITE (NOUT,3130) ITC, P, Q ENDIF ENDIF C SECANT METHOD. IF (ABS(F2 - F1) .GT. CDXTOL()) THEN X3 = X2 - (X2 - X1) * F2 / (F2 - F1) IF (LTEST) WRITE (NOUT,3032) ITC, X3 IF ((X3 - XA) * (X3 - XB) .LT. ZERO) GO TO 12 ENDIF C BISECTION. X3 = HALF * (XA + XB) IF (LTEST) WRITE (NOUT,3034) ITC, X3 12 CONTINUE C C X3 FOUND. UPDATE XA, XB. F3 = F(X3) IF (LTEST) WRITE (NOUT,3040) ITC, X1, X2, X3, F1, F2, F3 IF (SIGN(ONE, F3) * SIGN(ONE, FA) .LT. ZERO) THEN XB = X3 ELSE XA = X3 FA = F3 ENDIF IF (LTEST) WRITE (NOUT,3020) ITC, XA, XB C C STOP IF F(X3) IS SMALL ENOUGH. IF (ABS(F3) .LT. ABSF) RETURN C C STOP IF INTERVAL IS SMALL ENOUGH. DL = ABS(XB - XA) IF (DL .LT. ABSX) RETURN C C STOP IF THE FUNCTION VALUE HAS INCREASED FROM C THE PREVIOUS ITERATION (NOISE). FL = ABS(F3) IF (FL .GT. FOLD) THEN C KEEP THE PREVIOUS ITERATE. WRITE (NOUT,4000) ITC, X3, F3 X3 = X2 F3 = F2 WRITE (NOUT,4010) ITC, X3, F3 RETURN ENDIF C C STOP IF INTERVAL HAS INCREASED (STOP IN THE CASE C OF NOISE IN BISECTION OR TOO SMALL ABSX). IF (DL .GE. DOLD) RETURN C C STOP IF LAST TWO ITERATES DIFFER LITTLE ENOUGH (DANGEROUS). IF (LXLAST .AND. (ABS(X3 - X2) .LT. ABSX)) RETURN C C UPDATE. X0 = X1 X1 = X2 X2 = X3 F0 = F1 F1 = F2 F2 = F3 DOLD = DL FOLD = FL IF (ITC .EQ. ITCU) RETURN GO TO 10 C 2000 FORMAT (2H -, A6, 1H-, A60) 3000 FORMAT (2H -, A6, 1H-, 12HTEST OUTPUT ) 3010 FORMAT (/, 1H , 4X, 2E24.16, /, 1H , 4X, 2E24.16) 3012 FORMAT (1H , I4, 2(24X), E24.16, /, 1H , 4X, 2(24X), E24.16) 3020 FORMAT (1H , I4, 2E24.16) 3030 FORMAT (/, 1H , I4, 24H INVERSE QUADRATIC , 24X, E24.16) 3130 FORMAT (/, 1H , I4, 24H INVERSE QUADRATIC , 2E12.4) 3032 FORMAT ( 1H , I4, 24H SECANT , 24X, E24.16) 3034 FORMAT ( 1H , I4, 24H BISECTION , 24X, E24.16) 3040 FORMAT (1H , I4, 3E24.16, /, 1H , 4X, 3E24.16) 4000 FORMAT ( 1H , I4, 24H X3, IGNORED (F INC.), 24X, E24.16, /, 1 1H , 4X, 24H F3, IGNORED , 24X, E24.16) 4010 FORMAT ( 1H , I4, 24H X3, PREVIOUS, KEPT , 24X, E24.16, /, 1 1H , 4X, 24H F3, PREVIOUS , 24X, E24.16) END = MIN(X0, X1) XU = MAX(X0, X1) DNEW = ABS(XL - XU) LINI = .TRUE. ITC = 0 10 CONTINUE ITC = ITC + 1 C C STOP IF ALLOWED NUMBER OF ITERATIONS EXCEEDED. IF (ITC .GE. ITCU) RETURN C DOLD = DNEW C C INTERPOLATE. X2 = X1 - (X1 - X0) * F1 / (F1 - F0) C C CHECK THAT X2 IS IN (XL, XU); ELSE USE AUXILIARY INTERVAL. IF (X2 .LT. XL .OR. X2 .GT. XU) THEN IF (LINI) CALL ERR2(NAME, 3, 1, NOUT) X2 = X1A - (X1A - X0A) * F1A / (F1A - F0A) ENDIF C F2 = F(X2) IF (LTEST) WRITE (NOUT,3010) X0, X1, X2 IF (LINI) LINI = .FALSE. C C STOP IF F(X2) IS SMALL ENOUGH. IF (ABS(F2) .LT. ABSF) RETURN C C UPDATE SMALLEST INTERVAL ON WHICH FUNCTION CHANGES SIGN. IF ((SIGN(ONE, F2) * SIGN(ONE, F0)) .GT. ZERO) THEN XL = MIN(X1, X2) XU = MAX(X1, X2) ELSE XL = MIN(X0, X2) XU = MAX(X0, X2) ENDIF C C STOP IF INTERVAL HAS INCREASED OR IS SMALL ENOUGH. DNEW = ABS(XL - XU) IF ((DNEW .GT. DOLD) .OR. 1 (DNEW .LT. ABSX) ) RETURN C C INTERVAL FOR NEXT STEP (THE SMALLER ONE); AUXILIARY INTERVAL. IF (ABS(X0 - X2) .LT. ABS(X1 - X2)) THEN C NEXT (X0, X2); AUXILIARY (X2, X1). X0A = X2 X1A = X1 X1 = X2 F0A = F2 F1A = F1 F1 = F2 m2mk001.csh000755 000311 000121 00000000573 06030244130 012456 0ustar00krivecf1000000 000000 # m2mk001.c # To be sourced setenv FOR001 $di/$pe$fi.i set fo = $pe$fo setenv FOR002 $do/$fo.2ff setenv FOR003 $ds/$fo.3uu setenv ZZZLOG $do/$fo.log setenv ZZZEXE $de/$pe.$fe touch $ZZZLOG date >> $ZZZLOG echo $FOR002 >> $ZZZLOG echo $ZZZEXE >> $ZZZLOG $de/$pe.$fe date >> $ZZZLOG unsetenv FOR001 unsetenv FOR002 unsetenv FOR003 unsetenv ZZZLOG unsetenv ZZZEXE m2mk1a.csh000644 000311 000121 00000000355 06070006557 012467 0ustar00krivecf1000000 000000 # m2m- set de = "$cwd/../pro" set di = "$cwd" set do = "$cwd/../out" set ds = "$cwd/../out" set pe = "m2mk" set fe = "e40p0_ol_O2" set fi = "1a" set fo = "1aa4001" source $di/${pe}001.csh # ----------------------- m2mk1a.i000644 000311 000121 00000003051 06030244130 012121 0ustar00krivecf1000000 000000 95/09/21 He bm_a T LSTORE (UNFORMATTED OUTPUT) 1 INUSEL (0: UNSYMMETRIC; 1: SYMMETRIC) TT PCFC, PVC (PRINT F, V POWER EXPANSIONS) 1.0 1.0 -1.0 M1/2/3 (-1: INF) 20 0 F MUU, IPOS, PSYM 1 1 -1 -1 0 IPFL, IPFU, IPVL, IPVU, IPWU 1 NFPAR 1 -2.0 -2.0 1.0 J, FPAR(.,J) 2 MODF (INTERPRETATION OF FPAR BY CFC...) 1 NVPAR 1 -2.0 -2.0 1.0 J, VPAR(.,J) 0 MODV (INTERPRETATION OF VPAR BY VC...) 16 16 (NGOA(I), I = 1,2) 4 4 (NSUBA(I), I = 1,2) 16 16 16 16 16 16 16 16 16 16 (NGOL(I,1), I = 1,10) 4 4 4 4 4 4 4 4 4 4 (NSUBL(I,1), I = 1,10) 16 16 16 16 16 16 16 16 16 16 (NGOL(I,2), I = 1,10) 4 4 4 4 4 4 4 4 4 4 (NSUBL(I,2), I = 1,10) 0.100 0.030 DAS, DLS TT POMEGA, POTHER (WORKING RUNS: TT) TFFFF PCON, PTEST, PTEST1, PRES (WORKING RUNS: TFFF), PCONTR FFFFFFF PT0O, PT1O, PRESO, PTG, PTGA, PTGL, PTJ (WRKNG RUNS: F...F) 4 NSPR (MAX. NO. ROWS/COLUMS OF MATRICES TO BE PRINTED) m2mk_pack.tar000644 000311 000121 00000550000 06070001716 013241 0ustar00krivecf1000000 000000 m2mk.f000644 000311 000121 00000040003 06070001032 011666 0ustar00krivecf1000000 000000 PROGRAM M2MK C IMPLICIT REAL*8 (A - H, O - Z) C C C C C MATRIX ELEMENTS AS MATRIX COEFFICIENTS OF A POWER SERIES, C FOR ANY SET OF POWERS (.GE. -2) AND ANY COEFFICIENTS OF C THE CORRELATION FUNCTION F AND POTENTIAL V. C C CALLS M2OF- TO CALCULATE THE HH EXPANSION OF -OMEGA(F) C NUMERICALLY, AND M2- TO CALCULATE ALL MATRIX ELEMENTS, C USING THE M2OF- EXPANSION FOR THE -OMEGA(F) OPERATOR. C C GAUSSIAN INTEGRATION ABSCISSAS AND WEIGHTS ARE CALCULATED C IN EXTENDED PRECISION. C STREAMLINED M2OFQC IS USED. C C C AUTHOR: R. KRIVEC, J. STEFAN INSTITUTE, LJUBLJANA. C C C RESTRICTIONS: C C 1. L = 0. C C 2. FORM OF THE CORRELATION FUNCTIONS: THIS IS CONTROLLED C BY INPUT PARAMETERS READ IN BY M1PIO- ; THESE C PARAMETERS ARE USED BY ROUTINES NAMED CFC--- CALLED C BY M1PIO- , EACH ROUTINE INTERPRETING THE INPUT C PARAMETERS IN A DIFFERENT WAY (AS CONSTANTS WHICH C APPEAR AT CERTAIN PLACES IN THE FUNCTIONAL FORM OF THE C CORRELATION FUNCTION). THE CFC--- ROUTINES THEN C CALCULATE THE POWER SERIES FROM THESE FUNCTIONAL FORMS, C UP TO A MAXIMUM POWER IF THE SERIES IS INFINITE. C THE FORMS OF THE CORRELATION FUNCTIONS ARE RESTRICTED C BY THE SET OF THE CFC--- ROUTINES INCLUDED IN THE C PACKAGE. C C 3. FORM OF POTENTIAL V: ROUTINES VC--- (SEE ABOVE). C C C C C INPUT PARAMETERS C ((I) integer, (L) logical, (R) real, (A) Hollerith.) C C C ITITLE (A) Any text (80 characters). C C LSTORE (L) Unformatted output if .TRUE.. C C INUSEL Contract the final matrices before storage. C 0: full, 1: nu .ge. 0 only, -1: nu .lt. 0 only. C This parameter originates from COULDS and is C introduced here to save output space for C symmetric systems, as well as input array space C in COULD- (91/12/02). C **** INUSEL is not tested for consistency **** C C PCFC Print correlation function power series. C C PVC Print potential power series. C C XMASS1, -2, -3 Masses (R); a negative value is C transformed to a very large value (XINF, C DATA statement below). C C MUU Maximum MU = K / 2. C C IPOS * Ignored * C C PSYM * Ignored * C C IPFL, IPFU The smallest and the largest powers of rho C in the correlation function f power expansion. C 1, 1 for cusp parametrization; otherwise, C IPFU acts as a powers series cutoff. C C IPVL, IPVU The smallest and the largest powers of rho C in the potential V power (MacLaurin) expansion. C C IPWU The largest power in the effective potential C W for which the matrix elements are to be C calculated. Note that if f has an infinite C powers series, the sensible choice is C IPWU = IPFU - 2 because higher powers in W C are affected by the cutoff IPFU. But there C is no explicit connection between the two C in the program. C C NFPAR Number of triples of parameters of f; for C example, the form f = -(a + b exp(cr))r C requires NFPAR = 3 (for a, b, c triples). C C FPAR The values of f parameters; in the above C example, one line contains a(23), a(31), a(12) C in that order, etc. C C MODF Determines which subroutine is called to C calculate the power expansion of f, using C the array FPAR; therefore the interpretation C of FPAR depends on the routine. See the C parameter I/O routine (M1PI--) for the available C expansion routines. C C NVPAR Number of triples of parameters of V. C C VPAR V parameters, similar to FPAR. C C MODV Similar to MODV. C C NGOA Order of Gaussian integration in the variable C a, per subinterval in the 2 basic a-regions. C C NSUBA Number of subintervals in the basic 2 C a-regions. C C NGOL Order of Gaussian integration in the variable C lambda, per subinterval in the basic 10 C lambda-regions. Only the first C subarray is used. C C NSUBL Number of subintervals in the basic 10 C lambda-regions. Only the first subarray C is used. C C DAS, DLS Widths of the a- and lambda-regions C which border on the singularities. C C POMEGA (L) Calculate the omega(f) HH expansion if C .TRUE. (as it must be for working runs). C C POTHER (L) Calculate all the other expansions as well C as the final matrix elements if .TRUE. C (as it must be for working runs). C C PCON (L) Print certain basic constants (kappa etc.). C C PTEST, ... (L) See the input file. Normally .FALSE.; C used for test outputs from various routines; C most routines have such parameters; as these C parameters have no unnecessary appearances, C it is easy to follow them through. C C NSPR Number of rows/columns of the W matrix to C be printed for each power. C C C C C I/O PARAMETERS: C NIN INPUT LOGICAL UNIT NO. C ALL INITIAL INPUT IS FROM THIS UNIT AND IS READ IN C BY THE SUBROUTINE M1PIO- AND THIS PROGRAM. C NOUT PRINTED OUTPUT LOGICAL UNIT NO. C NOUT1 UNFORMATTED OUTPUT LOGICAL UNIT NO. C C DIMENSIONS: C SEE SUBROUTINE M2- FOR EXPLANATION OF DIMENSIONS. C DIMENSIONS ARE ALL DECLARED IN THIS PROGRAM. C C C MISCELLANEOUS NOTES C BASIC NOTATION: C PREFIXES: C ND- NDVAR DIMENSION OF VAR C AFFIXES: C -L VARL MIN. VALUE OF VAR ("LOWER") C -U VARU MAX. VALUE OF VAR ("UPPER") C ERRORS: C AT ERROR TESTS, THE ROUTINE ERR- IS CALLED TO C OUTPUT ROUTINE NAME AND ERROR NUMBER. ERRORS ARE EITHER C FATAL (AND STOP THE PROGRAM) OR NONFATAL (A WARNING IS C PRINTED). C OVERFLOWS: C ALMOST SURELY WILL NOT OCCUR (MOST OF THE C BIG NUMERS ARE IN LOGARITHMIC SCALE OR AS ROOTS). C FOR EXAMPLE, NO OVERFLOW CAN OCCUR IN THE GAMMA FUNCTION C OR CLEBSCH-GORDAN COEEFICIENT PROGRAMS. C MACHINE DEPENDENT CONSTANTS (SMALLEST REPRESENTABLE REAL, C ETC.): ARE SUPPLIED BY ROUTINES NAMED CDX... (MODIFY C THESE IF WORKING ON A DIFFERENT MACHINE). C C C C C PARAMETER STATEMENTS. C ===================== C C EXAMPLE: COULOMB POTENTIAL, LINEAR F: NDP0 AT LEAST 3 C (FOR POWERS (-1, 0, 1)); NDP AT LEAST 2 (FOR POWERS -1, 0). C FOR OTHER CASES SEE M2- COMMENT (M2- WILL STOP IF ANY C DIMENSIONS ARE TOO SMALL). C PARAMETER (NIN = 1, NOUT = 2, NOUT1 = 3, NIN1 = 0) PARAMETER (NDFPAR = 5, NDVPAR = 3, NDP0 = 3, NDP = 2) PARAMETER (NDMU = 21) PARAMETER (NDGO = 16, NNQSI = 8) C C C DERIVED PARAMETERS (NEVER CHANGE THESE STATEMENTS). C NDG, FOR SIMPLICITY, IS SLIGHTLY TOO LARGE (EXCEPT IF ALL C POWERS ARE POSITIVE). C C FOR M2-. PARAMETER (NDMUT = 2 * NDMU - 1, NDFACT = 4 * (NDMU-1)/2 + 2) PARAMETER (NDS = NDMU * (NDMU + 1) / 2, 1 NDST = NDMUT * (NDMUT + 1) / 2, 2 NDAMN = NDMUT * (NDMUT + 1) / 2, 3 NDG = NDMUT + (NDP0 + 1) / 2 + 3) C C FOR M2OF-. C NNQSI IS NOT A DIMENSION (MAX. NO. SUBDIVISIONS), C BUT IS USED TO CALCULATE DIMENSIONS. C THE FORMULA FOR NDSJ IS THE SAME AS ((NDMUT - 1)/2 + 1)**2. PARAMETER (NDSJ = (NDMUT - 1) * (NDMUT + 3) / 4 + 1, 1 NDPJ = (NDMUT - 1) / 2 + 1) PARAMETER (NDGO1 = NDGO + 1, 1 NDGO2 = (NDGO + 1) / 2, 2 NDGO1Z = NDGO / 2 + 2, 3 NDQSI = NDGO * NNQSI, 4 NDQA = 2 * NDGO * NNQSI, 5 NDQL = 10 * NDGO * NNQSI) C C FOR M1PIO-. PARAMETER (NDWK = NDVPAR / 2) C C C DECLARATIONS. C ============= C C GENERAL LOGICAL PCPU, PCON, PCFC, PVC, PSYM, PTEST, PTEST1, PRES, 1 PCONTR, POMEGA, POTHER, LSTORE DIMENSION ITITLE(20) C C INPUT COEFFICIENTS ETC. DIMENSION FPAR(3,NDFPAR), VPAR(3,NDVPAR), WK(3,NDWK), 1 F(3,NDP0), V(3,NDP0), XOMEGA(3), XKAPPA(3), 2 FANA(3,3) C C STATES DIMENSION ISMN(2,NDS), ISIS(NDMU,NDMU), ISN(2,NDMU), 1 ISMNT(2,NDST), ISIST(NDMUT,NDMUT), ISNT(2,NDMUT) C C GAMMA FUNCTIONS DIMENSION GNL(NDG), GN2L(NDG), FACT(NDFACT) C C CLEBSCH-GORDAN AND RELATED COEFFICIENTS DIMENSION GAMMA(NDS,NDS), ZETA(NDS,NDS), AMN(3,NDAMN) C C HH EXPANSION COEFFICIENTS DIMENSION CF(NDMUT,NDP0,2), CV(NDMUT,NDP0,2), TT(NDP0) C C MATRIX ELEMENTS DIMENSION EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP), ICONTR(NDS) C C SUBROUTINE M2OF- LOGICAL PT0O, PT1O, PRESO, PTG, PTGA, PTGL, PTJ DIMENSION NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2), 1 ISMNJ(2,NDSJ), ISISJ(NDMUT,NDMUT), ISNJ(2,NDMUT), 2 ZFA(NDQA,4), ZFL(NDQL,6), AUX(3,NDP0), 3 YAX(NDQA,NDSJ), YLX(NDQL,NDMUT,2), PJ(NDQA,NDPJ), 4 AG1(NDGO), WG1(NDGO), 5 QA(NDSJ,NDP), XSI(NDQSI), WSI(NDQSI), 6 XA(NDQA), WA(NDQA), XL(NDQL,2), WL(NDQL,2), 7 CDF2R(NDMUT,NDP,NDMUT), CDF2I(NDMUT,NDP,NDMUT) C ************ REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************ C C CHARACTER*6 NAME CHARACTER*60 VERS DATA NAME / 'M2MK ' /, VERS */ ' 3.0, 95/12/24 CORRECTED ZFA DIMENSION ' / C ------------------------------------------------------------ DATA PCPU / .TRUE. / C C C INITIALIZE. C =========== C C WRITE (NOUT,2000) NAME, VERS CPU0 = 0.0 CALL TEMPD(CPU0, CPU1, CPUD, NOUT, .FALSE.) DO 22 J = 1,NDP0 DO 20 I = 1,3 F(I,J) = 0.D0 V(I,J) = 0.D0 20 CONTINUE 22 CONTINUE XINF = 0.01D0 * CDXMAX() C C C INPUT. C ====== C C TITLE CARD (ANY TEXT, 80 CHARACTERS). C C READ (NIN,1000) ITITLE WRITE (NOUT,2010) ITITLE C C C UNFORMATTED STORE. C C READ (NIN,1020) LSTORE WRITE (NOUT,2012) LSTORE C C C CONTRACTION BEFORE UNFORMATTED STORE. C C READ (NIN,1010) INUSEL WRITE (NOUT,2013) INUSEL C C C PRINT F POWER EXPANSION BY CFC.... C C READ (NIN,1020) PCFC, PVC WRITE (NOUT,2014) PCFC, PVC C C C MODE FOR PARAMETER I/O (SUBROUTINE M1PIO- ). MODE1 = 1 IF (LSTORE) MODE1 = 2 C C C PARAMETERS ( IPOS , PSYM IGNORED). C C CALL M1PIOH(NIN, NOUT, NIN1, NOUT1, MODE1, PCFC, PVC, 1 NDFPAR, NDVPAR, NDP0, NDWK, 2 XMASS1, XMASS2, XMASS3, XINF, 3 MUU, IPOS, PSYM, 4 IPFL, IPFU, IPVL, IPVU, IPWU, 5 FPAR, MODF, F, FANA, VPAR, MODV, V, WK, 6 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 7 IP0OFF, IP0XU, IPOFF, IPXU) C C C CONTROL PARAMETERS. C POMEGA: CALL M2OF- . C POTHER: CALL M2- . C NSPR: NUMBER OF ROWS/COLUMNS TO BE PRINTED BY M1MIO- . C C READ (NIN,1020) POMEGA, POTHER WRITE (NOUT,2114) POMEGA, POTHER C C READ (NIN,1020) PCON, PTEST, PTEST1, PRES, PCONTR WRITE (NOUT,2110) PCON, PTEST, PTEST1, PRES, PCONTR C C READ (NIN,1020) PT0O, PT1O, PRESO, PTG, PTGA, PTGL, PTJ WRITE (NOUT,2112) PT0O, PT1O, PRESO, PTG, PTGA, PTGL, PTJ C C READ (NIN,1010) NSPR WRITE (NOUT,2116) NSPR C C C CHECK. C ====== C C IF (LSTORE .AND. (.NOT.(POMEGA .AND. POTHER))) 2 CALL ERR2(NAME, 1, 0, NOUT) CALL CDXFBO(NOUT) C C C CONSTANTS. C ========== C C CALL M1CD(XMASS1, XMASS2, XMASS3, 1 NOUT, 2 XKAPPA, XOMEGA) IF (PCON) WRITE (NOUT,3000) XINF, XKAPPA, XOMEGA NFACT = 4 * MUU / 2 + 2 IF (NFACT .GT. NDFACT) CALL ERR2(NAME, 2, 1, NOUT) CALL TEMPD(CPU1, CPU2, CPUD, NOUT, PCPU) C C C MATRIX ELEMENTS. C ================ C C C HH EXPANSION OF -OMEGA(F), NUMERICALLY. MUJ = 2 * MUU IF (POMEGA) A CALL M2OFQC(NDP0, NDP, NDMUT, NDSJ, NDPJ, NDQA, NDQL, 1 NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 2 IP0OFF, IPFL, IPFU, IPVL, IPVU, MUJ, 3 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 4 XKAPPA, XOMEGA, F, IPXU, IPOFF, 5 NOUT, PT0O, PT1O, PRESO, PTG, PTGA, PTGL, PTJ, 6 ISMNJ, ISISJ, ISNJ, ZFA, ZFL, AUX, 7 YAX, YLX, PJ, P, Z, AG, WG, AG1, WG1, 8 QA, XSI, WSI, NQA, XA, WA, NQL, XL, WL, 9 NSJ, CDF2R, CDF2I) CALL TEMPD(CPU2, CPU3, CPUD, NOUT, PCPU) C C IF (POTHER) 1 CALL M2B(NDP0, NDP, NDMU, NDMUT, NDS, NDST, A NDG, NDFACT, NDAMN, B IPFL, IPFU, IPVL, IPVU, F, V, C IP0OFF, IP0XU, IPOFF, IPXU, D MUU, XOMEGA, XKAPPA, MUJ, CDF2R, CDF2I, E ISMN, ISIS, ISN, F ISMNT, ISIST, ISNT, G GNL, GN2L, FACT, GAMMA, ZETA, AMN, H CF, CV, TT, I NOUT, PTEST, PTEST1, PRES, J NS, EMW, EMWD) CALL TEMPD(CPU3, CPU4, CPUD, NOUT, PCPU) C C C OUTPUT. C ======= C C C OPTIONAL CONTRACTION BEFORE OUTPUT. C **** CHANGES ISMN, EMW, EMWD. **** C **** NSX IS THE NEW NUMBER OF STATES. **** CALL M2WRDA(NDS, NDP, 1 NOUT, PCONTR, 2 IPXU, NS, INUSEL, ICONTR, 3 NSX, ISMN, EMW, EMWD) C C IF (MODE1 .EQ. 1) MODE2 = 1 IF (MODE1 .EQ. 2) MODE2 = 2 CALL M1MIOF(MODE2, NIN1, NOUT, NOUT1, 1 NDP, NDS, NSPR, 2 XOMEGA, XKAPPA, 3 IPOFF, IPXU, INUSEL, 4 MUU, NSX, ISMN, EMW, EMWD) CALL TEMPD(CPU4, CPU5, CPUD, NOUT, PCPU) CALL TEMPD(CPU1, CPUT, CPUD, NOUT, PCPU) C C 1000 FORMAT (20A4) 1010 FORMAT (20I4) 1020 FORMAT (20L1) C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2010 FORMAT (//, A 1H , 20A4, //) 2012 FORMAT (//, A 1H , 32HLSTORE , L4) 2013 FORMAT (//, A 1H , 32HINUSEL , I4) 2014 FORMAT (//, A 1H , 32HPCFC, PVC , 2L4, //) 2110 FORMAT (/, A 1H , 32HPCON, PTEST, PTEST1, PRES,PCONTR, 5L4) 2112 FORMAT ( A 1H , 32HPT0O/1O,PRESO,PTG,PTGA,PTGL,PTJ , 7L4) 2114 FORMAT (//, A 1H , 32HPOMEGA, POTHER , 2L4) 2116 FORMAT (//, A 1H , 32HNSPR , I4, //) 3000 FORMAT (//, A 1H , 16HXINF , D12.4, /, B 1H , 16HXKAPPA , 3F16.8, /, C 1H , 16HXOMEGA , 3F16.8) END cdxeps.f000644 000311 000121 00000000557 05306654433 012344 0ustar00krivecf1000000 000000 FUNCTION CDXEPS() REAL * 8 CDXEPS C C ** MACHINE DEPENDENT ** C EPS (SMALLEST REAL * 8 NUMBER SUCH THAT (1.D0 + EPS) .GT. 1.D0). C C* CDXEPS = 2.D0 ** (-52) C* IBM C* CDXEPS = 2.D0 ** (-56) C* VAX CDXEPS = 2.D0 ** (-52) C* CONVEX C220 RETURN END cdxfbo.f000644 000311 000121 00000000313 05307356415 012311 0ustar00krivecf1000000 000000 SUBROUTINE CDXFBO(NOUT) C C ** MACHINE DEPENDENT ** C FLUSHES BUFFER CONTENTS ON UNIT NOUT TO OUTPUT FILE. C CALL FLUSH(NOUT) C* CONVEX C220 RETURN END cdxmax.f000644 000311 000121 00000000437 05306654640 012337 0ustar00krivecf1000000 000000 FUNCTION CDXMAX() REAL * 8 CDXMAX C C ** MACHINE DEPENDENT ** C MAXIMUM REAL * 8 NUMBER REPRESENTABLE. C C* CDXMAX = 2.D0 ** (+251) C* IBM CDXMAX = 2.D0 ** (+1022) C* CONVEX C220 RETURN END cdxpi.f000644 000311 000121 00000000155 05305157757 012165 0ustar00krivecf1000000 000000 FUNCTION CDXPI() REAL * 8 CDXPI CDXPI = 3.14159265358979323846D00 RETURN END cdxtol.f000644 000311 000121 00000000537 05306654743 012355 0ustar00krivecf1000000 000000 FUNCTION CDXTOL() REAL * 8 CDXTOL C C ** MACHINE DEPENDENT ** C TOL (SMALLEST REPRESENATBLE REAL * 8 NUMBER). C CDXTOL = 2.D0 ** (-1024) C* C220 C* CDXTOL = 2.D0 ** (-126) C* VAX C* CDXTOL = 2.D0 ** (-260) C* IBM RETURN END cfc000.f000644 000311 000121 00000003074 06067231550 012022 0ustar00krivecf1000000 000000 SUBROUTINE CFC000(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), F(3,NDP0), FANA(3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC000' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 F(I,IP0X) = -ALPHA(I) FANA(I) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 2.1, 95/12/24. 2.0, 92/05/22. (1.1) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc001.f000644 000311 000121 00000004214 06067231703 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ALPHA(3), BETA(3), GAMMA(3), F(3,NDP0), 1 FANA(3,3) C C C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) C -( ALPHA(I) + BETA(I)*EXP(-GAMMA(I)*R(I)) ) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C C C LOGICAL LCALL0 DIMENSION W(3) CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC001' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -(ALPHA(I) + BETA(I)) FANA(I,1) = -ALPHA(I) FANA(I,2) = -BETA(I) FANA(I,3) = GAMMA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 1) RETURN C C C FURTHER POWERS. DO 30 IP0 = 2,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * GAMMA(I) / DFLOAT(IP0 - 1) F(I,IP0X) = -BETA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 3.1, 95/12/24. 3.0, 92/05/22. (2.2) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc002.f000644 000311 000121 00000004452 06067232004 012020 0ustar00krivecf1000000 000000 SUBROUTINE CFC002(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, ZZ, F, FANA) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL LPR DIMENSION ZZ(3), F(3,NDP0), FANA(3) C C C C C CUSP COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * R(I) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1 (ABORTING IF IPFL .NE. 1, IPFU .NE. 1). C INPUT ARE MASSES AND PRODUCTS OF CHARGES (ZZ) (THIS IS C NECESSARY, FOR EXAMPLE, IF SOME PAIR INTERACTION IS TO BE PUT C TO ZERO; THEN THE CORRELATION PARAMETER IS ZERO, TOO; C THIS WOULD NOT BE POSSIBLE IF THE CHARGES THEMSELVES WERE C INPUT). C THIS PROGRAM CALCULATES CUSP COEFFICIENTS TO FULL PRECISION, C WHICH IS BETTER THAN IF THE MAIN PROGRAM WOULD READ THEM IN C AND CALL CFC000. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'CFC002' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .NE. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .NE. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 1 IP0X = IP0 + IP0OFF C IF (XM1 .LT. 0.D0) CALL ERR2(NAME, 4, 1, NOUT) IF (XM2 .LT. 0.D0) CALL ERR2(NAME, 5, 1, NOUT) IF (XM3 .LT. 0.D0) CALL ERR2(NAME, 6, 1, NOUT) C F(1,IP0X) = ZZ(1) * XM2 * XM3 / (XM2 + XM3) F(2,IP0X) = ZZ(2) * XM3 * XM1 / (XM3 + XM1) F(3,IP0X) = ZZ(3) * XM1 * XM2 / (XM1 + XM2) FANA(1) = F(1,IP0X) FANA(2) = F(2,IP0X) FANA(3) = F(3,IP0X) C IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 5.1, 95/12/24. 5.0, 92/05/22. (4.0) ) C ======================================== 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc003.f000644 000311 000121 00000004037 06067230136 012024 0ustar00krivecf1000000 000000 SUBROUTINE CFC003(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, F) IMPLICIT REAL*8 (A - H, O - Z) LOGICAL LPR DIMENSION ALPHA(3), BETA(3), F(3,NDP0) C C C R(I) POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C F = SUM(I=1...3) -ALPHA(I) * EXP(-BETA(I) * R(I)), C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 0,..., IPFU (ABORTING IF IPFL .GT. 0). C C CHARACTER*6 NAME DATA NAME / 'CFC003' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 91/05/11. O: CFC001 2.2, 91/01/16. ' / C ------------------------------------------------------------ C C LOGICAL LCALL0 DIMENSION W(3) DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPFL .GT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) C C C FIRST POWER, INITIALIZE W. IF (LPR) WRITE (NOUT,4000) IPFL, IPFU IP0 = 0 IP0X = IP0 + IP0OFF DO 10 I = 1,3 W(I) = 1.D0 F(I,IP0X) = -ALPHA(I) 10 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) IF (IPFU .EQ. 0) RETURN C C C FURTHER POWERS. DO 30 IP0 = 1,IPFU IP0X = IP0 + IP0OFF DO 20 I = 1,3 W(I) = -W(I) * BETA(I) / DFLOAT(IP0) F(I,IP0X) = -ALPHA(I) * W(I) 20 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (F(I,IP0X), I = 1,3) 30 CONTINUE RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H F POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPFL, IPFU , 2I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END cfc004.f000644 000311 000121 00000014105 06067230137 012023 0ustar00krivecf1000000 000000 SUBROUTINE CFC004(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XE, XA, XR, XN, 3 D1, D2, D, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XE(3), XA(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE. C XE(1-3) = (E1, E2, C). E1: BINDING ENERGY OF PARTICLE 1,...; C C: ASYMPTOTIC CONSTANT IN PHI = EXP(C * RHO) FOR C THE CFHHM SMOOTH HH-EXPANED PART OF W.F. C DEPENDS C ON THE CORREL. FUNCTION AND CAN ONLY BE OBTAINED A C POSTERIORI FROM THE MATRIX ELEMENTS OF THE C EFFECTIVE POTENTIAL W, CALCULATED FROM THE OUTPUT C OF THIS ROUTINE. ONE WAY TO DO IT IS TO SEE IF C THE SAME C IS OBTAINED AS WAS INPUT TO THIS C ROUTINE, AND THUS ACHIEVE SELF-CONSISTENCY. C C CAN ALSO BE PUT TO 0, IN WHICH CASE THE C OUTPUT OF THIS ROUTINE WILL BE AS IN THE CASE C OF E+E-E- (C WAS NOT TAKEN INTO ACCOUNT). C XA(1-3) VALUES OF PARAMETERS A(I). A3 IS A FREE PARAMETER, C AND XA(1), XA(2) ARE IGNORED (RESERVED FOR FUTURE C USE). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C A(I) = (A1, A2, A3); C B(I) = (B1, B2, B3); C C(I) = (C1, C2, C3); C D1, D2, D, C WHERE C A3 = XA(3) C A1 = - ROOT(2 M2 E2) - C ROOT(M2) - A3, C A2 = - ROOT(2 M1 E1) - C ROOT(M1) - A3, C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3), C D1 = A1 + A2, D2 = ROOT(M3), C D = D1 + C D2 C (D SHOULD BE NEGATIVE IF THE TRUE C IS INPUT; IF C = 0, D MAKES C NO SENSE; D ONLY SERVES AS A CHECK; HOWEVER, FROM D1 AND D2, C THE VALUE OF D WITH C FROM THE KM = 0 EQUATION USING THE C MATRIX ELEMENTS OUTPUT FROM THIS PROGRAM, CAN BE CALCULATED). C HERE M1 IS THE REDUCED MASS OF THE PARTICLE 1 WITH RESPECT TO C THE PAIR (2,3), ETC. C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION XM(3), A(3), ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC004' / CHARACTER*60 VERS DATA VERS */ ' 2.2, 92/11/26. (1.2) ' / C ------------------------------------------------------------ C DATA ZERO, ONE, TWO / 0.D0, 1.D0, 2.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XE, XA, XR, XN ENDIF C C CALCULATE B AND A, AND D. C RESULT (B) TEMPORARILY IN F(.,1+IP0OFF). XM(1) = XM1 XM(2) = XM2 XM(3) = XM3 IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM(1), XM(2), XM(3), XZ, F, FANA) XMM1 = XM(1) * (XM(2) + XM(3)) / (XM(1) + XM(2) + XM(3)) XMM2 = XM(2) * (XM(3) + XM(1)) / (XM(1) + XM(2) + XM(3)) XMM3 = XM(3) * (XM(1) + XM(2)) / (XM(1) + XM(2) + XM(3)) A(1) = - SQRT(TWO * XMM2 * XE(2)) - XE(3) * SQRT(XMM2) - XA(3) A(2) = - SQRT(TWO * XMM1 * XE(1)) - XE(3) * SQRT(XMM1) - XA(3) A(3) = XA(3) D1 = A(1) + A(2) D2 = SQRT(XMM3) D = D1 + XE(3) * D2 C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 ALPHA(I) = - A(I) BETA(I) = - (F(I,1+IP0OFF) - A(I)) GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, D1, D2, D ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HEPS., C , 3E22.14, /, E 1H , 8HA(I) , 3E22.14, /, F 1H , 8HAV. R(I), 3E22.14, /, G 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HD1,D2, D, 3E22.14) END cfc005.f000644 000311 000121 00000011466 06067230141 012026 0ustar00krivecf1000000 000000 SUBROUTINE CFC005(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 XM1, XM2, XM3, XZ, XA, XAL, XR, XN, F, FANA) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XZ(3), XA(3), XAL(3), XR(3), XN(3), F(3,NDP0), 1 FANA(3,3) LOGICAL LPR C C C POWER SERIES COEFFICIENTS OF THE CORRELATION FUNCTION C C 3 C F = SUM [A + (B - A ) EXP(-C R )] R , C I=1 I I I I I I C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C B(I) ARE PRECISE CUSP PARAMETERS CALULATED IN THIS ROUTINE. C IT IS ALSO POSSIBLE TO REQUIRE THAT A(I) EQUAL THE CUSP PARAMETER C FOR SOME I; THEN B(I) = A(I) AND F IS LINEAR IN R(I). C BUT A(I) ARE INDEPENDENT OF EACH OTHER; NO AYMPTOTIC C CONDITIONS ARE IMPOSED. (INTENDED FOR IMPROVING ON THE LINEAR C CORRELATION FUNCTION IN CASES LIKE MU-D-T IN WHICH ASYMPTOTICS C SEEM TO BE DIFFICULT TO IMPLEMENT IN CORRELATION FUNCTION.) C C INPUT: C XM1-3 = (M1, M2, M3). MASSES. C XZ(1-3) = (Z2*Z3, Z3*Z1, Z1*Z2). PRODUCTS OF CHARGES, NOT C CHECKED AGAINST V HERE, TO ENABLE ARTIFICIAL C MODIFICATIONS LIKE MODIFYING ONE OF THE CUSPS C FROM THE CORRECT VALUE (NON-FATAL CHECKS CAN C BE DONE BY THE CALLING PROGRAM). C XA(1-3) = VALUES OF PARAMETERS A(I). C XAL(1-3): IF XAL(I) = 0.0, A(I) = XA(I), AS IT IS INPUT; C ELSE A(I) IS EQUATED TO B(I). C XR(1-3) = (R1, R2, R3) (AVERAGE R(I), FOR C(I), SEE BELOW). C XN(1-3) = (N1, N2, N3) (FOR C(I), SEE BELOW). C C THE FOLLOWING QUANTITIES ARE CALCULATED: C B1, B2, B3; C C1, C2, C3, C WHERE C B1, B2, B3 ARE CUSP PARAMETERS, C C1 = 1 / (N1 R1), C C2 = 1 / (N2 R2), C C3 = 1 / (N3 R3). C C B IS CALCULATED BY CALLING CFC002. C A, B, AND C ARE THEN INPUT TO CFC001 TO CALCULATE THE POWER C EXPANSIONS. C STORAGE OF F EXPANSION: F(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C HERE IP0 = 1,..., IPFU (ABORTING IF IPFL .GT. 1). C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / DIMENSION ALPHA(3), BETA(3), GAMMA(3) C CHARACTER*6 NAME DATA NAME / 'CFC005' / CHARACTER*60 VERS DATA VERS */ ' 2.4, 93/03/16. (1.0) ' / C ------------------------------------------------------------ C DATA ZERO, ONE / 0.D0, 1.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (IPFL .GT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPFU .LT. 1) CALL ERR2(NAME, 2, 1, NOUT) IF (IPFU+IP0OFF .GT. NDP0) CALL ERR2(NAME, 3, 1, NOUT) IF (XN(1) .LE. ZERO) CALL ERR2(NAME, 4, 1, NOUT) IF (XN(2) .LE. ZERO) CALL ERR2(NAME, 5, 1, NOUT) IF (XN(3) .LE. ZERO) CALL ERR2(NAME, 6, 1, NOUT) IF (XR(1) .LE. ZERO) CALL ERR2(NAME, 7, 1, NOUT) IF (XR(2) .LE. ZERO) CALL ERR2(NAME, 8, 1, NOUT) IF (XR(3) .LE. ZERO) CALL ERR2(NAME, 9, 1, NOUT) C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2100) NAME, XM1, XM2, XM3, XZ, XA, XR, XN ENDIF C C CALCULATE B (TEMPORARILY IN F(.,1+IP0OFF)). IPFX = 1 CALL CFC002(NDP0, NOUT, LPR, 1 IPFX, IPFX, IP0OFF, 2 XM1, XM2, XM3, XZ, F, FANA) C C DEFINE INPUT FOR CFC001. DO 10 I = 1,3 IF (XAL(I) .EQ. ZERO) THEN C NONLINEAR, WITH INPUT A. ALPHA(I) = - XA(I) BETA(I) = - (F(I,1+IP0OFF) - XA(I)) ELSE C LINEAR, WITH CALCULATED A = B. ALPHA(I) = - F(I,1+IP0OFF) BETA(I) = ZERO ENDIF GAMMA(I) = ONE / (XN(I) * XR(I)) 10 CONTINUE CALL CFC001(NDP0, NOUT, LPR, 1 IPFL, IPFU, IP0OFF, 2 ALPHA, BETA, GAMMA, F, FANA) DO 12 I = 1,3 FANA(I,1) = - ALPHA(I) FANA(I,2) = - BETA(I) FANA(I,3) = GAMMA(I) 12 CONTINUE C C TEST OUTPUT. IF (LPR) THEN WRITE (NOUT,2200) NAME, ALPHA, BETA, GAMMA, FANA ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HMASSES , 3E22.14, /, C 1H , 8HPROD.CH., 3E22.14, /, D 1H , 8HA(I) , 3E22.14, /, E 1H , 8HAV. R(I), 3E22.14, /, F 1H , 8HN(I) , 3E22.14) 2200 FORMAT ( A 2H -, A6, 1H-, /, B 1H , 8HALPHA , 3E22.14, /, C 1H , 8HBETA , 3E22.14, /, D 1H , 8HGAMMA , 3E22.14, /, E 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END cleb1.f000644 000311 000121 00000005340 05305160004 012020 0ustar00krivecf1000000 000000 FUNCTION CLEB1(NDFACT, NFACT, FACT, X1, X2, X3, X4, X5, X6) IMPLICIT REAL*8 (A - H, O - Z) C*I C*I C*D FUNCTION CLEB(X1,X2,X3,X4,X5,X6) C*I C*I C*I ORIGIN: UNIVERSITY OF CALIFORNIA AT DAVIS. C*I MODIFIED 05/20/83 BY R. KRIVEC. C*I C*I V 2.0, 90/04/29. C*I C*I DELETED LINES BEGIN WITH C*D . SOME ARE FOLLOWED BY SUBTITUTES. C*I INSERTED LINES BEGIN OR ARE PRECEDED BY C*I . C*I C*I NDFACT .GE. NFACT .GE. X1 + X2 + X3 + 2 MUST HOLD IN ALL C*I CALLS OF A GIVEN RUN. C*I C*I FURTHER MODIFICATIONS: C*I C*I MODIFICATION (CO1) TO AVOID OVERFLOW, 06/01/83. C*I MORE SQRT-S TO AVOID OVERFLOW IN FACT (NOW NFACT .LE. 960 C*I ON VAX). C*I DIVISIONS IN CO1 MOVED STILL FORWARD, 06/02/83. C*I EXPLICIT CHECK FOR BOUNDS (NFACT) ADDED, 06/17/83. C*I C*I C C(L1,L2,L,M1,M2,M) C*D DIMENSION FACT(101) DIMENSION FACT(NDFACT) DATA INK /0/ C*I IF (NFACT .GT. 960) CALL EXIT IF(INK.EQ.1) GO TO 11 FACT(1)=1. C*D DO 10 I=2,101 DO 10 I = 2,NFACT C*D10 FACT(I)=FACT(I-1)*SQRT(SQRT(SQRT(SQRT(DFLOAT(I-1))))) 10 FACT(I) = FACT(I-1) * A SQRT(SQRT(SQRT(SQRT(SQRT(SQRT(DFLOAT(I-1))))))) INK=1 11 CONTINUE NA=2.001*X1 NB=2.001*X2 NC=2.001*X3 ND=2.001*X4 NE=2.001*X5 NF=-2.001*X6 C*D CLEB=0. CLEB1=0. IF(ND+NE+NF.NE.0)GOTO2 L3=(NB+NE)/2 L8=(NA+ND)/2 L10=(NC+NF)/2 IF(MOD(NB+NE,2).NE.0.OR.MOD(NA+ND,2).NE.0.OR. X MOD(NC+NF,2).NE.0)GOTO2 L0=(NA+NB+NC)/2 C*D IF(L0.GT.99)GOTO2 IF (L0 .GT. NFACT-2) GO TO 2 IF(IABS(ND).GT.NA.OR.IABS(NE).GT.NB.OR.IABS(NF).GT.NC)GOTO2 L1=(NA+NB-NC)/2 L2=(NA-ND)/2 L4=(NC-NB+ND)/2 L5=(NC-NA-NE)/2 L6=(NA-NB+NC)/2 L7=(NB+NC-NA)/2 L9=(NB-NE)/2 L11=(NC-NF)/2 KMIN=MAX(0,-L4,-L5)+1 KMAX=MIN(L1,L2,L3)+1 IF(KMAX.LT.KMIN) GO TO 2 L20=NC+1 C*D CO1=FACT(L1+1)*FACT(L6+1)*FACT(L7+1)*FACT(L8+1) C*D X *FACT(L2+1)*FACT(L3+1) C*D X*FACT(L9+1)*FACT(L10+1)*FACT(L11+1)/FACT(L0+2) C*D X *FACT(L20+1)/FACT(L20) CO1 = 1.D0 / FACT(L0+2) / 1 FACT(L20) * FACT(L1+1) * FACT(L6+1) * FACT(L7+1) * 2 FACT(L8+1) * FACT(L2+1) * FACT(L3+1) * 3 FACT(L9+1) * FACT(L10+1) * FACT(L11+1) * 4 FACT(L20+1) SGN=1. DO1KK=KMIN,KMAX K=KK-1 KKK=K-1 L12=L1-KKK L13=L2-KKK L14=L3-KKK L15=L4+KK L16=L5+KK DEN=FACT(K+1)*FACT(L12)*FACT(L13)*FACT(L14)*FACT(L15)*FACT(L16) C*D CLEB=CLEB+SGN*(((CO1/DEN**2)**2)**2)**2 CLEB1 = CLEB1 + SGN * (((((CO1 / DEN**2)**2)**2)**2)**2)**2 SGN=-SGN 1 CONTINUE C*D IF(MOD(KMIN-1,2).NE.0)CLEB=-CLEB IF (MOD(KMIN-1, 2) .NE. 0) CLEB1 = -CLEB1 2 CONTINUE RETURN END cqxeps.f000644 000311 000121 00000000465 05306655000 012346 0ustar00krivecf1000000 000000 FUNCTION CQXEPS() REAL*16 CQXEPS C C ** MACHINE DEPENDENT ** C EPS (SMALLEST REAL*16 NUMBER SUCH THAT (1.Q0 + EPS) .GT. 1.Q0). C CQXEPS = 2.Q0 ** (-112) C* CONVEX C220 C* CQXEPS = 2.Q0 ** (-108) C* IBM RETURN END cqxtol.f000644 000311 000121 00000000450 05306655102 012352 0ustar00krivecf1000000 000000 FUNCTION CQXTOL() REAL*16 CQXTOL C C ** MACHINE DEPENDENT ** C TOL (SMALLEST REPRESENATBLE REAL*16 NUMBER). C CQXTOL = 2.Q0 ** (-16385) C* CONVEX C220 C* CQXTOL = 2.Q0 ** (-260) C* IBM RETURN END err2.f000644 000311 000121 00000000641 05213131662 011711 0ustar00krivecf1000000 000000 SUBROUTINE ERR2(NAME, NERR, ISTOP, NOUT) CHARACTER*6 NAME INTEGER NERR, ISTOP, NOUT C IF (ISTOP .NE. 1) WRITE (NOUT,1000) NERR, NAME IF (ISTOP .EQ. 1) WRITE (NOUT,1010) NERR, NAME IF (ISTOP .EQ. 1) CALL EXIT C 1000 FORMAT (1H , 16H** ERROR (W) , I16, 6H IN , A6, 5H **) 1010 FORMAT (1H , 16H**** ERROR (F) , I16, 6H IN , A6, 5H ****) RETURN END gauscq.f000644 000311 000121 00000003431 06067230162 012325 0ustar00krivecf1000000 000000 SUBROUTINE GAUSCQ(NDG, NDN, NDNZ, N, Z, P, AG, WG, NOUT, LPR) IMPLICIT REAL*16 (A-H, O-Z) LOGICAL LPR DIMENSION Z(NDNZ), P(NDN), AG(NDG), WG(NDG) C C C ABSCISSAS AND WEIGHTS FOR GAUSS INTEGRATION. C THE POSITIVE ABSCISSAS ARE GIVEN ONLY. C C CHARACTER*6 NAME DATA NAME / 'GAUSCQ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: CGAUSS 3.1, 90/04/07. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ZERO, ONE, TWO / 0.Q0, 1.Q0, 2.Q0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N .LT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF ((N + 1) / 2 .GT. NDG) CALL ERR2(NAME, 2, 1, NOUT) IF (N + 1 .GT. NDN) CALL ERR2(NAME, 3, 1, NOUT) IF (N / 2 + 2 .GT. NDNZ) CALL ERR2(NAME, 4, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C IF (LPR) WRITE (NOUT,100) NAME, N, NDG, NDN, NDNZ CALL LP0ZQ(NDN, NDNZ, N, NZ, P, Z, NOUT) IF (LPR) WRITE (NOUT,102) NAME, N, NZ, NDN, NDNZ FN = TWO / (N * N) IP = 1 IF (MOD(N, 2) .EQ. 0) GO TO 10 CALL LP0Q(NDN, N - 1, ZERO, P, NOUT) WG(1) = FN / (P(N) * P(N)) AG(1) = ZERO IP = 2 10 CONTINUE DO 12 I = 1,NZ IF (LPR) WRITE (NOUT,104) NAME, I CALL LP0Q(NDN, N - 1, Z(I), P, NOUT) WG(IP) = FN * (ONE - Z(I) * Z(I)) / (P(N) * P(N)) AG(IP) = Z(I) IP = IP + 1 12 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 100 FORMAT ( A 2H -, A6, 1H-, 16H N NDG NDN NDNZ, 4I4) 102 FORMAT ( A 2H -, A6, 1H-, 16H N NZ NDN NDNZ, 4I4) 104 FORMAT ( A 2H -, A6, 1H-, 4H I, I4) END gausq.f000644 000311 000121 00000002650 06067230164 012166 0ustar00krivecf1000000 000000 SUBROUTINE GAUSQ(NDA, NDB, AG, WG, N, A, B, AG1, WG1, NOUT) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION AG1(NDB), WG1(NDB) C ********** REAL*16 AG(NDA), WG(NDA) C ********** C C C ABSCISSAS AND WEIGHTS OF GAUSSIAN INTEGRATION FOR THE INTERVAL C (A, B). THE ORDER OF INTEGRATION IS N. C INPUT: THE POSITIVE ABSCISSAS AND THEIR WEIGHTS IN EXTENDED C PRECISION. C THIS ROUTINE DOES NOT TEST N AGAINST INPUT VALUES OF AG, WG. C C CHARACTER*6 NAME DATA NAME / 'GAUSQ ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: GAUSSA 2.0, 05.10.85. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, HALF / 0.5D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N .GT. NDB) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C ZA = HALF * (B - A) ZB = HALF * (B + A) N2 = N / 2 N12 = (N + 1) / 2 N21 = N2 + 1 NM2 = MOD(N, 2) IF (NM2 .EQ. 0) GO TO 10 AG1(N2+1) = ZB WG1(N2+1) = WG(1) 10 CONTINUE DO 12 I = 1,N2 AG1(N12+I) = ZA * AG(I+NM2) + ZB WG1(N12+I) = ZA * WG(I+NM2) AG1(N21-I) = - ZA * AG(I+NM2) + ZB WG1(N21-I) = WG1(N12+I) 12 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END gf2.f000644 000311 000121 00000001700 05213131664 011514 0ustar00krivecf1000000 000000 SUBROUTINE GF2(ND, N, LF2, GNL, GN2L) C IMPLICIT REAL * 8 (A - H, O - Z) INTEGER ND, N, LF2 REAL * 8 GNL(ND), GN2L(ND) C C C NATURAL LOGARITHMS OF GAMMA FUNCTIONS AS FOLLOWS: C C GNL(I) = LOG(GAMMA(I)), I = 1,..., N; C GN2L(J) = LOG(GAMMA((2(J - 1) + 1) / 2)), J = 1,..., N; C C I.E., THE GAMMA FUNCTIONS ARE C C GAMMA(1),..., GAMMA(N); C GAMMA(1/2),..., GAMMA(N-1/2). C C C GF2 1.0, 88/03/31. R. K. C C IF (N .GE. 1 .AND. N .LE. ND) GO TO 10 WRITE (LF2,2001) N, ND CALL EXIT 10 CONTINUE PI = CDXPI() GNL(1) = 0.D0 GN2L(1) = LOG(SQRT(PI)) IF (N .EQ. 1) RETURN DO 12 I = 2,N GNL(I) = GNL(I-1) + LOG(DFLOAT(I - 1)) GN2L(I) = GN2L(I-1) + LOG(0.5D0 * DFLOAT(2 * I - 3)) 12 CONTINUE RETURN 2001 FORMAT (1H , 8H* GF2 *, 32H EXIT - N OUT OF RANGE , A 8HN, ND , 2I8) END lp0q.f000644 000311 000121 00000002031 06067230205 011707 0ustar00krivecf1000000 000000 SUBROUTINE LP0Q(NDN, NU, X, P, NOUT) IMPLICIT REAL*16 (A-H, O-Z) DIMENSION P(NDN) C C C VALUES OF LEGENDRE POLYNOMIALS P (X), N = 0, ..., NU. C N C P(N + 1) = P (X). C N C CHARACTER*6 NAME DATA NAME / 'LP0Q ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: PNVAL 1.1, 20.9.85. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, ONE / 1.Q0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (NU + 1 .GT. NDN) CALL ERR2(NAME, 1, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C P(1) = ONE IF (NU .EQ. 0) RETURN P(2) = X IF (NU .EQ. 1) RETURN N1U = NU + 1 DO 10 N1 = 3,N1U P(N1) = ((N1 + N1 - 3) * X * P(N1-1) - 1 (N1 - 2) * P(N1-2)) 2 / (N1 - 1) 10 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END lp0zq.f000644 000311 000121 00000004274 06067230206 012115 0ustar00krivecf1000000 000000 SUBROUTINE LP0ZQ(NDN, NDNZ, N, NZ, P, Z, NOUT) IMPLICIT REAL*16 (A-H, O-Z) DIMENSION P(NDN), Z(NDNZ) C C C ZEROS OF P (X) IN THE (OPEN) INTERVAL (0, 1). C N C CHARACTER*6 NAME DATA NAME / 'LP0ZQ ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: PNZERC 1.0C, 90/04/18. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, 1 ZERO, ONE, TWO, ONE4 / 0.Q0, 1.Q0, 2.Q0, 0.25Q0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (N + 1 .GT. NDN) CALL ERR2(NAME, 1, 1, NOUT) IF (N / 2 + 2 .GT. NDNZ) CALL ERR2(NAME, 2, 1, NOUT) IF (LCALL0) LCALL0 = .FALSE. C EPS = CQXEPS() TOL = TWO ** 8 * CQXTOL() C NZ = N / 2 IF (NZ .EQ. 0) RETURN NZ2 = NZ + 2 N1 = N + 1 Z(1) = - ONE / NZ Z(2) = ZERO DO 20 I = 3,NZ2 H = ONE4 * (Z(I-1) - Z(I-2)) X0 = Z(I-1) + H CALL LP0Q(NDN, N, X0, P, NOUT) F0 = P(N1) S0 = SIGN(ONE, F0) X1 = X0 X2 = X0 10 CONTINUE X1 = X1 + H CALL LP0Q(NDN, N, X1, P, NOUT) IF (ABS(P(N1)) .LT. EPS) GO TO 18 IF (SIGN(ONE, P(N1)) .EQ. S0) GO TO 10 F1 = P(N1) DNEW = ABS(X1 - X0) 12 CONTINUE DOLD = DNEW X2 = (X0 * F1 - X1 * F0) / (F1 - F0) CALL LP0Q(NDN, N, X2, P, NOUT) IF (ABS(P(N1)) .LT. EPS) GO TO 18 F2 = P(N1) IF (SIGN(ONE, F2) .EQ. S0) GO TO 14 X1 = X2 F1 = F2 GO TO 16 14 CONTINUE X0 = X2 F0 = F2 S0 = SIGN(ONE, F2) 16 CONTINUE DNEW = ABS(X1 - X0) IF (DNEW .GE. DOLD) GO TO 18 IF (ABS(F1 - F0) .LT. TOL) GO TO 18 GO TO 12 18 CONTINUE Z(I) = X2 20 CONTINUE DO 22 I = 1,NZ Z(I) = Z(I+2) 22 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m11a.f000644 000311 000121 00000004251 06067232327 011607 0ustar00krivecf1000000 000000 FUNCTION M11A(NDG, NOUT, PTEST, 1 NG, GNL, GN2L, MU, IP) C IMPLICIT REAL*8 (A-H, O-Z) REAL*8 M11A C LOGICAL PTEST DIMENSION GNL(NDG), GN2L(NDG) C C C C C CALCULATES A FACTOR APPEARING IN THE HH EXPANSION OF POWERS C OF INTERPARTICLE DISTANCES (POWER: IP, HH INDEX: MU), C C C GAMMA((IP+3)/2) SQRT((MU+1) (-IP/2) C MU C 4 PI ---------------------------------------. C GAMMA(MU + IP/2 + 3) C C C STOPS THE PROGRAM IF IP .LT. -2. C IT USES NATURAL LOGARITHMS OF GAMMA FUNCTIONS AS FOLLOWS: C C GNL(I) = LOG(GAMMA(I)), I = 1,..., NG; C GN2L(J) = LOG(GAMMA((2(J - 1) + 1) / 2)), J = 1,..., NG, C C IE., THE GAMMA FUNCTIONS MUST BE INPUT ORDERED AS C C GAMMA(1),..., GAMMA(NG); C GAMMA(1/2),..., GAMMA(NG-1/2). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M11A ' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (NG .GT. NDG) CALL ERR2(NAME, 1, 1, NOUT) C C C POCHHAMMER SYMBOL (S * EXP(P)). C A = -0.5D0 * DFLOAT(IP) CALL POCH1(A, MU, NOUT, P, S) C C C GAMMA((IP+3)/2), GAMMA(MU + IP/2 + 3). C IF (IP .LT. -2) CALL ERR2(NAME, 2, 1, NOUT) IF (MU+3+(IP+1)/2 .GT. NG) CALL ERR2(NAME, 3, 1, NOUT) IF (MOD(IABS(IP), 2) .EQ. 0) 1 G = GN2L((IP+4)/2) - GNL(MU+3+IP/2) IF (MOD(IABS(IP), 2) .NE. 0) 1 G = GNL((IP+3)/2) - GN2L(MU+3+(IP+1)/2) C C C THE RESULT (S MAY BE 0). C C M11A = S * EXP(P + G) * 4.D0 * CDXPI() * SQRT(DFLOAT(MU + 1)) C C IF (PTEST) WRITE (NOUT,2100) NAME, 1 NDG, NG, MU, IP, S, P, G, M11A, 2 (I, GNL(I), GN2L(I), I = 1,NDG) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.4, 95/12/24. 1.3, 93/03/16. ) C ======================================== 2100 FORMAT ( A 1H , A6, B 44HNDG,NG,MU,IP,S,P,G,M11A,(I,GNL(I),GN2L(I)) ,/, C 1H , 4I4, 4F16.8, /, (1H , I4, 2F16.8)) END m12a.f000644 000311 000121 00000003540 06067232415 011606 0ustar00krivecf1000000 000000 SUBROUTINE M12A(NOUT, 1 XOMEGA, XKAPPA, G, NU, IP, 2 XGR, XGI) C IMPLICIT REAL*8 (A-H, O-Z) C DIMENSION XOMEGA(3), XKAPPA(3), G(3) C C C C C CALCULATES A FACTOR APPEARING IN THE HH EXPANSION OF FUNCTIONS C OF INTERPARTICLE DISTANCES (POWER: IP, HH INDEX: MU), C C SUM(K=1...3) EXP(I OMEGA(K) NU) (2 KAPPA(K))**(IP/2) G(K,IP). C C THIS IS THE ONLY FACTOR WHERE THE SUM OVER PARTICLE PAIRS C APPEARS. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M12A ' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (IP .NE. 0) GO TO 20 C C ZERO IP. C XGR = COS(XOMEGA(1)*DFLOAT(NU)) * G(1) + 1 COS(XOMEGA(2)*DFLOAT(NU)) * G(2) + 2 COS(XOMEGA(3)*DFLOAT(NU)) * G(3) XGI = SIN(XOMEGA(1)*DFLOAT(NU)) * G(1) + 1 SIN(XOMEGA(2)*DFLOAT(NU)) * G(2) + 2 SIN(XOMEGA(3)*DFLOAT(NU)) * G(3) RETURN 20 CONTINUE C C NONZERO IP. C Z1 = SQRT(2.D0 * XKAPPA(1)) Z2 = SQRT(2.D0 * XKAPPA(2)) Z3 = SQRT(2.D0 * XKAPPA(3)) IF (IP .LT. 0) Z1 = 1.D0 / Z1 IF (IP .LT. 0) Z2 = 1.D0 / Z2 IF (IP .LT. 0) Z3 = 1.D0 / Z3 XGR = COS(XOMEGA(1)*DFLOAT(NU)) * (Z1**IABS(IP) * G(1)) + 1 COS(XOMEGA(2)*DFLOAT(NU)) * (Z2**IABS(IP) * G(2)) + 2 COS(XOMEGA(3)*DFLOAT(NU)) * (Z3**IABS(IP) * G(3)) XGI = SIN(XOMEGA(1)*DFLOAT(NU)) * (Z1**IABS(IP) * G(1)) + 1 SIN(XOMEGA(2)*DFLOAT(NU)) * (Z2**IABS(IP) * G(2)) + 2 SIN(XOMEGA(3)*DFLOAT(NU)) * (Z3**IABS(IP) * G(3)) RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.1, 95/12/24. 1.0, 90/02/19. ) C ======================================== END m1amna.f000644 000311 000121 00000004002 06067232505 012212 0ustar00krivecf1000000 000000 SUBROUTINE M1AMNA(NDS, NDAMN, NOUT, A NS, ISMN, B AMN) IMPLICIT REAL*8 (A-H, O-Z) C DIMENSION ISMN(2,NDS), AMN(3,NDAMN) C C C C C A(ALPHA;MU, NU) FOR ALL STATES. C MUST BE CALLED WITH STATES CONTAINING ALL NU VALUES - C THIS IS CHECKED ON NS WHICH MUST BE EQUAL TO C (MUU + 1)*(MUU + 2)/2 (MUU = LARGEST MU), AND ON EACH C STATE INDEX. C C ON ENTRY: C NDS DIMENSION - MAX. NO. OF STATES. C NDAMN DIMENSION OF AMN. C NOUT OUTPUT LOGICAL UNIT NO. C NS NO. OF STATES. C ISMN (MU,NU) PAIRS FOR ALL STATES. C C ON EXIT: C AMN(1,I) A(-1,MU(I),NU(I)), C AMN(2,I) A(0,MU(I),NU(I)), C AMN(3,I) A(1,MU(I),NU(I)), FOR I = 1,NS. C C DIMENSIONS ARE TESTED. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M1AMNA' / C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (NS .LE. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) MUU1 = ISMN(1,NS) + 1 IF (MUU1*(MUU1 + 1)/2 .NE. NS) CALL ERR2(NAME, 3, 1, NOUT) IF (NS .GT. NDAMN) CALL ERR2(NAME, 4, 1, NOUT) C C C RESET MATRIX. DO 10 I = 1,NDAMN AMN(1,I) = 0 AMN(2,I) = 0 AMN(3,I) = 0 10 CONTINUE DO 22 I = 1,NS MU = ISMN(1,I) NU = ISMN(2,I) C C C TEST ORDERING OF (MU,NU). IF (I .NE. (MU*(MU+1)+MU+NU)/2+1) CALL ERR2(NAME,5,1,NOUT) AMN(1,I) = 1 SQRT(0.5D0 * DFLOAT((MU - NU + 2)*(MU + NU))) AMN(2,I) = DFLOAT(NU) AMN(3,I) = 1 SQRT(0.5D0 * DFLOAT((MU + NU + 2)*(MU - NU))) 22 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.1, 95/12/24. 1.0, 90/02/20. ) C ======================================== END m1arqa.f000644 000311 000121 00000004323 06067230211 012220 0ustar00krivecf1000000 000000 SUBROUTINE M1ARQA(NDQ, NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 DAS, NGOA, NSUBA, 2 P, Z, AG, WG, AG1, WG1, PTEST, PTESTG, 3 XSI, WSI, NOUT, 4 NQ, X, W) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL PTEST, PTESTG DIMENSION NGOA(2), NSUBA(2), 1 AG1(NDGO), WG1(NDGO), XSI(NDQSI), WSI(NDQSI), 2 X(NDQ), W(NDQ) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C INTEGRATION POINTS IN VARIABLE A. C INTERVAL IS (0, PI/2), SINGULARITIES ARE AT A = PI/2. C C CHARACTER*6 NAME DATA NAME / 'M1ARQA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: M1ARA 1.0, 90/02/26. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DIMENSION XAB(3) DATA LCALL0 / .TRUE. /, 1 ZERO, HALF, ONE4 / 0.D0, 0.5D0, 0.25D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C TESTS. IF (DAS .LT. ZERO) CALL ERR2(NAME, 1, 1, NOUT) IF (DAS .GT. ONE4 * CDXPI()) CALL ERR2(NAME, 2, 1, NOUT) C C BOUNDARIES. XAB(1) = ZERO XAB(2) = HALF * CDXPI() - DAS XAB(3) = HALF * CDXPI() C C GENERATE QUADRATURE POINTS. C NQ = 0 C INTERVAL COUNT. DO 30 I = 1,2 C INTERVAL LIMITS. A = XAB(I) B = XAB(I+1) C C DEFINE GAUSS POINTS OVER (A, B) SUBDIVISIONS. C GAUSS ORDER, NUMBER OF SUBDIVISIONS. N = NGOA(I) NSI = NSUBA(I) CALL M1XGQA(NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 N, NSI, A, B, 2 P, Z, AG, WG, AG1, WG1, PTESTG, 3 NOUT, 4 NQSI, XSI, WSI) C C ADD POINTS TO FINAL GRID. DO 20 J = 1,NQSI NQ = NQ + 1 IF (NQ .GT. NDQ) CALL ERR2(NAME, 3, 1, NOUT) X(NQ) = XSI(J) W(NQ) = WSI(J) 20 CONTINUE 30 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m1cd.f000644 000311 000121 00000002444 06067232601 011671 0ustar00krivecf1000000 000000 SUBROUTINE M1CD(XM1, XM2, XM3, 1 NOUT, 2 XKAPPA, XOMEGA) C IMPLICIT REAL*8 (A - H, O - Z) C DIMENSION XKAPPA(3), XOMEGA(3) C C C C C KAPPAS AND OMEGAS (FOR ANY MASSES). C (IF THERE IS MORE THAN ONE "INFINITE" MASS, THE FORMULA C FOR XOMEGA MAY GET CRAZY, BUT THE FIXUP IS TRIVIAL.) C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M1CD ' / C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (XM1 .LT. 0.D0) CALL ERR2(NAME, 1, 1, NOUT) IF (XM2 .LT. 0.D0) CALL ERR2(NAME, 2, 1, NOUT) IF (XM3 .LT. 0.D0) CALL ERR2(NAME, 3, 1, NOUT) C C XKAPPA(1) = (XM2 + XM3) / (2.D0 * XM2 * XM3) XKAPPA(2) = (XM3 + XM1) / (2.D0 * XM3 * XM1) XKAPPA(3) = (XM1 + XM2) / (2.D0 * XM1 * XM2) C C XOMEGA(1) = -ACOS((XM1*(XM3-XM2)-XM2*(XM3+XM2)) / 1 ((XM1+XM2)*(XM3+XM2)) ) XOMEGA(2) = ACOS((XM2*(XM3-XM1)-XM1*(XM3+XM1)) / 1 ((XM2+XM1)*(XM3+XM1)) ) XOMEGA(3) = 0.D0 RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 3.1, 95/12/24. 3.0, 90/08/30. ) C ======================================== END m1lrqa.f000644 000311 000121 00000007227 06067230213 012243 0ustar00krivecf1000000 000000 SUBROUTINE M1LRQA(NDQ, NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 XOMEGA, DLS, NGOL, NSUBL, 2 P, Z, AG, WG, AG1, WG1, PTEST, PTESTG, 3 XSI, WSI, NOUT, 4 NQX, X, W) IMPLICIT REAL*8 (A-H, O-Z) LOGICAL PTEST, PTESTG DIMENSION XOMEGA(3), NGOL(10,2), NSUBL(10,2), 1 AG1(NDGO), WG1(NDGO), XSI(NDQSI), WSI(NDQSI), 2 NQX(2), X(NDQ,2), W(NDQ,2) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C INTEGRATION POINTS IN VARIABLE LAMBDA. C INTERVAL IS (0, 2PI), SINGULARITIES ARE: C C R(K) = 0: LAMBDA = PI - XOMEGA(K), K = 1, 2, 3. C C CHARACTER*6 NAME DATA NAME / 'M1LRQA' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 92/11/26. O: M1LRA 2.0, 90/04/26. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DIMENSION S(3), XLB(11) DATA LCALL0 / .TRUE. /, 1 ZERO, TWO, THREE / 0.D0, 2.D0, 3.D0 / C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C TEST SIGNS. IF (XOMEGA(2) .LT. CDXTOL()) CALL ERR2(NAME, 1, 1, NOUT) IF (XOMEGA(1) .GT. -CDXTOL()) CALL ERR2(NAME, 2, 1, NOUT) IF (DLS .LT. ZERO) CALL ERR2(NAME, 3, 1, NOUT) C C SINGULAR POINTS (ORDERED). XLL = ZERO XLU = TWO * CDXPI() S(1) = CDXPI() - XOMEGA(2) S(2) = CDXPI() - XOMEGA(3) S(3) = CDXPI() - XOMEGA(1) IF (S(1) .LT. TWO * DLS) CALL ERR2(NAME, 4, 1, NOUT) IF (S(2)-S(1) .LT. THREE * DLS) CALL ERR2(NAME, 5, 1, NOUT) IF (S(3)-S(2) .LT. THREE * DLS) CALL ERR2(NAME, 6, 1, NOUT) IF (XLU -S(3) .LT. TWO * DLS) CALL ERR2(NAME, 7, 1, NOUT) C C BOUNDARIES. XLB(1) = XLL XLB(2) = S(1) - DLS XLB(3) = S(1) XLB(4) = S(1) + DLS XLB(5) = S(2) - DLS XLB(6) = S(2) XLB(7) = S(2) + DLS XLB(8) = S(3) - DLS XLB(9) = S(3) XLB(10) = S(3) + DLS XLB(11) = XLU IF (PTEST) WRITE (NOUT,2500) NAME, DLS IF (PTEST) WRITE (NOUT,2300) NAME, S IF (PTEST) WRITE (NOUT,2400) NAME, XLB C C GENERATE QUADRATURE POINTS. DO 40 K = 1,2 NQ = 0 C INTERVAL COUNT. DO 30 I = 1,10 C INTERVAL LIMITS. A = XLB(I) B = XLB(I+1) C C DEFINE GAUSS POINTS OVER (A, B) SUBDIVISIONS. C GAUSS ORDER, NUMBER OF SUBDIVISIONS. N = NGOL(I,K) NSI = NSUBL(I,K) IF (PTEST) WRITE (NOUT,2200) NAME, K, I, A, B, N, NSI CALL M1XGQA(NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 N, NSI, A, B, 2 P, Z, AG, WG, AG1, WG1, PTESTG, 3 NOUT, 4 NQSI, XSI, WSI) C C ADD POINTS TO FINAL GRID. DO 20 J = 1,NQSI NQ = NQ + 1 IF (NQ .GT. NDQ) CALL ERR2(NAME, 8, 1, NOUT) X(NQ,K) = XSI(J) W(NQ,K) = WSI(J) 20 CONTINUE 30 CONTINUE NQX(K) = NQ 40 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2200 FORMAT (2H -, A6, 1H-, A 1H , 20HK, I, A, B, N, NSI , 2I4, 2F16.8, 2I4) 2300 FORMAT (2H -, A6, 1H-, A 1H , 20HS , 3F16.8) 2400 FORMAT (2H -, A6, 1H-, A 1H , 20HXLB , /, B (1H , F16.8)) 2500 FORMAT (2H -, A6, 1H-, A 1H , 20HDLS , F16.8) END m1miof.f000644 000311 000121 00000012652 06067230215 012236 0ustar00krivecf1000000 000000 SUBROUTINE M1MIOF(MODE, NIN1, NOUT, NOUT1, 1 NDP, NDS, NSPR, 2 XOMEGA, XKAPPA, 3 IPOFF, IPXU, INUSEL, 4 MUU, NS, ISMN, EMW, EMWD) IMPLICIT REAL * 8 (A - H, O - Z) DIMENSION XOMEGA(3), XKAPPA(3), 1 ISMN(2,NDS), 2 EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP) C C C INPUT/OUTPUT OF MATRIX ELEMENTS AND ACCOMPANYING DATA. C DIFFERS FROM M1MIOB IN THAT ISIS, ISN ARE NOT INPUT/OUTPUT, C TO MAKE THE CONTRACTION OF MATRICES WHICH ACTS ONLY ON ISMN, C EMW, EMWD, CONSISTENT. DIFFERS FROM M1MIOD IN THE ADJUSTMENT C OF IXPU AND NS (READS ONLY THE NUMBER OF MATRIX ELEMENTS C THAT FIT INTO EMW/D). THIS IS DONE SO THAT IPXU0, NS0 ARE C DEFINED FOR READING (ALL RECORDS MUST BE READ), AND ARE C FINALLY TRANSFERRED INTO IPXU, NS (WHICH NO LONGER SHOW C THE NUMBER OF MATRIX ELEMENTS IN THE INPUT FILE). C C MODE ACTION C C 1 FORMATTED OUTPUT. C 2 FORMATTED AND UNFORMATTED OUTPUT. C 3 UNFORMATTED INPUT (NO OUTPUT EXCEPT WARNINGS). C C NOTE THAT MATRIX ELEMENTS ARE PRINTED "UNTRANSPOSED," I.E., C THE SECOND INDEX RUNS IN ROWS, BUT THE UNFORMATTED OUTPUT C IS WITH THE FIRST INDEX RUNNING FIRST. C C NSPR IS AN INPUT PARAMETER ENSURING THAT NOT MORE THAN C NSPR ROWS/COLUMS OF THE FINAL MATRICES ARE PRINTED, TO C PREVENT VERY LARGE OUTPUT FILES. C C LOGICAL LCALL0, LOF, LOU, LIU DATA LCALL0 / .TRUE. / C CHARACTER*6 NAME DATA NAME / 'M1MIOF' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 92/07/03 (M1MIOD 1.0) (IPXU, NS ADJUSTMENT) ' / C ------------------------------------------------------------ C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (MODE .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (MODE .GT. 3) CALL ERR2(NAME, 2, 1, NOUT) C LOF = MODE .EQ. 1 .OR. MODE .EQ. 2 LOU = MODE .EQ. 2 LIU = MODE .EQ. 3 C NSPRX = NS IF (LOF .AND. NSPR .GE. 1) NSPRX = MIN(NS, NSPR) C IF (LIU) READ (NIN1) XOMEGA, XKAPPA IF (LOU) WRITE (NOUT1) XOMEGA, XKAPPA C IF (LIU) READ (NIN1) IPOFF, IPXU, INUSEL IF (LOF) WRITE (NOUT,9100) IPOFF, IPXU, INUSEL IF (LOU) WRITE (NOUT1) IPOFF, IPXU, INUSEL C IF (LIU) READ (NIN1) MUU, NS IF (LOF) WRITE (NOUT,9200) MUU, NS IF (LOU) WRITE (NOUT1) MUU, NS C IF (LIU) THEN C DEFINE IPXU0, NS0 (TEMPORARY, FOR READING). IF (IPXU .GT. NDP) CALL ERR2(NAME, 30, 0, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 31, 0, NOUT) IPXU0 = MIN(IPXU, NDP) NS0 = MIN(NS, NDS) ELSE IF (IPXU .GT. NDP) CALL ERR2(NAME, 40, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 41, 1, NOUT) ENDIF C IF (LIU) READ (NIN1) (ISMN(1,I), ISMN(2,I), I = 1,NS0) IF (LOF) WRITE (NOUT,9202) (I, ISMN(1,I), ISMN(2,I), I = 1,NS) IF (LOU) WRITE (NOUT1) (ISMN(1,I), ISMN(2,I), I = 1,NS) C C READ SEQUENTIAL FILE (ALL RECORDS). IF (LOF) WRITE (NOUT,9300) DO 22 K = 1,IPXU IP = K - IPOFF IF (LOF) WRITE (NOUT,9302) K, IP DO 20 J = 1,NS IF (LIU) THEN IF (J .LE. NS0 .AND. K .LE. IPXU0) THEN READ (NIN1) (EMW(I,J,K), I = 1,NS0) ELSE C SKIP RECORD. READ (NIN1) BUFF ENDIF ENDIF IF (LOF .AND. J .LE. NSPRX) 1 WRITE (NOUT,9304) J, ISMN(1,J), ISMN(2,J), 2 (EMW(J,I,K), I = 1,NSPRX) IF (LOU) WRITE (NOUT1) (EMW(I,J,K), I = 1,NS) 20 CONTINUE 22 CONTINUE C IF (LOF) WRITE (NOUT,9400) DO 32 K = 1,IPXU IP = K - IPOFF IF (LOF) WRITE (NOUT,9402) K, IP DO 30 J = 1,NS IF (LIU) THEN IF (J .LE. NS0 .AND. K .LE. IPXU0) THEN READ (NIN1) (EMWD(I,J,K), I = 1,NS0) ELSE C SKIP RECORD. READ (NIN1) BUFF ENDIF ENDIF IF (LOF .AND. J .LE. NSPRX) 1 WRITE (NOUT,9404) J, ISMN(1,J), ISMN(2,J), 2 (EMWD(J,I,K), I = 1,NSPRX) IF (LOU) WRITE (NOUT1) (EMWD(I,J,K), I = 1,NS) 30 CONTINUE 32 CONTINUE IF (LIU) THEN C ADJUST IPXU, NS (HERE OUTPUT PARAMETERS). IPXU = IPXU0 NS = NS0 ENDIF RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 9100 FORMAT (////, A 1H , 20HIPOFF, IPXU, INUSEL , 3I8) 9200 FORMAT (/, A 1H , 16HMUU, NS , 2I8) 9202 FORMAT (/, A 1H , 16H(MU,NU) PAIRS , //, (1H , I8, 4X, 2I4)) 9300 FORMAT (////, A 1H , 20HW MATRIX ELEMENTS ) 9302 FORMAT (//, A 1H , 16H POWER INDEX , I4, 12H, POWER , I4, /) 9304 FORMAT ( A 1H , I4, 4X, 2I4, 4D14.6, /, (1H , 16X, 4D14.6)) 9400 FORMAT (////, A 1H , 20HWD MATRIX ELEMENTS ) 9402 FORMAT (//, A 1H , 16H POWER INDEX , I4, 12H, POWER , I4, /) 9404 FORMAT ( A 1H , I4, 4X, 2I4, 4D14.6, /, (1H , 16X, 4D14.6)) END m1pioh.f000644 000311 000121 00000043507 06067230216 012247 0ustar00krivecf1000000 000000 SUBROUTINE M1PIOH(NIN, NOUT, NIN1, NOUT1, MODE, LCFC, LVC, 1 NDFPAR, NDVPAR, NDP0, NDWK, 2 XMASS1, XMASS2, XMASS3, XINF, 3 MUU, IPOS, PSYM, 4 IPFL, IPFU, IPVL, IPVU, IPWU, 5 FPAR, MODF, F, FANA, VPAR, MODV, V, WK, 6 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 7 IP0OFF, IP0XU, IPOFF, IPXU) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL LCFC, LVC, PSYM DIMENSION FPAR(3,NDFPAR), F(3,NDP0), FANA(3,3), 1 VPAR(3,NDVPAR), V(3,NDP0), WK(3,NDWK), 2 NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2) C C C PARAMETER INPUT/OUTPUT ROUTINE FOR MATRIX ELEMENTS. C C THIS ROUTINE PERFORMS FORMATTED AND UNFORMATTED INPUT/OUTPUT C OF PARAMETERS, NOT MATRIX ELEMENTS. IT HAS TWO INPUT AND C TWO OUTPUT CHANNELS WHICH ARE ACTIVATED ACCORDING TO THE C VALUE OF MODE. C C EXAMPLE: THE FIRST PROGRAM IN THE CHAIN USES THIS ROUTINE TO C READ PARAMETERS AND STORE THEM IN AN UNFORMATTED FILE; C THE NEXT PROGRAM USES THIS ROUTINE TO READ THOSE PARAMETERS C FROM THAT UNFORMATTED FILE, AND STORE THEM IN THE NEXT FILE, C ETC. EACH TIME THE PARAMETERS ARE ALSO PRINTED. C C C CHANNEL FILE TYPE C (UNIT NUMBER) (NO OPEN STAT. NEEDED) C C NIN FORMATTED (F), SEQUENTIAL C NOUT FORMATTED, SEQUENTIAL C NIN1 UNFORMATTED (U/F), SEQUENTIAL C NOUT1 UNFORMATTED, SEQUENTIAL C C C MODE ACTION COMMENT C C 1 F IN, F OUT USED IN M2M- C 2 F IN, F OUT, U/F OUT USED IN M2M- C 3 U/F IN, F OUT USED IN SCH. EQ. SOL. PROG. C 4 U/F IN, F OUT, U/F OUT USED IN SCH. EQ. SOL. PROG. C 5 U/F IN, F OUT AS 3, BUT CALCULATES FANA; C USED IN AVERAGES PROGRAM C C C NOTE THAT IP0OFF , IP0XU , IPOFF , IPXU ARE CALCULATED IN C THIS ROUTINE IF NECESSARY. FANA , F , V ARE CALCULATED IF C MODE = 1, 2, OR 5. C C C NEGATIVE MASSES ARE CHANGED TO XINF ("INFINITE") IMMEDIATELY C AFTER FIRST FORMATTED READ, SO THAT THEY NEVER REAPPEAR C IN ANY SUBSEQUENT FILE. C C CHARACTER*6 NAME DATA NAME / 'M1PIOH' / CHARACTER*60 VERS DATA VERS */ ' 1.3, 92/11/26 (MODE = 5 (FANA); CFC004; 5) (M1PIOG 2.1) ' / C ------------------------------------------------------------ C C LOGICAL LCALL0, LIF, LIU, LOF, LOU, LFV DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C DEFINE ACTIONS. C --------------- C IF (MODE .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (MODE .GT. 5) CALL ERR2(NAME, 2, 1, NOUT) C LIF = MODE .EQ. 1 .OR. MODE .EQ. 2 LIU = MODE .EQ. 3 .OR. MODE .EQ. 4 .OR. MODE .EQ. 5 LOF = .TRUE. LOU = MODE .EQ. 2 .OR. MODE .EQ. 4 LFV = MODE .EQ. 1 .OR. MODE .EQ. 2 .OR. MODE .EQ. 5 C C C MASSES OF PARTICLES. C ==================== C C A NEGATIVE MASS IS PUT EQUAL TO XINF WHEN FIRST INPUT C ("INFINITE," INPUT, SEE DEFINITION ELSEWHERE). C IF (LIF) READ (NIN,1012) XMASS1, XMASS2, XMASS3 IF (LIF) THEN IF (XMASS1 .LE. 0.D0) CALL ERR2(NAME, 11, 0, NOUT) IF (XMASS2 .LE. 0.D0) CALL ERR2(NAME, 12, 0, NOUT) IF (XMASS3 .LE. 0.D0) CALL ERR2(NAME, 13, 0, NOUT) IF (XMASS1 .LT. 0.D0) XMASS1 = XINF IF (XMASS2 .LT. 0.D0) XMASS2 = XINF IF (XMASS3 .LT. 0.D0) XMASS3 = XINF ENDIF IF (LIU) READ (NIN1) XMASS1, XMASS2, XMASS3 IF (LOF) WRITE (NOUT,2020) XMASS1, XMASS2, XMASS3 IF (LOU) WRITE (NOUT1) XMASS1, XMASS2, XMASS3 C C C MAX. MU (MATRIX), IPOS, PSYM FOR STATES. C ======================================== C IF (LIF) READ (NIN,1014) MUU, IPOS, PSYM IF (LIU) READ (NIN1) MUU, IPOS, PSYM IF (LOF) WRITE (NOUT,2030) MUU, IPOS, PSYM IF (LOU) WRITE (NOUT1) MUU, IPOS, PSYM C C C F, V POWER RANGES AND MATRIX ELEMENT POWER CUTOFF ( IPWU ). C =========================================================== C C F POWERS: (IPFL,..., IPFU). C V POWERS: (IPVL,..., IPVU). C IF (LIF) READ (NIN,1010) IPFL, IPFU, IPVL, IPVU, IPWU IF (LIU) READ (NIN1) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOF) WRITE (NOUT,2040) IPFL, IPFU, IPVL, IPVU, IPWU IF (LOU) WRITE (NOUT1) IPFL, IPFU, IPVL, IPVU, IPWU C C C STORAGE OFFSET AND NUMBER OF POWERS IN THE COMMON RANGE C OF POWERS FOR F, V (UNION OF RANGES OF F AND V). C ------------------------------------------------------- C IP0OFF = 1 - MIN(IPFL, IPVL) IP0XU = MAX(IPFU, IPVU) - MIN(IPFL, IPVL) + 1 IF (IP0XU .GT. NDP0) CALL ERR2(NAME, 21, 1, NOUT) IF (LOF) WRITE (NOUT,2042) IP0OFF, IP0XU C C STORAGE OFFSET AND NUMBER OF POWERS FOR THE HH EXPANSION C COEFFICIENTS AND FINAL MATRIX ELEMENTS. C -------------------------------------------------------- C IPOFF = -999 IPXU = -999 IF (LIF) THEN C SMALLEST AND LARGEST POWERS ( IPL , IPU ). C IPWU IS THE MAXIMUM REQUIRED POWER IN THE MATRIX ELEMENTS C OF W . C IF THE SERIES FOR F IS FINITE, THE MAXIMUM POWER, IPU0 , C IS GIVEN BY THE FORMULA BELOW. C IF THE SERIES FOR F IS INFINITE, IT CAN BE SHOWN THAT C THE HIGHEST POWER IN W WHICH IS NOT AFFECTED BY THE C CUTOFF OF POWERS IN F IS IPFU - 2 WHERE IPFU IS C THE LARGEST POWER OF F USED. C WARNING 22 APPLIES TO FINITE SERIES AND WARNS THAT NOT C ALL EXISTING POWERS IN W WILL BE CALCULATED (IGNORE C IN CASE OF INFINITE SERIES). C WARNING 23 APPLIES TO INFINITE SERIES AND WARNS THAT C MORE POWERS IN W WILL BE CALCULATED THAN ARE C UNAFFECTED BY THE CUTOFF IN F (IGNORE FOR FINITE C SERIES). C DIMENSION TESTS COME LATER IN MATRIX ELEMENT ROUTINES. C OFFSET: ARRAY INDEX = POWER + OFFSET. C IPL = MIN(IPVL, IPFL-2, 2*IPFL-2, IPFL-1) IPU0 = MAX(IPVU, IPFU-2, 2*IPFU-2, IPFU-1) IPU = MIN(IPU0, IPWU) IF (IPWU .LT. IPU0) CALL ERR2(NAME, 22, 0, NOUT) IF (IPWU .GT. MAX(IPVU, IPFU-2)) CALL ERR2(NAME, 23, 0, NOUT) IPOFF = 1 - IPL IPXU = IPU + IPOFF IF (LOF) WRITE (NOUT,2044) IPOFF, IPXU ENDIF C C C PARAMETERS OF THE CORRELATION FUNCTION. C ======================================= C C THE PROCEDURE: C (1) READ PARAMETERS USUALLY CALLED ALPHA(I), C BETA(I),..., I = 1,2,3, INTO THE ARRAY FPAR(I,K) , C K = 1,..., NFPAR . C (2) READ A MODE SWITCH ( MODF ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING FPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPFL , IPFU . C (THERE HAVE TO BE SOME BOUNDS IF THE CORRELATION C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN F(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NFPAR IF (LIU) READ (NIN1) NFPAR IF (LOF) WRITE (NOUT,2050) NFPAR IF (LOU) WRITE (NOUT1) NFPAR C IF (NFPAR .LT. 1) CALL ERR2(NAME, 31, 1, NOUT) IF (NFPAR .GT. NDFPAR) CALL ERR2(NAME, 32, 1, NOUT) C DO 30 K = 1,NFPAR C IF (LIF) READ (NIN,1100) J, (FPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (FPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2060) J, (FPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (FPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 33, 1, NOUT) IF (J .GT. NDFPAR) CALL ERR2(NAME, 34, 1, NOUT) 30 CONTINUE C IF (LIF) READ (NIN,1010) MODF IF (LIU) READ (NIN1) MODF IF (LOF) WRITE (NOUT,2062) MODF IF (LOU) WRITE (NOUT1) MODF C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE CORRELATION FUNCTION. C ---------------------------------------------------------- C C CUSP PARAMETRIZATION IS DONE BY CFC002. NOTE THAT THE C INPUT USED BY CFC002 (MASSES, CHARGES) IS INDEPENDENT OF C THE V COEFFICIENTS READ IN BELOW. THE CONSISTENCY TEST C IS DONE AFTER READING IN THE V COEFFICIENTS. C C IF (MODF.LT.0 .OR. MODF.GT.5) CALL ERR2(NAME, 35, 1, NOUT) IF (MODF .EQ. 0) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 36, 1, NOUT) CALL CFC000(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), F, FANA) ENDIF IF (MODF .EQ. 1) THEN IF (NFPAR .NE. 3) CALL ERR2(NAME, 37, 1, NOUT) CALL CFC001(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), FPAR(1,3), F, FANA) ENDIF IF (MODF .EQ. 2) THEN IF (NFPAR .NE. 1) CALL ERR2(NAME, 38, 1, NOUT) CALL CFC002(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, FPAR(1,1), 3 F, FANA) ENDIF IF (MODF .EQ. 3) THEN IF (NFPAR .NE. 2) CALL ERR2(NAME, 39, 1, NOUT) CALL CFC003(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 FPAR(1,1), FPAR(1,2), F) ENDIF IF (MODF .EQ. 4) THEN C FPAR: XZ, XE, XA, XR, XN (SEE CFC004). IF (NFPAR .NE. 5) CALL ERR2(NAME, 40, 1, NOUT) CALL CFC004(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), D1, D2, D, F, FANA) ENDIF IF (MODF .EQ. 5) THEN IF (NFPAR .NE. 5) CALL ERR2(NAME, 41, 1, NOUT) CALL CFC005(NDP0, NOUT, LCFC, 1 IPFL, IPFU, IP0OFF, 2 XMASS1, XMASS2, XMASS3, 3 FPAR(1,1), FPAR(1,2), FPAR(1,3), 4 FPAR(1,4), FPAR(1,5), F, FANA) ENDIF IF (LCFC) WRITE (NOUT,2200) NAME, FANA ENDIF C C C PARAMETERS OF THE POTENTIAL V. C ============================== C C THE PROCEDURE: C (1) READ PARAMETERS INTO THE ARRAY VPAR(I,K) , C K = 1,..., NVPAR . C (2) READ A MODE SWITCH ( MODV ) THAT TELLS WHICH C SUBROUTINE IS TO BE CALLED TO CALCULATE THE C POWER EXPANSION, USING VPAR . C (3) CALL THAT ROUTINE WITH THE BOUNDS ON POWERS C AS DEFINED BY THE PREVIOUSLY READ IPVL , IPVU . C (THERE HAVE TO BE SOME BOUNDS IF THE POTENTIAL C FUNCTION IS AN INFINITE EXPANSION.) THE RESULT C IS PLACED IN V(I,.) WITH A PROPER OFFSET FOR C POWERS (CALCULATED ABOVE). C IF (LIF) READ (NIN,1010) NVPAR IF (LIU) READ (NIN1) NVPAR IF (LOF) WRITE (NOUT,2070) NVPAR IF (LOU) WRITE (NOUT1) NVPAR C IF (NVPAR .LT. 1) CALL ERR2(NAME, 51, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 52, 1, NOUT) C DO 40 K = 1,NVPAR C IF (LIF) READ (NIN,1100) J, (VPAR(I,J), I = 1,3) IF (LIU) READ (NIN1) J, (VPAR(I,J), I = 1,3) IF (LOF) WRITE (NOUT,2080) J, (VPAR(I,J), I = 1,3) IF (LOU) WRITE (NOUT1) J, (VPAR(I,J), I = 1,3) C IF (J .LT. 1) CALL ERR2(NAME, 53, 1, NOUT) IF (J .GT. NDVPAR) CALL ERR2(NAME, 54, 1, NOUT) 40 CONTINUE C IF (LIF) READ (NIN,1010) MODV IF (LIU) READ (NIN1) MODV IF (LOF) WRITE (NOUT,2082) MODV IF (LOU) WRITE (NOUT1) MODV C IF (LFV) THEN C C CALCULATE THE POWER EXPANSION OF THE POTENTIAL. C ----------------------------------------------- C IF (MODV.LT.0 .OR. MODV.GT.1) CALL ERR2(NAME, 55, 1, NOUT) IF (MODV .EQ. 0) THEN CALL VC000(NDVPAR, NDP0, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) ENDIF IF (MODV .EQ. 1) THEN CALL VC001(NDVPAR, NDP0, NDWK, NOUT, LVC, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) ENDIF ENDIF C C IF (LIF .AND. (MODF .EQ. 2 .OR. MODF .EQ. 4 .OR. MODF .EQ. 5)) 1 THEN C C CONSISTENCY CHECK, TRUE CUSPS (ANY MODV ). C ------------------------------------------- C C TEST CUSP PARAMETERS VS. V PARAMETERS: FPAR ARE PRODUCTS C OF CHARGES IN THIS CASE (SEE CFC002), AND MUST BE EQUAL C TO THE V-COEFFICIENTS OF POWER -1. (FATAL ERRORS ONLY IF C MODF = 2 TO ENABLE FLEXIBILITY IN F.) C IF (MODF .EQ. 2) THEN ZZZ0 = 100 * CDXEPS() IERR = 1 ELSE ZZZ0 = 10 * CDXEPS() IERR = 0 ENDIF IF (IPVL .GT. -1 .OR. IPVU .LT. -1) 1 CALL ERR2(NAME, 60, 1, NOUT) ZZZ1 = V(1,-1+IP0OFF) ZZZ2 = V(2,-1+IP0OFF) ZZZ3 = V(3,-1+IP0OFF) IF (ABS(ZZZ1 - FPAR(1,1)) .GT. ABS(ZZZ0 * ZZZ1)) 1 CALL ERR2(NAME, 61, IERR, NOUT) IF (ABS(ZZZ2 - FPAR(2,1)) .GT. ABS(ZZZ0 * ZZZ2)) 1 CALL ERR2(NAME, 62, IERR, NOUT) IF (ABS(ZZZ3 - FPAR(3,1)) .GT. ABS(ZZZ0 * ZZZ3)) 1 CALL ERR2(NAME, 63, IERR, NOUT) ENDIF C C C GAUSSIAN INTEGRATION PARAMETERS. C ================================ C IF (LIF) READ (NIN,1010) (NGOA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NSUBA(I), I = 1,2) IF (LIF) READ (NIN,1010) (NGOL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,1), I = 1,10) IF (LIF) READ (NIN,1010) (NGOL(I,2), I = 1,10) IF (LIF) READ (NIN,1010) (NSUBL(I,2), I = 1,10) IF (LIF) READ (NIN,1030) DAS, DLS C IF (LIU) READ (NIN1) (NGOA(I), I = 1,2) IF (LIU) READ (NIN1) (NSUBA(I), I = 1,2) IF (LIU) READ (NIN1) (NGOL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,1), I = 1,10) IF (LIU) READ (NIN1) (NGOL(I,2), I = 1,10) IF (LIU) READ (NIN1) (NSUBL(I,2), I = 1,10) IF (LIU) READ (NIN1) DAS, DLS C IF (LOF) WRITE (NOUT,2120) (NGOA(I), I = 1,2), 1 (NSUBA(I), I = 1,2), 2 (NGOL(I,1), I = 1,10), 3 (NSUBL(I,1), I = 1,10), 4 (NGOL(I,2), I = 1,10), 5 (NSUBL(I,2), I = 1,10), 6 DAS, DLS C IF (LOU) WRITE (NOUT1) (NGOA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NSUBA(I), I = 1,2) IF (LOU) WRITE (NOUT1) (NGOL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,1), I = 1,10) IF (LOU) WRITE (NOUT1) (NGOL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) (NSUBL(I,2), I = 1,10) IF (LOU) WRITE (NOUT1) DAS, DLS C RETURN C C 1010 FORMAT (20I4) 1012 FORMAT (3F20.6) 1014 FORMAT (2I4, L4) 1030 FORMAT (10F8.2) 1100 FORMAT (I4, 3F20.16) C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2020 FORMAT (//, A 1H , 40HMASS1 , D28.16, /, B 1H , 40HMASS2 , D28.16, /, C 1H , 40HMASS3 , D28.16) 2030 FORMAT ( A 1H , 40HMUU; IPOS, PSYM (IGNORED) , 2I4, L4) 2040 FORMAT ( A 1H , 40HIPFL, IPFU , 2I4, /, B 1H , 40HIPVL, IPVU , 2I4, /, C 1H , 40HIPWU (CUTOFF) , I4) 2042 FORMAT ( A 1H , 40H CALCULATED: IP0OFF, IP0XU , 2I4) 2044 FORMAT ( A 1H , 40H CALCULATED: IPOFF, IPXU , 2I4) 2050 FORMAT ( A 1H , 32HNFPAR , I4) 2060 FORMAT ( A 1H , 36HJ, FPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2062 FORMAT ( A 1H , 32HMODF (F FORMULA SELECTOR) , I4) 2070 FORMAT ( A 1H , 32HNVPAR , I4) 2080 FORMAT ( A 1H , 36HJ, VPAR(1...3,J) , I4, D28.16, /, B 1H , 40H , D28.16, /, C 1H , 40H , D28.16) 2082 FORMAT ( A 1H , 32HMODV (V FORMULA SELECTOR) , I4) 2120 FORMAT (//, A 1H , 32HINTEGRATION PARAMETERS , /, B 1H , 32HNGOA , 2I4, /, C 1H , 32HNSUBA , 2I4, /, D 1H , 32HNGOL(.,1) , 10I4, /, E 1H , 32HNSUBL(.,1) , 10I4, /, F 1H , 32HNGOL(.,2) , 10I4, /, G 1H , 32HNSUBL(.,2) , 10I4, /, H 1H , 32HDAS, DLS , 2F12.6) 2200 FORMAT (1H , 1H-, A6, 1H-, /, A 1H , 8HFANA , 3E22.14, /, (1H , 8X, 3E22.14)) END m1pjxa.f000644 000311 000121 00000004432 06067233046 012250 0ustar00krivecf1000000 000000 SUBROUTINE M1PJXA(NDX, NDPJ, N, K, NX, XX, NOUT, PTEST, PJ) C IMPLICIT REAL * 8 (A - H, O - Z) C LOGICAL PTEST DIMENSION PJ(NDX,NDPJ), XX(NDX) C C C C (K,0) C CALCULATES JACOBI POLYNOMIALS P (X(I)), M, K INTEGER, C M C C M = 0, 1,..., N, I = 1,..., NX, BY THE STABLE UPWARD RECURSION. C THE ABOVE POLYNOMIAL VALUE IS IN THE LOCATION PJ(I,M+1). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M1PJXA' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C IF (K .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (N .LT. 0) CALL ERR2(NAME, 2, 1, NOUT) IF (N+1 .GT. NDPJ) CALL ERR2(NAME, 3, 1, NOUT) IF (NX .LT. 1) CALL ERR2(NAME, 4, 1, NOUT) IF (NX .GT. NDX) CALL ERR2(NAME, 5, 1, NOUT) C C C N = 0. DO 20 J = 1,NX PJ(J,1) = 1.D0 20 CONTINUE IF (PTEST) WRITE (NOUT,2100) NAME, 1 K, (J, XX(J), PJ(J,1), J = 1,NX) IF (N .EQ. 0) RETURN C C C N = 1. DO 30 J = 1,NX PJ(J,2) = 0.5D0 * (DFLOAT(K + 2) * XX(J) + K) 30 CONTINUE IF (PTEST) WRITE (NOUT,2110) NAME, 1 K, (J, XX(J), PJ(J,2), J = 1,NX) IF (N .EQ. 1) RETURN C C C N = 2,.... DO 50 I = 2,N ZZ1 = ((K + 2*I) - 1) * ((K + 2*I) - 2) * (K + 2*I) ZZ2 = ((K + 2*I) - 1) * K * K ZZ3 = -2*(K + I - 1) * (I - 1) * (K + 2*I) ZZ4 = 2 * I * (K + I) * ((K + 2*I) - 2) DO 40 J = 1,NX PJ(J,I+1) = ( (ZZ1 * XX(J) + ZZ2) * PJ(J,I) + 1 ZZ3 * PJ(J,I-1) ) / ZZ4 40 CONTINUE IF (PTEST) WRITE (NOUT,2120) NAME, 1 I, K, (J, XX(J), PJ(J,I+1), J = 1,NX) 50 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.2, 95/12/24. 1.1, 90/03/01. ) C ======================================== 2100 FORMAT ( A 1H , A6, 16H PJ, N = 0, K =, I4, /, B (1H , I4, 2F24.16)) 2110 FORMAT ( A 1H , A6, 16H PJ, N = 1, K =, I4, /, B (1H , I4, 2F24.16)) 2120 FORMAT ( A 1H , A6, 12H PJ, N =, I4, 6H, K =, I4, /, B (1H , I4, 2F24.16)) END m1sa.f000644 000311 000121 00000005002 06067233300 011674 0ustar00krivecf1000000 000000 SUBROUTINE M1SA(NDMU, NDS, NOUT, A MUU, IPOS, B NS, ISMN, ISIS, ISN) IMPLICIT REAL*8 (A-H, O-Z) C DIMENSION ISMN(2,NDS), ISIS(NDMU,NDMU), ISN(2,NDMU) C C C C C (MU, NU) PAIRS FOR ALL STATES. C C ON ENTRY: C NDMU DIMENSION - MAX. NO. OF MU. C NDS DIMENSION - MAX. NO. OF STATES. C NOUT OUTPUT LOGICAL UNIT NO. C MUU MAX. MU. C IPOS 0 ALL PAIRS, NU = (-MU, -MU+2,..., MU). C 1 POSITIVE-NU PAIRS, NU = C (MOD(MU,2),..., MU). C C ON EXIT: C NS NO. STATES. C ISMN(1,I) MU, I = 1,..., NS. C ISMN(2,I) NU, I = 1,..., NS. C ISIS(I,J) STATE INDEX FOR THE PAIR (MU, NU) WHERE C I = MU + 1, J = NU-VALUE COUNTER AT MU. C ISN(1,I) SMALLEST NU AT I = MU + 1. C ISN(2,I) NUMBER OF NU-VALUES AT I = MU + 1. C C DIMENSIONS ARE TESTED. C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M1SA ' / C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C C C IF (MUU .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) IF (MUU+1 .GT. NDMU) CALL ERR2(NAME, 2, 1, NOUT) IF (IPOS .NE. 0 .AND. IPOS .NE. 1) CALL ERR2(NAME, 3, 1, NOUT) C C C RESET MATRICES. C DO 10 I = 1,NDS ISMN(1,I) = 0 ISMN(2,I) = 0 10 CONTINUE DO 14 J = 1,NDMU ISN(1,J) = 0 ISN(2,J) = 0 DO 12 I = 1,NDMU ISIS(I,J) = 0 12 CONTINUE 14 CONTINUE C C C STATE COUNTER. C NSX = 0 MUU1 = MUU + 1 DO 22 MU1 = 1,MUU1 MU = MU1 - 1 C C SMALLEST NU. C NUL = -MU IF (IPOS .EQ. 1) NUL = MOD(MU, 2) C C NUMBER OF NU. C NUN = MU + 1 IF (IPOS .EQ. 1) NUN = MU / 2 + 1 ISN(1,MU1) = NUL ISN(2,MU1) = NUN DO 20 NU1 = 1,NUN NU = NUL + 2 * NU1 - 2 C C STATE. C NSX = NSX + 1 IF (NSX .GT. NDS) CALL ERR2(NAME, 4, 1, NOUT) ISMN(1,NSX) = MU ISMN(2,NSX) = NU ISIS(MU1,NU1) = NSX 20 CONTINUE 22 CONTINUE NS = NSX RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.2, 95/12/24. 1.1, 90/02/20. ) C ======================================== END m1xgqa.f000644 000311 000121 00000005261 06067230220 012236 0ustar00krivecf1000000 000000 SUBROUTINE M1XGQA(NDQ, NDGO, NDGO1, NDGO2, NDGO1Z, 1 N, NSI, A, B, 2 P, Z, AG, WG, AG1, WG1, PTESTG, 3 NOUT, 4 NQ, X, W) IMPLICIT REAL * 8 (A-H, O-Z) LOGICAL PTESTG DIMENSION AG1(NDGO), WG1(NDGO), X(NDQ), W(NDQ) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C MULTIPLE GAUSSIAN QUADRATURE POINTS AND WEIGHTS ON (A, B). C PRIMARY ABSCISSAS/WEIGHTS ARE CALCULATED IN EXTENDED PRECISION. C VALUES AGREE WITH THOSE OF ABRAMOWITZ/STEGUN EVEN FOR N = 96, C EXCEPT IN TWO INSTANCES WHERE THE 21-ST DIGIT AFTER COMMA C DIFFERS (MAYBE THE A/S BOOK HAS ERROS). C C ON ENTRY C N GAUSSIAN ORDER C NSI NUMBER OF SUBDIVISIONS OF (A, B) C A, B BOUNDS OF (A, B) C PTESTG TEST OUTPUT BY CGAUSS. C C ON EXIT C NQ FINAL NUMBER OF QUADRATURE POINTS. C X(I) I = 1,..., NQ, QUADRATURE POINTS. C W(I) I = 1,..., NQ, QUADRATURE WEIGHTS. C C THE REST ARE WORKING ARRAYS. C C CHARACTER*6 NAME DATA NAME / 'M1XGQA' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 91/07/11. O: M1XGA 1.0, 90/02/26. ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DATA LCALL0 / .TRUE. /, XTOL / 1.0D-10 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (N .LT. 2) CALL ERR2(NAME, 1, 1, NOUT) IF (N .GT. NDGO) CALL ERR2(NAME, 2, 1, NOUT) IF (N+1 .GT. NDGO1) CALL ERR2(NAME, 3, 1, NOUT) IF ((N+1)/2 .GT. NDGO2) CALL ERR2(NAME, 4, 1, NOUT) IF (N/2+2 .GT. NDGO1Z) CALL ERR2(NAME, 5, 1, NOUT) IF (N*NSI .GT. NDQ) CALL ERR2(NAME, 6, 1, NOUT) IF (NSI .LT. 1) CALL ERR2(NAME, 7, 1, NOUT) IF (B - A .LT. XTOL) CALL ERR2(NAME, 8, 1, NOUT) C C HALF OF GAUSSIAN POINTS FOR ORDER N. CALL GAUSCQ(NDGO2, NDGO1, NDGO1Z, 1 N, Z, P, AG, WG, NOUT, PTESTG) C C LOOP OVER SUBINTERVALS. H = (B - A) / NSI NQ = 0 DO 22 I = 1,NSI ASI = A + H * (I - 1) BSI = A + H * I IF (I .EQ. NSI) BSI = B CALL GAUSQ(NDGO2, NDGO, AG, WG, N, ASI, BSI, AG1, WG1, NOUT) C C ADD POINTS TO GRID. DO 20 J = 1,N NQ = NQ + 1 X(NQ) = AG1(J) W(NQ) = WG1(J) 20 CONTINUE 22 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) END m2b.f000644 000311 000121 00000066274 06067233457 011552 0ustar00krivecf1000000 000000 SUBROUTINE M2B(NDP0, NDP, NDMU, NDMUT, NDS, NDST, A NDG, NDFACT, NDAMN, B IPFL, IPFU, IPVL, IPVU, F, V, C IP0OFF, IP0XU, IPOFF, IPXU, D MUU, XOMEGA, XKAPPA, MUJ, CDF2R, CDF2I, E ISMN, ISIS, ISN, F ISMNT, ISIST, ISNT, G GNL, GN2L, FACT, GAMMA, ZETA, AMN, H CF, CV, TT, I NOUT, PTEST, PTEST1, PRES, J NS, EMW, EMWD) C IMPLICIT REAL*8 (A - H, O - Z) C LOGICAL PTEST, PTEST1, PRES DIMENSION F(3,NDP0), V(3,NDP0), XOMEGA(3), XKAPPA(3), 1 CDF2R(NDMUT,NDP,NDMUT), CDF2I(NDMUT,NDP,NDMUT), 2 ISMN(2,NDS), ISIS(NDMU,NDMU), ISN(2,NDMU), 3 ISMNT(2,NDST), ISIST(NDMUT,NDMUT), ISNT(2,NDMUT), 4 GNL(NDG), GN2L(NDG), FACT(NDFACT), 5 GAMMA(NDS,NDS), ZETA(NDS,NDS), AMN(3,NDAMN), 6 CF(NDMUT,NDP0,2), CV(NDMUT,NDP0,2), 7 TT(NDP0), 8 EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP) C C C C C MATRIX ELEMENTS AS MATRIX COEFFICIENTS OF A POWER SERIES, C FOR ANY SET OF POWERS (.GE. -2) AND ANY COEFFICIENTS OF F C AND V. THE HH EXPANSION OF -1/2 (DEL(F))**2 MUST BE C INPUT, FOR ALL SUMMATION STATES AND ALL NU. C C RESTRICTIONS: C C 1. L = 0. C - C 2. CALCULATES 2 W OF ANN. PHYS. 189, LIKE THE ORIGINAL C PROGRAM ME (THE MANDELZWEIG-HAFTEL CODE). C C C EXPANSION BASIS: C C INSTEAD OF FUNCTIONS Y(MU,NU;A,LAMBDA) (CF. ANN. PHYS., C VOL. 189) WHICH WOULD REQUIRE COMPLEX ALGEBRA, WE USE C THE REAL LINEAR COMBINATIONS C C C SQRT(2) RE Y(MU,NU;.,.), NU .GE. 0; C C R(MU,NU;A,LAMBDA) = RE Y(MU,0;.,.), NU = 0; C C SQRT(2) IM Y(MU,-NU;.,.), NU .LT. 0. C C C THE ORDERING OF (MU,NU) LABELS ON R IS THE SAME AS THE C ORDERING FOR Y . THE MATRIX ELEMENTS OF A FUNCTION G C IN THIS BASIS CAN BE EXPRESSED IN TERMS OF THE REAL AND C IMAGINARY PARTS OF THE EXPANSION COEFFICIENTS OF G IN C THE BASIS Y(MU,NU) , USING THE INVARIANCE OF GAMMA C AND ZETA COEFFICIENTS (CF. A.P. 189) WITH RESPECT TO C SIGN CHANGE OF ALL MAGNETIC (NU) QUANTUM NUMBERS. IF WE C DENOTE (M,N) = (MU,NU) ETC., AND TAKE ONLY NONNEGATIVE C N, ETC., THESE EXPRESSIONS ARE: C C G(R;M,N,MP,NP) SQRT((1+DELTA(NU,0)(1+DELTA(NUP,0))) = C SUM(MPP) ( GAMMA(MPP;M,N,MP,NP) RE G(Y;MPP,N-NP) C + (-1)**NP GAMMA(MPP;M,N,MP,-NP) RE G(Y;MPP,N+NP); C C G(R;M,N,MP,-NP) SQRT((1+DELTA(NU,0)(1+DELTA(NUP,0))) = C SUM(MPP) ( GAMMA(MPP;M,N,MP,NP) IM G(Y;MPP,N-NP) C - (-1)**NP GAMMA(MPP;M,N,MP,-NP) IM G(Y;MPP,N+NP); C C G(R;M,-N,MP,NP) SQRT((1+DELTA(NU,0)(1+DELTA(NUP,0))) = C SUM(MPP) ( - GAMMA(MPP;M,N,MP,NP) IM G(Y;MPP,N-NP) C - (-1)**NP GAMMA(MPP;M,N,MP,-NP) IM G(Y;MPP,N+NP); C C G(R;M,-N,MP,-NP) SQRT((1+DELTA(NU,0)(1+DELTA(NUP,0))) = C SUM(MPP) ( GAMMA(MPP;M,N,MP,NP) RE G(Y;MPP,N-NP) C - (-1)**NP GAMMA(MPP;M,N,MP,-NP) RE G(Y;MPP,N+NP). C C ARGUMENTS R AND Y DENOTE THE EXPANSION BASIS. (IN PART OF THE C OPERATOR OMEGA WE HAVE ZETA INSTEAD OF GAMMA; BUT THE C RELATIONS ARE THE SAME.) IN THE COMMENTS BELOW WE CALL C THESE GAMMAS AND ZETAS AS GAMMA1, GAMMA2, ZETA1, ZETA2. C C NOTE THAT (OF COURSE) NOT ALL G(Y;.,.) ON THE RHS ARE C MUTUALLY INDEPENDENT: C C NU * C G(Y;MU,-NU) = (-1) G(Y;MU,NU) , G REAL. C C WHEN THESE G(Y;.,.) ARE CALCULATED, THE ABOVE SYMMETRY C IS USED TO CALCULATE AND STORE ALL THE G(Y;.,.) C SO THAT WE HAVE A REDUNDANCY; BUT THIS MAKES C THE CALCULATION OF MATRIX ELEMENTS SIMPLER BECAUSE C THE PROGRAM DOES NOT HAVE TO ASK FOR THE SIGNS OF C N-NP , N+NP , AND TO MULTIPLY BY ADDITIONAL PHASE C FACTORS (SEE THE RHS OF THE ABOVE FORMULAS). C C C C VERSION DATE AND NUMBER: SEE FORMAT 1000. C C C FORMAL PARAMETERS C ================= C C C ON ENTRY C C (ALL OF THESE PARAMETERS ARE UNCHANGED ON RETURN.) C C NDP0 DIMENSION FOR THE UNION OF F, V POWERS C (SEE CALLING PROGRAM): MUST ACCOMODATE C ALL POWERS BETWEEN MIN(IPFL, IPVL) AND C MAX(IPFU, IPVU). C C NDP DIMENSION FOR THE POWERS OF THE FINAL MATRICES. C MUST ACCOMODATE IPXU POWERS. C C NDMU DIMENSION, AT LEAST MUU + 1, WHERE MUU IS THE C LARGEST MU IN THE STATES LABELLING THE MATRIX. C C NDMUT AS NDMU, BUT FOR THE SUMMATION STATES. C DERIVED (DERIVED MEANS THAT IT CAN BE CALCULATED C IN A PARAMETER STATEMENT IN THE CALLING PROGRAM). C C NDS DIMENSION FOR STATES LABELLING THE MATRIX; C DIMENSION OF THE FINAL MATRICES. DERIVED. C C NDST AS NDS, BUT FOR THE SUMMATION STATES. DERIVED. C C NDG DIMENSION FOR GAMMA FUNCTIONS. DERIVED. C C NDFACT DIMENSION FOR FACTORIALS. MAX. 960 ON VAX. C DERIVED. C C NDAMN DIMENSION FOR ANGULAR OPERATORS CONSTANTS C (APPEARING IN ZETA). DERIVED. C C IPFL SMALLEST POWER OF F. C C IPFU LARGEST POWER OF F. C C IPVL SMALLEST POWER OF V. C C IPVU LARGEST POWER OF F. C C F(K,I) THE COEFFICIENTS OF THE EXPANSION C F = SUM(K=1...3) SUM(P) R(K)**P F(K,I) C WHERE R(1) = R(2,3) ETC. ARE THE INTERPARTICLE C DISTANCES, AND I = P + IP0OFF. THE SUM(P) C RUNS OVER ALL POWERS ALTHOUGH SOME F MAY BE ZERO. C C V(K,I) THE COEFFICIENTS OF THE EXPANSION C V = SUM(K=1...3) SUM(P) R(K)**P V(K,I). C THEY MUST BE ALIGNED WITH F(K,I) (EQUAL C POWERS AT EQUAL POSITIONS I IN ARRAYS), C ALTHOUGH SOME V MAY BE ZERO. C C IP0OFF POWER OFFSET OF THE INPUT F, V ARRAYS. C USED TO CALCULATE INDEX I OF F, V ARRAYS AS C I = IP + IP0OFF, WHERE IP IS THE POWER. C MUST EQUAL 1 - MIN(IPFL, IPFV). C C IP0XU NUMBER OF F, V POWERS. MUST BE AT LEAST C MAX(IPFU, IPVU) - MIN(IPFL, IPVL) + 1. C C IPOFF OFFSET OF POWERS OF THE FINAL MATRICES. C ARRAY INDEX = POWER + OFFSET. C C IPXU NUMBER OF POWERS IN THE FINAL MATRICES. C THE ARRAY INDEX WHICH COUNTS THE POWERS C GOES FROM 1 TO IPXU, AND THE POWERS ARE C AS ABOVE (POWER = INDEX - IPOFF). C C MUU MAX. MU, MUP. DETERMINES THE NUMBER OF C STATES AND THEREFORE THE DIMENSION OF THE C FINAL MATRICES. C C XOMEGA THE QUASI-DALITZ CONSTANTS OMEGA(I,J) OF C ANN. PHYS. 189, ORDERED AS (2,3), (3,1), (1,2). C C XKAPPA THE QUASI-DALITZ CONSTANTS KAPPA(I,J) OF C ANN. PHYS. 189, ORDERED AS (2,3), (3,1), (1,2). C C MUJ MAXIMUM MU OF CDF2R/I. THIS IS CHECKED TO C BE .GE. MUTU = 2 * MUU (SUMMATION STATES). C NO OTHER CHECKS ARE POSSIBLE ON CDF2R/I. C C CDF2R/I THE HH EXPANSION OF -1/2 DEL(F)**2 . C IT MUST CONTAIN THE REAL AND IMAGINARY PARTS C OF THE COEFFICIENTS FOR EXPANSION INTO THE Y C BASIS FOR ALL SUMMATION STATES; THEREFORE DUE TO C THE SYMMETRY OF THESE COEFFICIENTS FOR C NU AND -NU ALSO THE LINEARLY DEPENDENT C VALUES MUST BE INPUT; SEE INTRODUCTION ABOVE. C C ISMN, C ISIS, C ISN WORKING ARRAYS FOR STATE LABELS WITHOUT C SYMMETRIZATION. SEE M1SA. CAN BE USED ON RETURN. C C ISMNT, C ISIST, C ISNT WORKING ARRAYS FOR SUMMATION STATE LABELS. C SEE M1SA. CAN BE USED ON RETURN. C C GNL, C GN2L WORKING ARRAYS FOR THE GAMMA FUNCTIONS. C C FACT WORKING ARRAY FOR FACTORIALS. C C GAMMA, C ZETA WORKING ARRAYS FOR GAMMA, ZETA COEFFICIENTS. C C AMN WORKING ARRAY FOR ANGULAR OPERATOR COEFFICIENTS. C C CF, C CV, C TT WORKING ARRAYS FOR HH EXPANSIONS OF F, V. C CF, CV CAN BE USED ON RETURN. C C NOUT PRINTED OUTPUT LOGICAL UNIT NO. C C PTEST TEST OUTPUTS (DO NOT USE AT LARGE C DIMENSIONS BECAUSE FOR TESTING PURPOSES FULL C MATRICES ARE PRINTED). C C PTEST1 TEST OUTPUTS BY M11A. C C PRES PRINTS RESULTS. C C C ON RETURN C C NS NUMBER OF STATES (OUTPUT MATRIX ACTUAL SIZE). C C EMW(I,J,K) MATRIX OF 2*W-BAR OF ANN. PHYS. 189, C WITHOUT THE DERIVATIVE TERM, WHERE C I = 1,..., NS COUNTS STATES (MU,NU), C J = 1,..., NS COUNTS STATES (MUP,NUP), AND C K = 1,..., IPXU COUNTS POWERS (SEE ABOVE). C C EMWD(I,J,K) MATRIX OF THE DERIVATIVE TERM. THE FULL RESULT C IS EMW + EMWD * D/D(RHO). C C C C C EXTERNALS LOGICAL TRICO REAL*8 M11A, CLEB1 C C C INTERNAL DECLARATIONS LOGICAL LXV, LXLF, LXDF2, LXOS, LXOD, LXD C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'M2B ' / C IF (LCALL0) WRITE (NOUT,1000) NAME IF (LCALL0) LCALL0 = .FALSE. C C C C C DIMENSION TEST FOR THE NUMBER OF POWERS IN THE HH C EXPANSION COEFFICIENTS AND FINAL MATRIX ELEMENTS. C ================================================= C C IF (IPXU .GT. NDP) CALL ERR2(NAME, 11, 1, NOUT) C C C CHECK THE VALUES OF IP0OFF, IP0XU. C ================================== C C IP0L = MIN(IPFL, IPVL) IP0U = MAX(IPFU, IPVU) IF (IP0OFF .NE. 1-IP0L) CALL ERR2(NAME, 21, 1, NOUT) IF (IP0XU .LT. IP0U-IP0L+1) CALL ERR2(NAME, 22, 1, NOUT) IF (IP0XU .GT. NDP0) CALL ERR2(NAME, 23, 1, NOUT) IF (IPOFF .LT. IP0OFF) CALL ERR2(NAME, 24, 1, NOUT) C C C OTHER PARAMETERS. C ================= C C C FACTORIALS. NFACT MUST BE MAX(J1 + J2 + J + 2) OF CG COEFFICIENTS. NFACT = 4 * MUU/2 + 2 IF (NFACT .GT. NDFACT) CALL ERR2(NAME, 31, 1, NOUT) C C C RESET. C (FACT MUST NOT BE RESET - THIS IS FATAL). C ========================================= C C DO 2000 I = 1,NDG GNL(I) = 0.D0 GN2L(I) = 0.D0 2000 CONTINUE DO 2030 I = 1,NDAMN AMN(3,I) = 0.D0 2030 CONTINUE DO 2070 K = 1,NDP DO 2050 J = 1,NDS DO 2040 I = 1,NDS EMW(I,J,K) = 0.D0 EMWD(I,J,K) = 0.D0 2040 CONTINUE 2050 CONTINUE 2070 CONTINUE C C C GENERATE STATES ETC. C ==================== C C C STATES (ALL NU). CALL M1SA(NDMU, NDS, NOUT, 1 MUU, 0, 2 NS, ISMN, ISIS, ISN) C C C STATES FOR SUMMATION (ALL NU). MUTU = 2 * MUU IF (MUTU .GT. MUJ) CALL ERR2(NAME, 43, 1, NOUT) CALL M1SA(NDMUT, NDST, NOUT, 1 MUTU, 0, 2 NST, ISMNT, ISIST, ISNT) C C C COEFFICIENTS A(ALPHA;MUT,NUT) FOR SUMMATION STATES C (THEY ARE NEEDED TO CALCULATE ZETA). CALL M1AMNA(NDST, NDAMN, NOUT, 1 NST, ISMNT, 2 AMN) IF (.NOT.PTEST) GO TO 2110 WRITE (NOUT,2112) NAME DO 2100 J = 1,NST MUT = ISMNT(1,J) NUT = ISMNT(2,J) WRITE (NOUT,2114) J, MUT, NUT, 1 (AMN(I,(MUT*(MUT+1)+(MUT+NUT))/2+1), I = 1,3) 2100 CONTINUE 2110 CONTINUE C C C GAMMA FUNCTIONS. C ================ C C NG = MUTU + (IP0U + 1) / 2 + 3 CALL GF2(NDG, NG, NOUT, GNL, GN2L) C C C LOOP OVER MUT (OUTERMOST LOOP). (T = DOUBLE PRIME.) C =================================================== C C MUT1U = 2 * MUU + 1 DO 6060 MUT1 = 1,MUT1U MUT = MUT1 - 1 C C C RESET. DO NOT RESET CDF2R/I (INPUT). DO 3004 K = 1,NDP0 DO 3002 I = 1,NDMUT CF(I,K,1) = 0.D0 CF(I,K,2) = 0.D0 CV(I,K,1) = 0.D0 CV(I,K,2) = 0.D0 3002 CONTINUE TT(K) = 0.D0 3004 CONTINUE C C C NU-INDEPENDENT FACTOR FOR R(I,J)**IP0 EXPANSION. C LOOP OVER POWERS OF F, V ONLY. DO 3010 IP0X = 1,IP0XU IP0 = IP0X - IP0OFF TT(IP0X) = M11A(NDG, NOUT, PTEST1, 1 NG, GNL, GN2L, MUT, IP0) IF (PTEST) WRITE (NOUT,3012) NAME, 1 NDG, NG, MUT, IP0X, IP0, TT(IP0X) 3010 CONTINUE C C C CALCULATE GAMMAS AND ZETAS. C FOR ALL ((MU,NU); (MUP,NUP)), FIXED MUT. C ---------------------------------------- C C C (NO REPETITION.) C CLEBSCH-GORDAN COEFFICIENTS CALL: C(L1,L2,L,M1,M2,M). C RESET. DO 3030 ISP = 1,NS DO 3020 IS = 1,NS GAMMA(IS,ISP) = 0.D0 ZETA(IS,ISP) = 0.D0 3020 CONTINUE 3030 CONTINUE DO 3060 IS = 1,NS MU = ISMN(1,IS) NU = ISMN(2,IS) C C C SKIP IF NU .LT. 0 ; NEVER USED (SEE INTRODUCTION ABOVE). IF (NU .LT. 0) GO TO 3060 DO 3050 ISP = 1,NS MUP = ISMN(1,ISP) NUP = ISMN(2,ISP) C C C TEST MUP AT FIXED MU , MUT . C TRICO USES TRIANGULAR AND PARITY TESTS. C MAGNETIC QUANTUM NUMBERS ARE NOT TESTED HERE. C CLEB1 TESTS ALL THE QUANTUM NUMBERS. IF (.NOT.TRICO(MU, MUP, MUT)) GO TO 3050 NUT = NU - NUP ZZ1 = 1 DFLOAT(1 - 2*MOD(IABS(MUP-MU-3*MUT)/2,2)) * 2 SQRT( DFLOAT((MUT+1)*(MUP+1)) / 3 (CDXPI()**3 * DFLOAT(MU+1)) ) ZZ2 = 1 CLEB1(NDFACT, NFACT, FACT, 2 0.5D0*DFLOAT(MUP), 3 0.5D0*DFLOAT(MUT), 4 0.5D0*DFLOAT(MU), 5 0.5D0*DFLOAT(NUP), 6 0.5D0*DFLOAT(NUT), 7 0.5D0*DFLOAT(NU) ) GAMMA(IS,ISP) = ZZ1 * ZZ2 * ZZ2 C C C AMN IS LOWER-TRIANGLE-STORED IN (MU-,NU-). ZZ3 = 0.D0 DO 3040 I = 1,3 IF ((IABS(NUP-2*(I-2)) .GT. MUP) .OR. 1 (IABS(NUT+2*(I-2)) .GT. MUT)) GO TO 3040 ZZ3 = ZZ3 + 1 AMN(I,(MUT*(MUT+1)+(MUT+NUT))/2+1) * 2 AMN(4-I,(MUP*(MUP+1)+(MUP+NUP))/2+1) * 3 CLEB1(NDFACT, NFACT, FACT, 4 0.5D0*DFLOAT(MUP), 5 0.5D0*DFLOAT(MUT), 6 0.5D0*DFLOAT(MU), 7 0.5D0*DFLOAT(NUP-2*(I-2)), 8 0.5D0*DFLOAT(NUT+2*(I-2)), 9 0.5D0*DFLOAT(NU) ) * ZZ2 3040 CONTINUE ZETA(IS,ISP) = 4.D0 * ZZ1 * ZZ3 IF (PTEST) WRITE (NOUT,3052) NAME, 1 MUT, IS, MU, NU, ISP, MUP, NUP, 2 GAMMA(IS,ISP), ZETA(IS,ISP) 3050 CONTINUE 3060 CONTINUE C C C LOOP OVER NUT TO CALCULATE HH EXPANSIONS OF F, V, C FOR EACH POWER IP0 , EACH NUT , FOR FIXED MUT . C THE EXPANSION BASIS IS Y (ANN. PHYS. VOL. 189). C NOTE THAT BECAUSE OF SYMMETRY THERE IS REDUNDANCY, BUT C THIS MAKES THE REST OF THE PROGRAM SIMPLER (SEE C INTRODUCTION ABOVE; ONLY THE NONNEGATIVE-NU COEFFICIENTS C ARE INDEPENDENT). C -------------------------------------------------------- C C NUTXU = ISNT(2,MUT1) DO 4020 NUTX = 1,NUTXU NUT = ISNT(1,MUT1) + 2 * NUTX - 2 C C C PHASE (-1)**((3 MUT - NUT)/2). PH0 = DFLOAT(1 - 2 * MOD(IABS(3*MUT - NUT)/2, 2)) C C C LOOP OVER POWERS OF F, V. DO 4010 IP0X = 1,IP0XU C POWER. IP0 = IP0X - IP0OFF C C C NUT-DEPENDENT FACTORS FOR F, V (REPETITIONS C BECAUSE THEY ARE INDEPENDENT OF MUT ; COMPLEX). CALL M12A(NOUT, 1 XOMEGA, XKAPPA, F(1,IP0X), NUT, IP0, 2 XFR, XFI) CALL M12A(NOUT, 1 XOMEGA, XKAPPA, V(1,IP0X), NUT, IP0, 2 XVR, XVI) IF (PTEST) WRITE (NOUT,4012) NAME, 1 MUT, NUT, IP0X, IP0, XFR, XFI, XVR, XVI C C C IP0-TH COEFFICIENTS OF F, V. CF(NUTX,IP0X,1) = (PH0 * TT(IP0X)) * XFR CF(NUTX,IP0X,2) = (PH0 * TT(IP0X)) * XFI CV(NUTX,IP0X,1) = (PH0 * TT(IP0X)) * XVR CV(NUTX,IP0X,2) = (PH0 * TT(IP0X)) * XVI 4010 CONTINUE 4020 CONTINUE IF (.NOT.PTEST) GO TO 4040 C C C TEST OUTPUT. WRITE (NOUT,4032) MUT DO 4030 K = 1,IP0XU WRITE (NOUT,4034) K WRITE (NOUT,4036) 1 (I, CF(I,K,1), CF(I,K,2), 2 CV(I,K,1), CV(I,K,2), I = 1,NUTXU) 4030 CONTINUE 4040 CONTINUE C C C CALCULATE THE CONTRIBUTION TO THE MATRIX ELEMENTS C FOR THE CURRENT MUT , FOR ALL OPERATORS, ALL C ((MU,NU), (MUP,NUP)), AT EACH IP. C ------------------------------------------------- C C DO 6050 IPX = 1,IPXU C POWER. IP = IPX - IPOFF C C C INDEX OF CF, CV ARRAYS FOR POWER IP. IP0X = IP + IP0OFF C C C DEFINE THE LOGICAL VARIABLES DECIDING WHETHER A C GIVEN OPERATOR CONTRIBUTES FOR POWER IP. LXV = (IP .GE. IPVL) .AND. (IP .LE. IPVU) LXLF = (IP .GE. IPFL-2) .AND. (IP .LE. IPFU-2) LXDF2 = (IP .GE. 2*IPFL-2) .AND. (IP .LE. 2*IPFU-2) LXOS = LXLF LXOD = (IP .GE. IPFL-1) .AND. (IP .LE. IPFU-1) LXD = LXLF C C C CONSTANTS. ZXLF = -0.5D0 * DFLOAT((IP+2)*(IP+6) - 2*MUT*(2*MUT+4)) ZXOD = -DFLOAT(IP+1) ZXD = DFLOAT(2*(IP+2)) C C C STATES. LOOPS RUN OVER ALL STATES; THE SIGNS OF C NU , NUP ARE TESTED TO CHOOSE THE CORRECT FORMULA; C SEE INTRODUCTION. DO 6040 ISP = 1,NS MUP = ISMN(1,ISP) NUP = ISMN(2,ISP) C C C (MUP,ABS(NUP)), (MUP,-ABS(NUP)) STATE NUMBERS C FOR GAMMA, ZETA. NUP1X = ( IABS(NUP) - ISN(1,MUP+1)) / 2 + 1 NUP2X = (-IABS(NUP) - ISN(1,MUP+1)) / 2 + 1 ISP1 = ISIS(MUP+1,NUP1X) ISP2 = ISIS(MUP+1,NUP2X) C C C RHS NORMALIZATION FACTOR. ZZZ01 = 1.D0 IF (NUP .EQ. 0) ZZZ01 = SQRT(0.5D0) C C C PHASE FACTOR FOR GAMMA2, ZETA2 TERMS. ZZZ0 = 1 - 2 * MOD(IABS(NUP), 2) DO 6030 IS = 1,NS MU = ISMN(1,IS) NU = ISMN(2,IS) C C C TEST MU AT FIXED MUP , MUT . C ABS(NU) +- ABS(NUP) MUST BE TESTED SEPARATELY C IN ORDER NOT TO EXCEED MUT . C THE MAGNETIC NUMBER TEST HERE IS THE WEAKER ONE C (FOR MINUS SIGN). PLUS SIGN: SEE BELOW ( NUT2X ). IF (.NOT.TRICO(MU, MUP, MUT)) GO TO 6030 IF (IABS(IABS(NU)-IABS(NUP)) .GT. MUT) GO TO 6030 C C C (MU,ABS(NU)) STATE NUMBER FOR GAMMA, ZETA. NU1X = (IABS(NU) - ISN(1,MU+1)) / 2 + 1 IS1 = ISIS(MU+1,NU1X) C C C FULL (BRA-KET) NORMALIZATION FACTOR. C IT INCLUDES THE ADDITIONAL FACTOR 2 TO C MAKE THE FINAL RESULT EQUAL TO 2*W . ZZZ02 = ZZZ01 IF (NU .EQ. 0) ZZZ02 = ZZZ01 * SQRT(0.5D0) ZZZ02 = 2.D0 * ZZZ02 C C C ARRAY INDICES OF NUT1 = ABS(NU) - ABS(NUP), C NUT2 = ABS(NU) + ABS(NUP). C ABS(NUT1) IS TESTED ABOVE NOT TO EXCEED MUT . C ABS(NUT2) MAY STILL EXCEED MUT ; TESTED LATER. NUT1X = 1 ((IABS(NU) - IABS(NUP)) - ISNT(1,MUT1)) / 2 + 1 NUT2X = 1 ((IABS(NU) + IABS(NUP)) - ISNT(1,MUT1)) / 2 + 1 C C C PHASES AND REAL/IMAGINARY POINTERS FOR F , V . IF (.NOT.(NU.GE.0 .AND. NUP.GE.0)) GO TO 5010 ZZZ1 = 1.D0 ZZZ2 = ZZZ0 IRI = 1 GO TO 5040 5010 CONTINUE IF (.NOT.(NU.GE.0 .AND. NUP.LT.0)) GO TO 5020 ZZZ1 = 1.D0 ZZZ2 = - ZZZ0 IRI = 2 GO TO 5040 5020 CONTINUE IF (.NOT.(NU.LT.0 .AND. NUP.GE.0)) GO TO 5030 ZZZ1 = - 1.D0 ZZZ2 = - ZZZ0 IRI = 2 GO TO 5040 5030 CONTINUE IF (.NOT.(NU.LT.0 .AND. NUP.LT.0)) GO TO 5040 ZZZ1 = 1.D0 ZZZ2 = - ZZZ0 IRI = 1 5040 CONTINUE C C C CONTRIBUTIONS OF DIFFERENT OPERATORS TO W. C INITIALIZE. ZX11 = 0.D0 ZX12 = 0.D0 ZX21 = 0.D0 ZX22 = 0.D0 C C C TERMS CONTAINING GAMMA1 AND GAMMA2, EXCEPT C THE D/D(RHO) PART OF OMEGA. C (V, -1/2 LAPLACEAN(F), -1/2 DEL(F)**2, C (2/RHO) D/D(RHO).) C CDF2R/I IS INPUT. C C NUT1X ALREADY TESTED. IF (LXV) ZX11 = 1 ZX11 + CV(NUT1X,IP0X,IRI) IF (LXLF) ZX11 = 1 ZX11 + ZXLF * CF(NUT1X,IP0X+2,IRI) IF (LXDF2 .AND. IRI.EQ.1) ZX11 = 1 ZX11 + CDF2R(NUT1X,IPX,MUT1) IF (LXDF2 .AND. IRI.EQ.2) ZX11 = 1 ZX11 + CDF2I(NUT1X,IPX,MUT1) IF (LXD) ZX11 = 1 ZX11 + ZXD * CF(NUT1X,IP0X+2,IRI) C C C SKIP IF NUT2X IS TOO LARGE. IF (NUT2X .GT. MUT+1) GO TO 6020 IF (LXV) ZX12 = 1 ZX12 + CV(NUT2X,IP0X,IRI) IF (LXLF) ZX12 = 1 ZX12 + ZXLF * CF(NUT2X,IP0X+2,IRI) IF (LXDF2 .AND. IRI.EQ.1) ZX12 = 1 ZX12 + CDF2R(NUT2X,IPX,MUT1) IF (LXDF2 .AND. IRI.EQ.2) ZX12 = 1 ZX12 + CDF2I(NUT2X,IPX,MUT1) IF (LXD) ZX12 = 1 ZX12 + ZXD * CF(NUT2X,IP0X+2,IRI) 6020 CONTINUE C C C TERMS CONTAINING ZETA1, ZETA2. C (-OMEGA, SCALAR PART.) IF (LXOS) 1 ZX21 = CF(NUT1X,IP0X+2,IRI) IF (LXOS .AND. (NUT2X .LE. MUT+1)) 1 ZX22 = CF(NUT2X,IP0X+2,IRI) C C C CONTRIBUTION TO 2*W (NORMALIZED). EMW(IS,ISP,IPX) = EMW(IS,ISP,IPX) + 1 ZZZ02 * 2 (ZZZ1 * (ZX11 * GAMMA(IS1,ISP1) + 3 ZX21 * ZETA(IS1,ISP1) ) + 4 ZZZ2 * (ZX12 * GAMMA(IS1,ISP2) + 5 ZX22 * ZETA(IS1,ISP2) ) ) C C C CONTRIBUTION TO 2*WD (NORMALIZED). C (-OMEGA, D/D(RHO) PART.) IF (.NOT.LXOD) GO TO 6030 ZX3 = 1 ZZZ1 * GAMMA(IS1,ISP1) * CF(NUT1X,IP0X+1,IRI) IF (NUT2X .LE. MUT+1) ZX3 = ZX3 + 1 ZZZ2 * GAMMA(IS1,ISP2) * CF(NUT2X,IP0X+1,IRI) EMWD(IS,ISP,IPX) = EMWD(IS,ISP,IPX) + 1 ZZZ02 * ZXOD * ZX3 6030 CONTINUE 6040 CONTINUE 6050 CONTINUE 6060 CONTINUE IF (.NOT.(PTEST .OR. PRES)) GO TO 9230 C C C OUTPUT: IF TEST OR IF EXPLICITLY REQUIRED (TRANSPOSED). WRITE (NOUT,9102) KU = IPXU JU = NS IU = NS IF (PTEST) KU = NDP IF (PTEST) JU = NDS IF (PTEST) IU = NDS DO 9120 K = 1,KU WRITE (NOUT,9104) K DO 9110 J = 1,JU WRITE (NOUT,9106) J, (EMW(I,J,K), I = 1,IU) 9110 CONTINUE 9120 CONTINUE WRITE (NOUT,9202) DO 9220 K = 1,KU WRITE (NOUT,9204) K DO 9210 J = 1,JU WRITE (NOUT,9206) J, (EMWD(I,J,K), I = 1,IU) 9210 CONTINUE 9220 CONTINUE 9230 CONTINUE RETURN C C 1000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.3, 95/12/24. 1.2, 90/06/12. ) C ======================================== 4032 FORMAT (////, A 1H , 16HCF, CV , 8H MUT = , I4) 4034 FORMAT (//, A 1H , 16H POWER INDEX , I4, //, B 1H , 40H NUTX RE CF IM CF, C 32H RE CV IM CV) 4036 FORMAT ( A 1H , I8, 4F16.8) 9102 FORMAT (////, A 1H , 16HEMW ) 9202 FORMAT (////, A 1H , 16HEMWD ) 9104 FORMAT (//, A 1H , 16H POWER INDEX , I4, //, B 1H , 40H J EMW(I,J,POWER), I = ... ) 9204 FORMAT (//, A 1H , 16H POWER INDEX , I4, //, B 1H , 40H J EMWD(I,J,POWER), I = ... ) 9106 FORMAT ( A 1H , I4, 5F12.6, /, (1H , 4X, 5F12.6)) 9206 FORMAT ( A 1H , I4, 5F12.6, /, (1H , 4X, 5F12.6)) 3012 FORMAT ( A 1H , A6, 28HNDG,NG,MUT,IPX,IP,TT(IPX) , 5I4, F16.8) 4012 FORMAT ( A 1H , A6, 28HMUT,NUT,IPX,IP,XFR/I,XVR/I , /, B 1H , 12X, 4I4, 4F12.6) 3052 FORMAT ( A 1H , A6, 40HMUT, IS,MU,NU, ISP,MUP,NUP, GAMMA, ZETA , /, B 1H , 12X, I4, 2(2X, 3I4), 2F16.8) 2112 FORMAT (/, A 1H , A6, 40HJ, MUT, NUT, AMN(-1), AMN(0), AMN(1) ) 2114 FORMAT ( A 1H , 12X, 3I4, 3F16.8) END m2ofqc.f000644 000311 000121 00000037140 06067230257 012242 0ustar00krivecf1000000 000000 SUBROUTINE M2OFQC(NDP0, NDP, NDMUT, NDSJ, NDPJ, NDQA, NDQL, 1 NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 2 IP0OFF, IPFL, IPFU, IPVL, IPVU, MUTU, 3 NGOA, NSUBA, NGOL, NSUBL, DAS, DLS, 4 XKAPPA, XOMEGA, F, IPXU, IPOFF, 5 NOUT, PT0, PT1, PRES, PTG, PTGA, PTGL, PTJ, 6 ISMNJ, ISISJ, ISNJ, ZFA, ZFL, AUX, 7 YAX, YLX, PJ, P, Z, AG, WG, AG1, WG1, 8 QA, XSI, WSI, NQA, XA, WA, NQL, XL, WL, 9 NSJ, CDF2R, CDF2I) C IMPLICIT REAL*8 (A-H, O-Z) C LOGICAL PT0, PT1, PRES, PTG, PTGA, PTGL, PTJ DIMENSION NGOA(2), NSUBA(2), NGOL(10,2), NSUBL(10,2), 1 XKAPPA(3), XOMEGA(3), F(3,NDP0), 2 ISMNJ(2,NDSJ), ISISJ(NDMUT,NDMUT), ISNJ(2,NDMUT), 3 ZFA(NDQA,4), ZFL(NDQL,6), AUX(3,NDP0), 4 YAX(NDQA,NDSJ), YLX(NDQL,NDMUT,2), PJ(NDQA,NDPJ), 5 AG1(NDGO), WG1(NDGO), 6 QA(NDSJ,NDP), XSI(NDQSI), WSI(NDQSI), 7 XA(NDQA), WA(NDQA), XL(NDQL,2), WL(NDQL,2), 8 CDF2R(NDMUT,NDP,NDMUT), CDF2I(NDMUT,NDP,NDMUT) C ************** REAL*16 P(NDGO1), Z(NDGO1Z), AG(NDGO2), WG(NDGO2) C ************** C C C HH EXPANSION OF -1/2 OMEGA(F) TO BE USED BY M2- TO C CALCULATE MATRIX ELEMENTS OF THIS OPERATOR. C THIS ROUTINE CALCULATES THE REAL AND IMAGINARY PARTS OF THE C EXPANSION COEEFICIENTS INTO THE FUNCTIONS Y ; SEE A MORE C DETAILED DISCUSSION BELOW. C C NUMERICAL GAUSSIAN INTEGRATION OF ANY ORDER C (AUTOMATIC GENERATION OF ABSCISSAS AND WEIGHTS). C C MODELLED AFTER F0NUM BY M. HAFTEL, EXTENDED FOR ANY C POWER SERIES OF F (ALSO UNSYMMETRIC CASES) AND ANY MASSES. C C C RESTRICTIONS: C C 1. L = 0. C C 2. GRID IN LAMBDA IS THE SAME FOR ALL VALUES OF A C (NGOL(.,2), NSUBL(.,2) IGNORED; IT IS AN C EMPIRICAL RESULT OF EARLIER VERSIONS THAT IT IS C SUFFICIENT TO KEEP A UNIFORM LAMBDA GRID (M. HAFTEL)). C C C THE EXPANSION BASIS IS Y (ANN. PHYS. VOL. 189) (NOT R , C THE REAL LINEAR COMBINATIONS, CF. ROUTINE M2- ); THE C REASON IS THAT THE FINAL MATRIX ELEMENTS (CALCULATED BY M2- ) C ARE EXPRESSED SIMPLY IN TERMS OF THE REAL AND IMAGINARY PARTS C OF THE EXPANSION COEFFICIENTS INTO THE ORIGINAL Y . THESE C PARTS OF THE COEFFICIENTS DIFFER FROM COEFFICIENTS IN THE C BASIS R ONLY BY A FACTOR OF SQRT(2) . C C NOTE THAT ONE COULD CALCULATE AND RETURN ONLY THE LINEARLY C INDEPENDENT COEFFICIENTS, I.E., THOSE FOR NONNEGATIVE NU ; C BUT THE REDUNDANCY IS REQUIRED BY M2- TO KEEP M2- SLIGHTLY C SIMPLER. C C M2OFQB: THIS VERSION ELIMINATES REPETITIONS OCCURRING IN M2OFA . C M2OFQC: THIS VERSION ELIMINATES REPETITIONS IN DEFINITION OF AUX . C C CHARACTER*6 NAME DATA NAME / 'M2OFQC' / CHARACTER*60 VERS DATA VERS */ ' 1.1, 95/08/30. O: 1.0; -B 1.0, 91/07/11. (TEST OUTPUT) ' / C ------------------------------------------------------------ C LOGICAL LCALL0 DIMENSION NQLX(2), ZFAL(9) DATA LCALL0 / .TRUE. /, A ZERO, ONE, TWO, HALF / 0.D0, 1.D0, 2.D0, 0.5D0 / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C DIMENSION TEST OF NUMBER OF POWERS IN THE FINAL MATRIX ELEMENTS. IF (IPXU .GT. NDP) CALL ERR2(NAME, 11, 1, NOUT) C C CHECK THE VALUE OF IP0OFF. IP0L = MIN(IPFL, IPVL) IP0U = MAX(IPFU, IPVU) IF (IP0OFF .NE. 1-IP0L) CALL ERR2(NAME, 21, 1, NOUT) IF (IPOFF .LT. IP0OFF) CALL ERR2(NAME, 22, 1, NOUT) C C OTHER CHECKS. IF (IPFU-IPFL+1 .GT. NDP0) CALL ERR2(NAME, 31, 1, NOUT) IF (MUTU+1 .GT. NDMUT) CALL ERR2(NAME, 32, 1, NOUT) C OTHER DIMENSIONS ARE TESTED IN SUBROUTINES. C C C CALCULATE THE GRID. C =================== C CALL M1ARQA(NDQA, NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 DAS, NGOA, NSUBA, 2 P, Z, AG, WG, AG1, WG1, PTGA, PTG, 3 XSI, WSI, NOUT, 4 NQA, XA, WA) CALL M1LRQA(NDQL, NDQSI, NDGO, NDGO1, NDGO2, NDGO1Z, 1 XOMEGA, DLS, NGOL, NSUBL, 2 P, Z, AG, WG, AG1, WG1, PTGL, PTG, 3 XSI, WSI, NOUT, 4 NQLX, XL, WL) NQL = NQLX(1) IF (PT0 .AND. PTG) WRITE (NOUT,2100) NAME, 1 (I, XA(I), WA(I), I = 1,NQA) IF (PT0 .AND. PTG) WRITE (NOUT,2110) NAME, 1 (I, XL(I,1), WL(I,1), I = 1,NQL) C C C FUNCTIONS OF A. C =============== C C AUXILIARY FUNCTIONS OF A. DO 12 I = 1,NQA ZFA(I,1) = COS(XA(I)) ZFA(I,2) = SIN(XA(I)) ZFA(I,3) = COS(TWO * XA(I)) ZFA(I,4) = SIN(TWO * XA(I)) 12 CONTINUE IF (PT0) WRITE (NOUT,2120) NAME, 1 (I, (ZFA(I,J), J = 1,4), I = 1,NQA) C C JACOBI POLYNOMIALS FOR ALL REQUIRED STATES, ALL A. LOOP OVER C NONNEGATIVE NU ; AT EACH NU ALL JACOBI POLYNOMIALS FOR C MU .LE. NU ARE CALCULATED BY RECURSION. C NOTE THAT NONNEGATIVE NU HERE ARE TAKEN BECAUSE OF JACOBI C POLYNOMIALS; THE NEGATIVE-NU QUANTITIES WILL BE OBTAINED C FROM SYMMETRY. CALL M1SA(NDMUT, NDSJ, NOUT, 1 MUTU, 1, 2 NSJ, ISMNJ, ISISJ, ISNJ) ZZA = HALF * (HALF * CDXPI()**2) / SQRT(CDXPI()**3) IF (PT0) WRITE (NOUT,2120) NAME, 1 (I, (ZFA(I,J), J = 1,4), I = 1,NQA) C C NU CAN HAVE ANY PARITY (ALL CONTIGUOUS NU .GE. 0). NU1U = MUTU+1 DO 24 NU1 = 1,NU1U NU = NU1 - 1 C C LARGEST (MU - NU) / 2 FOR GIVEN NU (VALID FOR ODD AND C EVEN MU, NU). NJ = (MUTU - NU) / 2 CALL M1PJXA(NDQA, NDPJ, NJ, NU, NQA, ZFA(1,3), 1 NOUT, PTJ, PJ) IF (PT0) WRITE (NOUT,2400) NAME, NU, NJ C C STORE ACCORDING TO THE ISISJ SEQUENCE OF STATES. C MULTIPLY BY C (1/2) (PI**2/2) ((MU + 1)/PI**3)**1/2 SIN(2A) (SIN A)**NU, C TO GET YAX SUCH THAT C (1/2) RE(Y(MU,NU)*) SIN(2A) = COS(LAMBDA NU) YAX(A), C (1/2) IM(Y(MU,NU)*) SIN(2A) = -SIN(LAMBDA NU) YAX(A), C WHERE THE ADDITIONAL FACTOR OF 1/2 IS INCLUDED IN ORDER C FOR THE RESULT TO BE (1/2)(-OMEGA(F)); ONLY NONNEGATIVE C NU APPEAR. NJ1 = NJ + 1 DO 20 J = 1,NJ1 C MU HAS THE SAME PARITY AS NU. MU = 2 * (J - 1) + NU ZZB = SQRT(DBLE(MU + 1)) * ZZA NUX = (NU - ISNJ(1,MU+1)) / 2 + 1 ISJ = ISISJ(MU+1,NUX) IF (PT0) WRITE (NOUT,2420) J, MU, ISJ DO 16 I = 1,NQA YAX(I,ISJ) = PJ(I,J) * ZZB * ZFA(I,4) * 1 ZFA(I,2)**NU * WA(I) IF (PT0) WRITE (NOUT,2440) I, YAX(I,ISJ), PJ(I,J), 1 ZZA, ZZB, ZFA(I,4), ZFA(I,2) 16 CONTINUE 20 CONTINUE 24 CONTINUE C C C FUNCTIONS OF LAMBDA. C ==================== C C AUXILIARY FUNCTIONS OF LAMBDA. DO 28 I = 1,NQL ZFL(I,1) = COS(XL(I,1) + XOMEGA(1)) ZFL(I,2) = COS(XL(I,1) + XOMEGA(2)) ZFL(I,3) = COS(XL(I,1) + XOMEGA(3)) ZFL(I,4) = SIN(XL(I,1) + XOMEGA(1)) ZFL(I,5) = SIN(XL(I,1) + XOMEGA(2)) ZFL(I,6) = SIN(XL(I,1) + XOMEGA(3)) 28 CONTINUE C C VALUES OF W(LAMBDA) COS(LAMBDA NU) , -W(LAMBDA) SIN(LAMBDA NU) . C THESE VALUES ARE SUCH THAT THE INTEGRANDS ARE C YLX(J,.,.) YAX(I) (-OMEGA(F)(I,J)) C (YAX: SEE ABOVE). C CALCULATE FOR ALL CONTIGUOUS NU .GE. 0; NEGATIVE-NU CASES LATER C BY SYMMETRY; NOTE THAT Y IS COMPLEX-CONJUGATE IN THE INTEGRAND. NU1U = MUTU + 1 DO 36 NU1 = 1,NU1U NU = NU1 - 1 IF (PT0) WRITE (NOUT,2500) NAME, NU DO 32 I = 1,NQL YLX(I,NU1,1) = WL(I,1) * COS(XL(I,1) * NU) YLX(I,NU1,2) = -WL(I,1) * SIN(XL(I,1) * NU) IF (PT0) WRITE (NOUT,2520) I, YLX(I,NU1,1), YLX(I,NU1,2) 32 CONTINUE 36 CONTINUE C C C INTEGRATION. C ============ C C RESET INTEGRALS. DO 44 K = 1,NDMUT DO 42 J = 1,NDP DO 40 I = 1,NDMUT CDF2R(I,J,K) = ZERO CDF2I(I,J,K) = ZERO 40 CONTINUE 42 CONTINUE 44 CONTINUE C C LOOP OVER LAMBDA POINTS. IF (PT0) WRITE (NOUT,2200) NAME DO 76 J = 1,NQL C C RESET INTEGRALS OVER A (ALL STATES, ALL POWERS). DO 50 IPX = 1,IPXU DO 48 ISJ = 1,NSJ QA(ISJ,IPX) = ZERO 48 CONTINUE 50 CONTINUE C C LOOP OVER A-POINTS. DO 68 I = 1,NQA C C AUXILIARY FUNCTIONS OF (A,LAMBDA) (ALL POWERS). C ----------------------------------------------- C C R(K)/RHO . ZFAL(1) = SQRT(XKAPPA(1) * (ONE + ZFA(I,2) * ZFL(J,1))) ZFAL(2) = SQRT(XKAPPA(2) * (ONE + ZFA(I,2) * ZFL(J,2))) ZFAL(3) = SQRT(XKAPPA(3) * (ONE + ZFA(I,2) * ZFL(J,3))) C C KAPPA(K) COS(LAMBDA+OMEGA(K)) / (R(K)/RHO)**2 . ZFAL(4) = XKAPPA(1) * ZFL(J,1) / ZFAL(1)**2 ZFAL(5) = XKAPPA(2) * ZFL(J,2) / ZFAL(2)**2 ZFAL(6) = XKAPPA(3) * ZFL(J,3) / ZFAL(3)**2 C C KAPPA(K) SIN(LAMBDA+OMEGA(K)) / (R(K)/RHO)**2 . ZFAL(7) = XKAPPA(1) * ZFL(J,4) / ZFAL(1)**2 ZFAL(8) = XKAPPA(2) * ZFL(J,5) / ZFAL(2)**2 ZFAL(9) = XKAPPA(3) * ZFL(J,6) / ZFAL(3)**2 C IF (PT0) WRITE (NOUT,2210) 1 I, XA(I), J, XL(J,1), (ZFAL(K), K = 1,9) C C MAX. RANGE OF INTERMEDIATE AND AUXILIARY POWERS C (EQUAL RANGES). JQL = MAX((1 - IPOFF) + 2 - IPFU, IPFL) JQU = MIN((IPXU - IPOFF) + 2 - IPFL, IPFU) JQXU = JQU - JQL + 1 DO 54 JQX = 1,JQXU C C INTERM./AUX. POWER AND ITS ARRAY INDEX. JQ = JQX + JQL - 1 JQ0X = JQ + IP0OFF C ZZ1 = F(1,JQ0X) * ZFAL(1) ** JQ ZZ2 = F(2,JQ0X) * ZFAL(2) ** JQ ZZ3 = F(3,JQ0X) * ZFAL(3) ** JQ C AUX(1,JQ0X) = ZZ1 + ZZ2 + ZZ3 AUX(2,JQ0X) = (ZFAL(4) * ZZ1 + 1 ZFAL(5) * ZZ2 + 2 ZFAL(6) * ZZ3 ) * ZFA(I,1) AUX(3,JQ0X) = ZFAL(7) * ZZ1 + 1 ZFAL(8) * ZZ2 + 2 ZFAL(9) * ZZ3 54 CONTINUE C C LOOP OVER POWERS. SKIP POWERS NOT IN THIS OPERATOR. C --------------------------------------------------- C DO 66 IPX = 1,IPXU IP = IPX - IPOFF IF (PT1 .AND. I + J .EQ. 2) WRITE (NOUT,2600) NAME, IP IF ((IP .LT. 2*IPFL-2) .OR. (IP .GT. 2*IPFU-2)) GO TO 66 C C -OMEGA(F) VALUE (FUNCTION OF (A,LAMBDA,POWER)), C CALCULATED BY A SUM OVER INTERMEDIATE POWERS. OFM = ZERO IQL = MAX(IP + 2 - IPFU, IPFL) IQU = MIN(IP + 2 - IPFL, IPFU) IQXU = IQU - IQL + 1 IF (PT1 .AND. I + J .EQ. 2) WRITE (NOUT,2602) IQL, IQU DO 58 IQX = 1,IQXU C C INTERMEDIATE POWER AND ITS ARRAY INDEX. IQ = IQX + IQL - 1 IQ0X = IQ + IP0OFF C C AUXILIARY POWER AND ITS ARRAY INDEX. IPQ = IP - IQ + 2 IPQ0X = IPQ + IP0OFF IF (PT1 .AND. I + J .EQ. 2) A WRITE (NOUT,2604) IQ, IPQ, IQ0X, IPQ0X OFM = OFM + IQ * IPQ * A (AUX(1,IQ0X) * AUX(1,IPQ0X) + B AUX(2,IQ0X) * AUX(2,IPQ0X) + C AUX(3,IQ0X) * AUX(3,IPQ0X) ) 58 CONTINUE OFM = -OFM C C ADD CONTRIBUTIONS TO INTEGRALS OVER A FROM AN A-POINT C (ALL STATES, ALL POWERS). DO 62 ISJ = 1,NSJ QA(ISJ,IPX) = QA(ISJ,IPX) + YAX(I,ISJ) * OFM 62 CONTINUE 66 CONTINUE 68 CONTINUE C C ADD CONTRIBUTIONS TO INTEGRALS OVER LAMBDA FROM A LAMBDA-POINT C (ALL STATES, ALL POWERS). FOR NONNEGATIVE NU ONLY. C STORE AS IN M2- , WITH MU-INDEX LAST BECAUSE IT IS THE OUTER C INDEX IN M2- . DO 74 IPX = 1,IPXU DO 72 ISJ = 1,NSJ MU = ISMNJ(1,ISJ) NU = ISMNJ(2,ISJ) NUX = (NU + MU) / 2 + 1 CDF2R(NUX,IPX,MU+1) = 1 CDF2R(NUX,IPX,MU+1) + YLX(J,NU+1,1) * QA(ISJ,IPX) CDF2I(NUX,IPX,MU+1) = 1 CDF2I(NUX,IPX,MU+1) + YLX(J,NU+1,2) * QA(ISJ,IPX) 72 CONTINUE 74 CONTINUE 76 CONTINUE C THE REAL AND IMAGINARY PARTS OF THE HH EXPANSION C ( CDF2R/I ) FOR NONNEGATIVE NU AT ALL POWERS ( IP ) ARE DONE. C C DEFINE AND STORE THE NEGATIVE-NU VALUES, USING SYMMETRY. C (THIS REDUNDANCY IS REQUIRED BY M2- .) DO 82 IPX = 1,IPXU DO 80 ISJ = 1,NSJ MU = ISMNJ(1,ISJ) NU = ISMNJ(2,ISJ) NUX = ( NU + MU) / 2 + 1 NUX1 = (-NU + MU) / 2 + 1 IF (NUX1 .EQ. NUX) GO TO 80 CDF2R(NUX1,IPX,MU+1) = 1 CDF2R(NUX,IPX,MU+1) * (1 - 2 * MOD(IABS(NU), 2)) CDF2I(NUX1,IPX,MU+1) = 1 CDF2I(NUX,IPX,MU+1) * (-(1 - 2 * MOD(IABS(NU), 2))) 80 CONTINUE 82 CONTINUE IF (.NOT.PRES) GO TO 88 C C PRINT. DO 86 IPX = 1,IPXU IP = IPX - IPOFF WRITE (NOUT,2300) NAME, IPX, IP DO 84 ISJ = 1,NSJ MU = ISMNJ(1,ISJ) NU = ISMNJ(2,ISJ) NUX = (NU + MU) / 2 + 1 NUX1 = (-NU + MU) / 2 + 1 WRITE (NOUT,2310) ISJ, MU, NU, 1 CDF2R(NUX,IPX,MU+1), CDF2R(NUX1,IPX,MU+1), 2 CDF2I(NUX,IPX,MU+1), CDF2I(NUX1,IPX,MU+1) 84 CONTINUE 86 CONTINUE 88 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2100 FORMAT (/, A 2H -, A6, 1H-, 16HI, XA, WA , /, B (1H , I4, 2F28.20)) 2110 FORMAT (/, A 2H -, A6, 1H-, 16HI, XL, WL , /, B (1H , I4, 2F28.20)) 2120 FORMAT (/, A 2H -, A6, 1H-, 16HI, ZFA(I,1-4) , /, B (1H , I4, 4F16.12)) 2200 FORMAT (/, A 2H -, A6, 1H-, 40HI, XA(I), J, XL(J,1), ZFAL(-,I,J) ) 2210 FORMAT ( A 1H , 2(I4, F12.8), /, 1H , 9F14.4) 2300 FORMAT (/, A 2H -, A6, 1H-, 20HPOWER INDEX, POWER , 2I4, /, B 1H , 8X, 44H MU NU CDF2R(MU,NU,IP), CDF2R(MU,-NU,IP) , /, C 1H , 8X, 8X, 36H CDF2I(MU,NU,IP), CDF2I(MU,-NU,IP) ) 2310 FORMAT ( A 1H , I4, 4X, 2I4, 2F24.16, /, 1H , 16X, 2F24.16) 2400 FORMAT ( A 2H -, A6, 1H-, 8HNU, NJ , 2I4) 2420 FORMAT ( A 1H , 16X, 8HJ,MU,ISJ, 3I4, /, B 1H , 24HI,YAX,PJ,ZZA/B,ZFA4/2: ) 2440 FORMAT ( A 1H , I4, 2F12.8, 4F12.8) 2500 FORMAT ( A 2H -, A6, 1H-, 8HNU , I4) 2520 FORMAT ( A 1H , 16X, 8HI, YLX , I4, 2F24.16) 2600 FORMAT ( A 2H -, A6, 1H-, 4HIP , I4) 2602 FORMAT ( A 1H , 16X, 8HIQL, IQU , 2I4) 2604 FORMAT ( A 1H , 32X, 20HIQ, IPQ, IQ0X, IPQ0X, 2I4, 2X, 2I4) END m2wrda.f000644 000311 000121 00000005450 06067230263 012243 0ustar00krivecf1000000 000000 SUBROUTINE M2WRDA(NDS, NDP, 1 NOUT, LPR, 2 IPXU, NS, INUSEL, ICONTR, 3 NSX, ISMN, EMW, EMWD) IMPLICIT REAL*8 (A - H, O - Z) LOGICAL LPR DIMENSION ICONTR(NDS), ISMN(2,NDS), 1 EMW(NDS,NDS,NDP), EMWD(NDS,NDS,NDP) C C C CONTRACTS THE W MATRIX BY SELECTING THE NONNEGATIVE-NU, C NEGATIVE-NU, OR ALL STATES, ACCORDING TO THE VALUE C OF THE VARIABLE INUSEL BEING 1, -1, OR 0, RESPECTIVELY. C C NOTE THAT STATES ARE ASSUMED TO BE ORDERED AS GIVEN BY ISMN, C I.E., THE NU-SELECTION IS DONE ON THE VECTOR ISMN ONLY. C C **** ISMN, EMW, EMWD CHANGED ON EXIT (EXCEPTIONAL) **** C C NS IS THE ORIGINAL NUMBER OF STATES AND NSX IS THE C OUTPUT NUMBER OF STATES. C C LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C CHARACTER*6 NAME DATA NAME / 'M2WRDA' / CHARACTER*60 VERS DATA VERS */ ' 1.2, 91/12/02. ' / C ------------------------------------------------------------ C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C IF (NS .LT. 1) CALL ERR2(NAME, 1, 1, NOUT) IF (NS .GT. NDS) CALL ERR2(NAME, 2, 1, NOUT) IF (IPXU .LT. 1) CALL ERR2(NAME, 3, 1, NOUT) IF (IPXU .GT. NDP) CALL ERR2(NAME, 4, 1, NOUT) IF (INUSEL .LT. -1 .OR. INUSEL .GT. 1) 1 CALL ERR2(NAME, 5, 1, NOUT) C IF (INUSEL .EQ. 0) THEN C C DO NOTHING. NSX = NS IF (LPR) WRITE (NOUT,2300) 1 NAME, (I, ISMN(1,I), ISMN(2,I), I = 1,NSX) RETURN ENDIF C C DEFINE THE CONTRACTING VECTOR, CONTRACT STATE LABELS. IF (LPR) WRITE (NOUT,2200) NAME NSX = 0 DO 10 I = 1,NS IF (.NOT. ((INUSEL .EQ. -1 .AND. ISMN(2,I) .LT. 0) .OR. 1 (INUSEL .EQ. 1 .AND. ISMN(2,I) .GE. 0) )) 2 GO TO 10 NSX = NSX + 1 ICONTR(NSX) = I ISMN(1,NSX) = ISMN(1,I) ISMN(2,NSX) = ISMN(2,I) IF (LPR) WRITE (NOUT,2210) 1 NSX, ISMN(1,NSX), ISMN(2,NSX), I 10 CONTINUE IF (NSX .EQ. 0) CALL ERR2(NAME, 10, 1, NOUT) C C CONTRACT THE MATRICES. DO 26 K = 1,IPXU DO 24 JX = 1,NSX J = ICONTR(JX) DO 20 IX = 1,NSX I = ICONTR(IX) EMW(IX,JX,K) = EMW(I,J,K) EMWD(IX,JX,K) = EMWD(I,J,K) 20 CONTINUE 24 CONTINUE 26 CONTINUE RETURN C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 2200 FORMAT ( A 2H -, A6, 1H-) 2210 FORMAT ( A 1H , 10X, I4, 4X, 2I4, I8) 2300 FORMAT ( A 2H -, A6, 1H-, /, B (1H , 10X, I4, 4X, 2I4)) END poch1.f000644 000311 000121 00000003077 06067233572 012072 0ustar00krivecf1000000 000000 SUBROUTINE POCH1(A, N, NOUT, P, S) C IMPLICIT REAL*8 (A-H, O-Z) C C C C C NATURAL LOGARITHM OF THE ABSOLUTE VALUE OF THE C POCHHAMMER SYMBOL (A) AND ITS SIGN (P, S, RESPECTIVELY). C N C (FOR LACK OF A BETTER TRICK). C USE: S * EXP(P). C THIS WORKS ALSO FOR 0 = (0) , N POSITIVE, AND FOR (-N) , C N N+1 C BECAUSE THEN S = 0.D0 ON EXIT (IE., USE OF S IS COMPULSORY). C C C C LOGICAL LCALL0 CHARACTER*6 NAME DATA LCALL0 / .TRUE. /, NAME / 'POCH ' / C C IF (LCALL0) WRITE (NOUT,2000) NAME IF (LCALL0) LCALL0 = .FALSE. C C C C IF (N .LT. 0) CALL ERR2(NAME, 1, 1, NOUT) C C C (A)0 = 1. C P = 0.D0 S = 1.D0 IF (N .EQ. 0) RETURN C C C N .GE. 1, A = 0.D0 (FIRST SPECIAL CASE WHEN S = 0). C P = 0.D0 S = 0.D0 IF (ABS(A) .LT. CDXTOL()) RETURN C C C N .GE. 1, A NONZERO. C P = 0.D0 S = 1.D0 DO 22 I = 1,N F = A + I - 1 IF (ABS(F) .LT. 8.D0*CDXTOL()) GO TO 20 C C CHANGE SIGN FOR EACH NEGATIVE FACTOR. C IF (F .LT. 0.D0) S = -S P = P + LOG(ABS(F)) GO TO 22 20 CONTINUE C C ZERO FACTOR FOUND (SECOND SPECIAL CASE WHEN S = 0). C P = 0.D0 S = 0.D0 RETURN 22 CONTINUE RETURN C C 2000 FORMAT ( A 1H , 1H-, A6, 1H-, B 40H 1.1, 95/12/24. 1.0, 90/02/19. ) C ======================================== END tempd.f000644 000311 000121 00000002513 05575327000 012154 0ustar00krivecf1000000 000000 SUBROUTINE TEMPD(TOLD, TNEW, TDIF, NOUT, LPR) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LPR C C CONVEX TIMING ROUTINE, USING CPUTIME(), WALLTIME(). C REASON: OLD TEMPD USED ETIME(,) WHICH RETURNS STRANGE VALUES C UPON -O3. TESTING 93/04/07... C PRINTS THE CURRENT CPU TIME, THE DIFFERENCE FROM THE C REFERENCE TIME (TOLD), AND TOLD. WALLTIME FROM ZERO IS PRINTED C ONLY, ALSO ON THE FIRST CALL. C NOUT IS THE OUTPUT UNIT NUMBER. C LOGICAL INIT REAL*4 CPUTIME, WALLTIME, SZERO, X DATA INIT / .TRUE. /, SZERO / 0.0 / C IF (.NOT. INIT) GO TO 10 WRITE (NOUT,2000) INIT = .FALSE. X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2200) WALL RETURN 10 CONTINUE X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2100) TNEW, TDIF, TOLD, WALL RETURN C 2000 FORMAT (1H , 48H-TEMPD- 2.0C, 94/06/08. CONVEX TIMING ROUTINE. ) 2100 FORMAT (1H , 2X, 4HCPU , F12.2, A 8H DIF, F12.2, B 8H REF, F12.2, C 8H WALL, F12.2) 2200 FORMAT (1H , 2X, 16X, 40X, A 8H WALL, F12.2) END trico.f000644 000311 000121 00000000523 05213131702 012151 0ustar00krivecf1000000 000000 LOGICAL FUNCTION TRICO(A, B, C) INTEGER A, B, C C C C TESTS THE TRIANGULAR AND PARITY CONDITIONS ON A, B, C. C C 2.0, 90/04/28. VERSION 1, 14-MAR-85. C C TRICO = C .GE. IABS(A - B) .AND. 1 C .LE. A + B .AND. 2 MOD(C, 2) .EQ. MOD(A + B, 2) RETURN END vc000.f000644 000311 000121 00000003315 06067230324 011673 0ustar00krivecf1000000 000000 SUBROUTINE VC000(NDVPAR, NDP0, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C R(I) POWER SERIES COEFFICIENTS OF THE POTENTIAL C C V = SUM(I=1...3) SUM(J=1...NVPAR) VPAR(I,J) * R(I)**(IPVL-1+J) C C WHERE R(I) IS THE DISTANCE BETWEEN PARTICLES J AND K. C STORAGE: V(I,IP0X), WHERE IP0X = IP0 + IP0OFF, C AND IP0 ARE THE CORRESPONDING POWERS. C C CHARACTER*6 NAME DATA NAME / 'VC000 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. O: CFC000 1.1, 90/03/28. ' / C ------------------------------------------------------------ LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C C CHECK NUMBER OF PARAMETERS. (IT MAY NOT EXCEED THE REQUIRED C NUMBER OF POWERS AS GIVEN BY (IPVL, IPVU).) IF (NVPAR .GT. IPVU - IPVL + 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 2, 1, NOUT) C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C DO 12 J = 1,NVPAR IP0 = (IPVL - 1) + J IP0X = IP0 + IP0OFF DO 10 I = 1,3 V(I,IP0X) = VPAR(I,J) 10 CONTINUE 12 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END vc001.f000644 000311 000121 00000005470 06067230326 011702 0ustar00krivecf1000000 000000 SUBROUTINE VC001(NDVPAR, NDP0, NDWK, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WK(3,NDWK), VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C THE INPUT ARRAY VPAR IS INTERPRETED SUCH THAT C THE POTENTIAL IS A SUM OF YUKAWA TERMS: C C V = SUM(I=1...3) SUM(K=1...NVPAR/2) C VPAR(I,2*K-1) * EXP(-VPAR(I,2*K) * R(I)) / R(I) C C NVPAR MUST BE EVEN AND NDWK .GE. NVPAR / 2. C C CHARACTER*6 NAME DATA NAME / 'VC001 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. ' / C ------------------------------------------------------------ C DIMENSION S(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPVL .NE. -1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU .LT. IPVL) CALL ERR2(NAME, 2, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 3, 1, NOUT) C ZERO = 0.0D0 ONE = 1.0D0 C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C C NUMBER OF YUKAWA TERMS, FROM NUMBER OF INPUT TERMS. IF (MOD(NVPAR, 2) .NE. 0) CALL ERR2(NAME, 11, 1, NOUT) NET = NVPAR / 2 IF (NET .GT. NDWK) CALL ERR2(NAME, 12, 1, NOUT) C C NUMBER OF POWERS TO BE GENERATED. NEP = IPVU - IPVL + 1 IF (NEP .GT. NDP0) CALL ERR2(NAME, 13, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 14, 1, NOUT) C C INITIALIZE. P = ONE DO 12 K = 1,NET DO 10 I = 1,3 WK(I,K) = VPAR(I,2*K-1) 10 CONTINUE 12 CONTINUE C C LOOP OVER POWERS. DO 40 J = 1,NEP C C POWER AND ITS INDEX. IP0 = J - 2 IP0X = IP0 + IP0OFF C S(1) = ZERO S(2) = ZERO S(3) = ZERO DO 22 K = 1,NET DO 20 I = 1,3 S(I) = S(I) + WK(I,K) 20 CONTINUE 22 CONTINUE C C CALCULATE THE V COEFFICIENTS. V(1,IP0X) = P * S(1) V(2,IP0X) = P * S(2) V(3,IP0X) = P * S(3) C C UPDATE FOR THE NEXT POWER (IP0 + 1). P = P / DFLOAT(IP0 + 2) DO 32 K = 1,NET DO 30 I = 1,3 WK(I,K) = WK(I,K) * (- VPAR(I,2*K)) 30 CONTINUE 32 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) 40 CONTINUE RETURN C 2000 FORMAT (2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END tempd.f000644 000311 000121 00000002513 05575327000 012154 0ustar00krivecf1000000 000000 SUBROUTINE TEMPD(TOLD, TNEW, TDIF, NOUT, LPR) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LPR C C CONVEX TIMING ROUTINE, USING CPUTIME(), WALLTIME(). C REASON: OLD TEMPD USED ETIME(,) WHICH RETURNS STRANGE VALUES C UPON -O3. TESTING 93/04/07... C PRINTS THE CURRENT CPU TIME, THE DIFFERENCE FROM THE C REFERENCE TIME (TOLD), AND TOLD. WALLTIME FROM ZERO IS PRINTED C ONLY, ALSO ON THE FIRST CALL. C NOUT IS THE OUTPUT UNIT NUMBER. C LOGICAL INIT REAL*4 CPUTIME, WALLTIME, SZERO, X DATA INIT / .TRUE. /, SZERO / 0.0 / C IF (.NOT. INIT) GO TO 10 WRITE (NOUT,2000) INIT = .FALSE. X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2200) WALL RETURN 10 CONTINUE X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2100) TNEW, TDIF, TOLD, WALL RETURN C 2000 FORMAT (1H , 48H-TEMPD- 2.0C, 94/06/08. CONVEX TIMING ROUTINE. ) 2100 FORMAT (1H , 2X, 4HCPU , F12.2, A 8H DIF, F12.2, B 8H REF, F12.2, C 8H WALL, F12.2) 2200 FORMAT (1H , 2X, 16X, 40X, A 8H WALL, F12.2) END trico.f000644 000311 000121 00000000523 05213131702 012151 0ustar00krivecf1000000 000000 LOGICAL FUNCTION TRICO(A, B, C) INTEGER A, B, C C C C TESTS THE TRIANGULAR AND PARITY CONDITIONS ON A, B, C. C C 2.0, 90/04/28. VERSION 1, 14-MAR-85. C C TRICO = C .GE. IABS(A - B) .AND. 1 C .LE. A + B .AND. 2 MOD(C, 2) .EQ. MOD(A + B, 2) RETURN END vc000.f000644 000311 000121 00000003315 06067230324 011673 0ustar00krivecf1000000 000000 S GIVEN BY (IPVL, IPVU).) IF (NVPAR .GT. IPVU - IPVL + 1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 2, 1, NOUT) C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C DO 12 J = 1,NVPAR IP0 = (IPVL - 1) + J IP0X = IP0 + IP0OFF DO 10 I = 1,3 V(I,IP0X) = VPAR(I,J) 10 CONTINUE 12 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) RETURN C C 2000 FORMAT ( A 2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END vc001.f000644 000311 000121 00000005470 06067230326 011702 0ustar00krivecf1000000 000000 SUBROUTINE VC001(NDVPAR, NDP0, NDWK, NOUT, LPR, 1 IPVL, IPVU, IP0OFF, WK, 2 NVPAR, VPAR, V) IMPLICIT REAL*8 (A-H, O-Z) DIMENSION WK(3,NDWK), VPAR(3,NDVPAR), V(3,NDP0) LOGICAL LPR C C C THE INPUT ARRAY VPAR IS INTERPRETED SUCH THAT C THE POTENTIAL IS A SUM OF YUKAWA TERMS: C C V = SUM(I=1...3) SUM(K=1...NVPAR/2) C VPAR(I,2*K-1) * EXP(-VPAR(I,2*K) * R(I)) / R(I) C C NVPAR MUST BE EVEN AND NDWK .GE. NVPAR / 2. C C CHARACTER*6 NAME DATA NAME / 'VC001 ' / CHARACTER*60 VERS DATA VERS */ ' 1.0, 90/12/19. ' / C ------------------------------------------------------------ C DIMENSION S(3) LOGICAL LCALL0 DATA LCALL0 / .TRUE. / C C IF (LCALL0) WRITE (NOUT,2000) NAME, VERS IF (LCALL0) LCALL0 = .FALSE. C C IF (IPVL .NE. -1) CALL ERR2(NAME, 1, 1, NOUT) IF (IPVU .LT. IPVL) CALL ERR2(NAME, 2, 1, NOUT) IF (NVPAR .GT. NDVPAR) CALL ERR2(NAME, 3, 1, NOUT) C ZERO = 0.0D0 ONE = 1.0D0 C IF (LPR) WRITE (NOUT,4000) IPVL, IPVU, NVPAR C C NUMBER OF YUKAWA TERMS, FROM NUMBER OF INPUT TERMS. IF (MOD(NVPAR, 2) .NE. 0) CALL ERR2(NAME, 11, 1, NOUT) NET = NVPAR / 2 IF (NET .GT. NDWK) CALL ERR2(NAME, 12, 1, NOUT) C C NUMBER OF POWERS TO BE GENERATED. NEP = IPVU - IPVL + 1 IF (NEP .GT. NDP0) CALL ERR2(NAME, 13, 1, NOUT) IF (IPVU + IP0OFF .GT. NDP0) CALL ERR2(NAME, 14, 1, NOUT) C C INITIALIZE. P = ONE DO 12 K = 1,NET DO 10 I = 1,3 WK(I,K) = VPAR(I,2*K-1) 10 CONTINUE 12 CONTINUE C C LOOP OVER POWERS. DO 40 J = 1,NEP C C POWER AND ITS INDEX. IP0 = J - 2 IP0X = IP0 + IP0OFF C S(1) = ZERO S(2) = ZERO S(3) = ZERO DO 22 K = 1,NET DO 20 I = 1,3 S(I) = S(I) + WK(I,K) 20 CONTINUE 22 CONTINUE C C CALCULATE THE V COEFFICIENTS. V(1,IP0X) = P * S(1) V(2,IP0X) = P * S(2) V(3,IP0X) = P * S(3) C C UPDATE FOR THE NEXT POWER (IP0 + 1). P = P / DFLOAT(IP0 + 2) DO 32 K = 1,NET DO 30 I = 1,3 WK(I,K) = WK(I,K) * (- VPAR(I,2*K)) 30 CONTINUE 32 CONTINUE IF (LPR) WRITE (NOUT,4010) IP0, (V(I,IP0X), I = 1,3) 40 CONTINUE RETURN C 2000 FORMAT (2H -, A6, 1H-, A60) 4000 FORMAT (/, A 1H , 40H V POWER EXPANSION COEFFICIENTS , //, B 1H , 40H IPVL, IPVU, NVPAR , 3I4) 4010 FORMAT ( A 1H , 36X, I4, 3D12.4) END tempd.f000644 000311 000121 00000002513 05575327000 012154 0ustar00krivecf1000000 000000 SUBROUTINE TEMPD(TOLD, TNEW, TDIF, NOUT, LPR) IMPLICIT REAL*8 (A-H,O-Z) LOGICAL LPR C C CONVEX TIMING ROUTINE, USING CPUTIME(), WALLTIME(). C REASON: OLD TEMPD USED ETIME(,) WHICH RETURNS STRANGE VALUES C UPON -O3. TESTING 93/04/07... C PRINTS THE CURRENT CPU TIME, THE DIFFERENCE FROM THE C REFERENCE TIME (TOLD), AND TOLD. WALLTIME FROM ZERO IS PRINTED C ONLY, ALSO ON THE FIRST CALL. C NOUT IS THE OUTPUT UNIT NUMBER. C LOGICAL INIT REAL*4 CPUTIME, WALLTIME, SZERO, X DATA INIT / .TRUE. /, SZERO / 0.0 / C IF (.NOT. INIT) GO TO 10 WRITE (NOUT,2000) INIT = .FALSE. X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2200) WALL RETURN 10 CONTINUE X = TOLD TDIF = CPUTIME(X) TNEW = TOLD + TDIF WALL = WALLTIME(SZERO) IF (LPR) WRITE (NOUT,2100) TNEW, TDIF, TOLD, WALL RETURN C 2000 FORMAT (1H , 48H-TEMPD- 2.0C, 94/06/08. CONVEX TIMING ROUTINE. ) 2100 FORMAT (1H , 2X, 4HCPU , F12.2, A 8H DIF, F12.2, B 8H REF, F12.2, C 8H WALL, F12.2) 2200 FORMAT (1H , 2X, 16X, 40X, A 8H WALL, F12.2) END trico.f000644 000311 000121 00000000523 05213131702 012151 0ustar00krivecf1000000 000000