! ! ********************************************************************** ! * ! * PROGRAM PLOTEF ! * ! * PROGRAM TO PRODUCE PLOTS OF INFORMATION FROM AN ENDF-5 OR -6 ! * FORMAT EVALUATED DATA FILE ! * ! * VERSION 6.0 JULY 1985 C.L. DUNFORD ! * 1. PLOTEF CONVERTED TO FORTRAN-77 ! * 2. NEW ENDF-6 FORMATS FILES 1-27 ADDED ! * 3. PLOTTING OF FILE 2, 23 AND 27 ADDED ! * VERSION 6.1 DECEMBER 1985 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.0 ! * 2. VT-240 OUTPUT OPTION ADDED ! * VERSION 6.2 DECEMBER 1986 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.1 ! * 2. MORE COMPLETE PLOTTING IN FILE 6 ! * 3. FILE 6, LAW=7 ADDED ! * 4. MT=457, READ SPECTRA COVARIANCE FORMAT ! * VERSION 6.3 AUGUST 1987 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.2 ! * 2. RESTORE REICH-MOORE TO ENDF-5 FORMAT ! * 3. PROCESS MORE THAN ONE INPUT FILE ! * 4. FORMAT CHANGES OF MAY 1987 EXCEPT ! * GENERALIZED R-MATRIX ! * VERSION 6.4 MAY 1988 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.3 ! * 2. HYBRID R-FUNCTION ADDED ! * VERSION 6.5 APRIL 1989 C.L. DUNFORD ! * 1. RECOGNIZE FILES 34, 35 AND 40 ! * VERSION 6.6 JUNE 1990 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.5 ! * 2. PHOTON INTERACTION FORMAT EXTENSIONS ! * 3. LOG STORAGE OF S(ALPHA,BETA) ! * VERSION 6.7 JUNE 1991 C.L.DUNFORD ! * 1. CORRECTIONS TO VERSION 6.6 ! * VERSION 6.8 JULY 1992 C.L. DUNFORD ! * 1. CORRECTIONS TO VERSION 6.7 ! * 2. VMS INPUT ON COMMAND LINE ! * VERSION 6.9 NOVEMBER 1993 C.L. DUNFORD ! * 1. CORRECT ERROR IN PLOTTING 457 CONTINUUM ! * 2. CORRECT BROND NLIB TO BE 41 ! * 3. REMOVED FR80 GRAPHIC OPTION ! * VERSION 6.10 NOVEMBER 1995 C.L.DUNFORD ! * 1. ADDED RECOGNITION OF MAT NO. FOR S-METHANE ! * 2. ADDED RECOGNITION OF NEW MT'S, 11, 44, 45 ! * AND 117 ! * 3. CORRECTED JEF ID IN A PLOT TITLE ! * 4. CORRECTED KALBACH ANGULAR DISTRIBUTIONS ! * VERSION 6.11 APRIL 1998 C.L.DUNFORD ! * 1. ALLOW 50000 POINTS IN TAB AND LIST RECORDS ! * 2. ALLOW UP TO 64 LEGENDRE COEFFICIENTS ! * 3. ADD NEW 451 FIELDS NREL AND EMAX ! * 4. NEW LTT=3 REPRESENTATION IN FILE 4 ! * 5 UPDATED ELEMENT NAMES AND SYMBOLS ! * VERSION 6.12 FEBRUARY 2001 C.L.DUNFORD ! * 1. MOVE NREL TO L1 FIELD FROM L2 FIELD ! * 2. ACCOUNT FOR 2 POSSIBLE CHANNEL SPINS IN ! * REICH-MOORE WHEN I AND L NOT EQUAL TO ZERO ! * 3. IMPLEMENT "$" OUTPUT CONTROL ON UNIX ! * 4. ALL GRAPHICS ROUTINES INCLUDED ! * 5. ONLY POSTSCRIPT AND REGIS SUPPORTED ! * 6. CREATE THREE INTERACTIVE VERSIONS AND ONE ! * BATCH VERSION ! * VERSION 6.13 MAY 2002 C.L.DUNFORD ! * 1. 6.12 BUGS REPORTED BY MAY 2002 ! * 2. FORMAT MODIFICATIONS FOR RADIOACTIVE PRODUCTS ! * IN FILES 8, 9 AMD 10 ! * 3. GRAPHIC PACKAGE NOW INCLUDED IN THIS SOURCE ! * 4. SIMPLE CONVERSION TO F95 STANDARD ! * ! * REFER ALL COMMENTS AND INQUIRIES TO ! * ! * NATIONAL NUCLEAR DATA CENTER ! * BUILDING 197D ! * BROOKHAVEN NATIONAL LABORATORY ! * P.O. BOX 5000 ! * UPTON, NY 11973-5000 ! * USA ! * ! * TELEPHONE 631-344-2902 ! * E-MAIL NNDC@BNL.GOV ! * ! ********************************************************************** ! ! TO CUSTOMIZE THIS SOURCE RUN SETMDC ! VMS - INTERACTIVE VERSION FOR VMS OPERATING SYSTEM ! WIN - INTERACTIVE VERSION FOR PC USING DIGITAL VISUAL FORTRAN ! UNX - INTERACTIVE VERSION FOR UNIX ! ANS - ANSI STANDARD BATCH MODE VERSION ! !*********************************************************************** ! COMMON/INDAT/IOPT,NLABEL COMMON/CLINE/INPAR CHARACTER(LEN=100) INPAR COMMON/CLINE1/ILENP COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEAD1/ZAH,AWRH,L1H,L2H,N1H,N2H,MATH,MFH,MTH COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT ! CHARACTER(LEN=66) STOR !+++MDC+++ !...VMS, WIN INTEGER*2 ILENP2 !---MDC--- CHARACTER(LEN=*), PARAMETER :: VERSION='6.13' ! ! DEFINE LIMITS FOR THE MINIPAGE VALUES ! MAXY = 5000 ! ! INITIALIZE FILE UNITS ! INPUT = 5 OUTPUT = 6 ITAPE = 20 RTAPE = 21 NSCR = 22 ! ! OUTPUT PROGRAM IDENTIFICATION ! WRITE(OUTPUT,'(/A)') ' PROGRAM PLOTEF VERSION '//VERSION ! ! CHECK FOR COMMAND LINE OPERATION ! INPAR = ' ' ILENP = 0 !+++MDC+++ !...VMS !/ CALL LIB$GET_FOREIGN(INPAR,,ILENP2) !/ ILENP = ILENP2 !...WIN CALL GETARG(1,INPAR,ILENP2) ILENP = IMAX0(ILENP2,0) !---MDC--- ! ! INITIALIZE GRAPHICS FOR RUN ! CALL GRBEG ! ! INITIALIZATION FOR EACH INPUT FILE ! 10 CALL BEGIN(IQUIT) IF(IQUIT.EQ.-1) GO TO 10 IF(IQUIT.EQ.1) GO TO 805 ! ! IF TAPE REQUEST LABEL IS LESS THAN ZERO DO NOT READ TPID ! IF(NLABEL.LT.0) GO TO 100 ! ! READ TAPE I.D. AND CHECK IF REQUESTED ! CALL TEXTR(ITAPE,STOR,LLABEL,MFLA,MTLA) IF(MFLA.EQ.0.AND.MTLA.EQ.0) GO TO 18 REWIND (UNIT=ITAPE) WRITE(OUTPUT,17) 17 FORMAT(/' TAPE IS UNLABELED') GO TO 100 18 IF(NLABEL.GT.0) GO TO 20 NLABEL = LLABEL GO TO 50 20 IF(NLABEL.EQ.LLABEL) GO TO 50 WRITE(OUTPUT,30) 30 FORMAT(/' TAPE LABEL DOES NOT MATCH REQUEST LABEL--EXECUTION ', & & 'TERMINATED') GO TO 800 ! ! WRITE TAPE I.D. ! 50 WRITE(OUTPUT,60) STOR,NLABEL 60 FORMAT(/' Label from Data Tape is given below'//' ',A66,I4/) ! ! READ HEAD CARD FOR FILE 1 OF CURRENT MATERIAL ! 100 CALL CONT(ITAPE,ZAH,AWRH,L1H,L2H,N1H,N2H,MATH,MFH,MTH) MFI = MFH ! ! TEST FOR END OF FILE ON ITAPE ! IF(MATH.EQ.0) THEN GO TO 680 ELSE IF(MATH.LT.0) THEN GO TO 800 END IF ! ! SEE IF ALL MATERIALS REQUESTED ! 130 IF(IOPT.EQ.1) GO TO 305 ! ! SEE IF MATERIAL IS REQUESTED ! IF(ZAN(1).EQ.0.0.AND.MATN(1).EQ.0) GO TO 200 DO 150 N=1,NMAT IF(MATH.EQ.MATN(N).OR.ZAH.EQ.ZAN(N)) GO TO 200 150 CONTINUE CALL SKPMAT(ITAPE) GO TO 100 ! ! RETRIEVE SPECS FOR THE MATERIAL ! 200 REWIND(UNIT=RTAPE) DO K=1,N READ(RTAPE) MFL,MFU,NMF,MTN END DO GO TO 305 ! ! READ FIRST RECORD OF FILE MFI ! 300 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MATI.EQ.0) THEN GO TO 100 ELSE IF(MATI.LT.0) THEN GO TO 680 END IF ! 305 SELECT CASE (MFI) ! CASE (1) CALL FILE1 CASE (2) CALL FILE2 CASE (3) CALL FILE3 CASE (4) CALL FILE4 CASE (5) CALL FILE5 CASE (6) CALL FILE6 CASE (7) CALL FILE7 CASE (8) CALL FILE8 CASE (9,10) CALL FILE9 CASE (12,13) CALL FILE12 CASE (14) CALL FILE14 CASE (15) CALL FILE15 CASE (23,27) CALL FILE23 CASE(26,28,31,32,33,34,35,40) WRITE(OUTPUT,630) MFI 630 FORMAT(/' PLOTS CANNOT BE GENERATED FOR FILE ',I2) CALL SKPFIL(ITAPE) CASE DEFAULT CALL SKPFIL(ITAPE) ! END SELECT GO TO 300 ! ! ERROR ON TAPE. WRITE ERROR MESSAGE AND STOP ! 680 WRITE(OUTPUT,690) 690 FORMAT(/' MATERIAL NUMBER IS LESS THAN OR EQUAL TO ZERO---', & & 'EXECUTION TERMINATED') ! ! CLOSE FILES ! 800 CLOSE(UNIT=ITAPE) IF(IOPT.EQ.0) CLOSE(UNIT=RTAPE,STATUS='DELETE') GO TO 10 ! ! JOB FINISTED ! 805 MATI = 0 MFI = 0 MTI = 0 HT = .5 CALL MOVEON(0) XFIN = XORG + 0.5*(XSIZE - 78.*HT/7.) YFIN = YORG + 0.5*YSIZE CALL LETTER('Job Completed',13,XFIN,YFIN) CALL ENDPLT CALL DONEPL ! ! TERMINATE JOB ! WRITE(OUTPUT,'(/A)') ' ' STOP ' JOB COMPLETED SUCCESSFULLY' END ! !*********************************************************************** ! SUBROUTINE GRBEG ! ! INITIALIZE GRAPHICS OUTPUT DEVICE ! COMMON/CLINE/INPAR CHARACTER(LEN=100) INPAR COMMON/CLINE1/ILENP COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT ! CHARACTER(LEN=100) POUFIL CHARACTER(LEN=10) BUF CHARACTER(LEN=80) DATIN ! !*********************************************************************** ! INSTALLATION DEPENDENT CODE ! THE FOLLOWING CODE UP TO BUT NOT INCLUDING FORTRAN STATEMENT ! NUMBER 50 PERFORMS THE GRAPHICS DEVICE INITIALIZATION FOR ! GRAPHICS OUTPUT DEVICES AVAILABLE TO NNDC. ONE OF FOUR OPTIONS ! IS SELECTED INTERACTIVELY BY THE USER. OTHER INSTALLATIONS ! SHOULD REPLACE THIS SECTION OF CODE WITH THEIR OWN DEVICE ! SELECTION PROCEDURE WHICH MAY BE INTERACTIVE OR FROM THE ! INPUT BATCH STREAM OR "HARDWIRED" IF ONLY ONE OPTION IS ! AVAILABLE. !*********************************************************************** ! ! POUFIL = '*' BUF = '*' !+++MDC+++ !...VMS, WIN IF(ILENP.NE.0) THEN CALL TOKEN(INPAR,'/',2,POUFIL) CALL TOKEN(INPAR,'/',3,BUF) ENDIF !...ANS !/ READ(INPUT,'(A)') DATIN !---MDC--- ! ! SELECT OUTPUT DEVICE ! IF(BUF.EQ.'*') THEN !+++MDC+++ !...VMS !/ IOPMAX = 2 !/ WRITE(OUTPUT,'(/A)') ' Select Output Device ' !/ WRITE(OUTPUT,'(A,$)') & !/ & ' PostScript(1), REGIS(2) - ' !/ READ(INPUT,'(A)') BUF !...ANS, WIN, UNX IOPMAX = 1 BUF = '1' !---MDC--- ENDIF IOPP = 1 READ(BUF,'(BN,I1)',ERR=10) IOPP 10 IF(IOPP.GE.1.AND.IOPP.LE.IOPMAX) THEN IOPKG = IOPP ELSE IOPKG = 1 ENDIF ! ! VT240 ! !+++MDC+++ !...VMS !/ IF(IOPKG.EQ.2) THEN !/ CALL NNDCRG(0,0) !/ GO TO 50 !/ END IF !---MDC--- ! ! GET PLOT FILE SPECIFICATION ! IF(POUFIL.EQ.'*') THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OUTPUT,'(/A,$)') & & ' Enter Output Plot File Specification - ' READ(INPUT,'(A)') POUFIL !...ANS !/ CALL TOKEN(DATIN,',',2,POUFIL) !---MDC--- ENDIF CALL UPSTR(POUFIL) CALL SETNAM(POUFIL) ! ! POSTSCRIPT ! IF(IOPKG.EQ.1) THEN CALL NNDCPS(0,0) END IF !*********************************************************************** ! END OF INSTALLATION DEPENDENT CODING !*********************************************************************** ! ! INITIALIZE PLOTTING CONTROL VARIABLES ! 50 HT = .14 THETA = 0. ULIM = 11. VLIM = 14. XSIZE = 11.5 YSIZE = 8.5 XORG = 8.*HT + 0.5 XTOP = VLIM - XORG - 2.*HT IF(XSIZE.GT.XTOP) XSIZE = XTOP YORG = 6.*HT + 0.5 YTOP = ULIM - YORG - (46.5/7.)*HT IF(YSIZE.GT.YTOP) YSIZE = YTOP XT = XORG YT = YORG + YSIZE + 1.5*HT ! RETURN END ! !*********************************************************************** ! SUBROUTINE BEGIN(IQUIT) ! ! ROUTINE TO SET UP JOB ! COMMON/INDAT/IOPT,NLABEL COMMON/CLINE/INPAR CHARACTER(LEN=100) INPAR COMMON/CLINE1/ILENP COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT ! LOGICAL IEXIST CHARACTER(LEN=50) INFIL CHARACTER(LEN=1) IW DATA IONEPASS/0/ ! ! SEE IF ONE PASS LIMIT SET ! IF(IONEPASS.EQ.1) THEN IQUIT = 1 GO TO 100 ENDIF ! ! INITIALIZE ! NCONT = 0 IQUIT = 0 INFIL = '*' !+++MDC+++ !...VMS, WIN, UNX IW = '*' !...ANS !/ IW = 'N' !---MDC--- ! ! INITIALIZE INPUT PARAMETERS ! NLABEL = 0 IOPT = 1 ! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! ! INFIL =INPUT FILE SPECIFICATION ! IOPT =0 PROCESS PARTAL TAPE ! =1 PROCESS FULL TAPE ! !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC ! !+++MDC+++ !...VMS, WIN IF(ILENP.NE.0) THEN CALL TOKEN(INPAR,'/',1,INFIL) CALL TOKEN(INPAR,'/',4,IW) IONEPASS = 1 IF(IW.NE.'N') IW = 'Y' ELSE IW = '*' ENDIF !---MDC--- IF(INFIL.EQ.'*') THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OUTPUT,'(/A,$)') & & ' Input File Specification - ' !---MDC--- READ(INPUT,'(A)') INFIL ENDIF CALL UPSTR(INFIL) IF(INFIL.EQ.' '.OR.INFIL.EQ.'DONE') THEN IQUIT = 1 GO TO 100 ENDIF INQUIRE(FILE=INFIL,EXIST=IEXIST) IF(.NOT.IEXIST) THEN WRITE(OUTPUT,'(/A/)') ' COULD NOT FIND INPUT FILE' !+++MDC+++ !...VMS, WIN, UNX IF(IONEPASS.EQ.1) THEN IQUIT = 1 ELSE IQUIT = -1 END IF !...ANS !/ IQUIT = 1 !---MDC--- GO TO 100 END IF ! ! PLOT ENTIRE TAPE ! IF(IW.EQ.'*') THEN !+++MDC+++ !...VMS, WIN, UNX WRITE(OUTPUT,'(/A,$)') & & ' Plot Entire Tape (Y(es),N(o)) - ' !---MDC--- READ(INPUT,'(A)') IW ENDIF CALL UPSTR(IW) IF(IW.EQ.'N') IOPT = 0 ! ! OPEN INPUT ! OPEN(UNIT=ITAPE,ACCESS='SEQUENTIAL',STATUS='OLD',ACTION='READ', & & FILE=INFIL) ! ! PROCESS REQUST SPECIFICATION ! IF(IOPT.NE.1) CALL REQUES ! ! OUTPUT SELECTED OPTIONS ! WRITE(OUTPUT,'(//2A)') & & ' Input File Specification------------------------',INFIL IF(IOPT.EQ.1) WRITE(OUTPUT,'(A)') ' Process the Entire Tape' ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE REQUES ! ! ROUTINE TO CONTROL ENTRY OF MAT MF MT SPECIFICATIONS ! COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT CHARACTER(LEN=250) REQTXT CHARACTER(LEN=80) LINE ! ! OPEN SCRATCH FILE FOR SPECS ! OPEN(UNIT=RTAPE,STATUS='SCRATCH',FORM='UNFORMATTED') ! ! INITIALIZE MATERIAL COUNT ! NMAT = 0 LREQ = 0 REQTXT = ' ' ! ! READ REQUESTS ! !+++MDC+++ !...VMS, WIN, UNX WRITE(OUTPUT,'(/A)') & & ' Enter Plot Specifications for Each Material' 10 WRITE(OUTPUT,'(A,$)') ' * ' !...ANS !/ 10 CONTINUE !---MDC--- READ(INPUT,'(A)') LINE ! ! CHECK FOR END OF ENTRIES ! IF(LINE.EQ.' ') GO TO 1000 ! ! CHECK IF MORE LINES FOLLOW IN REQUEST ! ICONT = INDEX(LINE,'-') IBEG = LREQ + 1 ILEN = 80 IF(ICONT.NE.0) ILEN = ICONT - 1 LREQ = IBEG + ILEN - 1 REQTXT(IBEG:LREQ) = LINE(1:ILEN) IF(ICONT.NE.0) GO TO 10 ! ! PROCESS REQUEST LINE ! CALL ANREQ(REQTXT,IERR) IF(IERR.EQ.0) GO TO 100 ! ! ERROR MESSAGE ! WRITE(OUTPUT,90) REQTXT(1:80) 90 FORMAT(' ***ERROR IN REQUEST BEGINNING'/1X,A80) GO TO 110 ! ! SET TO PROCESS NEXT REQUEST ! 100 WRITE(RTAPE) MFL,MFU,NMF,MTN 110 LREQ = 0 REQTXT = ' ' GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE UPSTR(STRING) ! ! ROUTINE TO CONVERT A STRING TO ALL UPPER CASE ! CHARACTER(LEN=*) STRING ! L = LEN(STRING) DO I=1,L IC = ICHAR(STRING(I:I)) IF(IC.GT.96.AND.IC.LT.123) STRING(I:I) = CHAR(IC-32) END DO ! RETURN END ! !*********************************************************************** ! SUBROUTINE TOKEN(INSTR,DELIM,ITOK,OUTSTR) ! ! SUBROUTINE TO EXTRACT A STRING FROM A STRING WITH DELIMITERS ! CHARACTER(LEN=*) INSTR,OUTSTR,DELIM ! ! INITIALIZE ! OUTSTR = ' ' CALL SCOUNT(INSTR,ILEN) CALL SCOUNT(DELIM,JLEN) IF(ITOK.EQ.0.OR.ILEN.EQ.0) GO TO 100 IF(JLEN.EQ.0) THEN IF(ITOK.EQ.1) OUTSTR = INSTR GO TO 100 END IF ! ! FIND ITOK-TH DELIMITER ! ITOKP = 1 - JLEN DO I=1,ITOK IBEG = ITOKP + JLEN IF(IBEG.LE.ILEN) THEN ITOKP = INDEX(INSTR(IBEG:),DELIM) + IBEG - 1 IF(ITOKP.LT.IBEG) ITOKP = ILEN + 1 ELSE GO TO 100 END IF IF(I.EQ.ITOK) THEN IF(ITOKP.GT.IBEG) OUTSTR = INSTR(IBEG:ITOKP-1) GO TO 100 END IF END DO ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE SCOUNT(STRING,LSTRING) ! ! ROUTINE TO COUNT TO LAST NON BLANK CHARACTER ! ! STRING - CHARACTER STRING TO BE ANALYZED ! LSTRING - LOCATION OF THE LAST NONBALNK CHARACTER IN THE ! STRING ! CHARACTER(LEN=*) STRING ! ! INITIALIZE ! LSTRING = 0 IF(STRING.EQ.' ') GO TO 100 ! ! FIND LAST NON BLANK CHARACTER ! NC = LEN(STRING) DO N=NC,1,-1 IF(STRING(N:N).NE.' '.AND.STRING(N:N).NE.CHAR(0)) GO TO 30 END DO GO TO 100 ! ! SET LENGTH ! 30 LSTRING = N ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE ANREQ(REQTXT,IERR) ! ! ROUTINE TO DECODE A ENDF FILE PLOT REQUEST LINE ! COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE ! CHARACTER(LEN=250) REQTXT CHARACTER(LEN=40) BUF CHARACTER(LEN=6) BUF1 CHARACTER(LEN=10) BUF2 CHARACTER(LEN=30) BUF3 ! ! INITIALIZE ERROR FLAG ! IERR = 0 ! ! GET MAT-NUMBER OR ZA ! NMAT = NMAT + 1 IF(NMAT.GT.30) GO TO 900 ZAN(NMAT) = 0. MATN(NMAT) = 0 NTOK = 1 CALL TOKEN(REQTXT,',',NTOK,BUF1) IF(INDEX(BUF1,'.').NE.0) GO TO 20 READ(BUF1,15,ERR=910) MATN(NMAT) 15 FORMAT(BN,I4) GO TO 30 20 READ(BUF1,25,ERR=910) ZAN(NMAT) 25 FORMAT(F6.0) ! ! SET UP TO ANALYZE MF(MT) SPECIFICATIONS ! 30 NMF = 0 MFL(1) = 1 MFU(1) = 99 DO K=2,12 MFL(K) = 0 MFU(K) = 0 END DO ! ! ANALYZE EACH MF(MT) SPECIFICATION ! 60 NTOK = NTOK + 1 CALL TOKEN(REQTXT,',',NTOK,BUF) IF(BUF.EQ.' ') THEN IF(NMF.EQ.0) NMF = 1 GO TO 1000 ENDIF IF(NMF.EQ.12) GO TO 900 ! ! INITIALIZE SPECIFICATION PARAMETERS ! NMF = NMF + 1 MFL(NMF) = 1 MFU(NMF) = 99 NMT = 0 DO K=1,20 MTN(K,NMF) = 0 END DO CALL TOKEN(BUF,'(',1,BUF2) IF(BUF2.EQ.' ') GO TO 100 ! ! EXTRACT INITIAL VALUE OF MF ! CALL TOKEN(BUF2,'/',1,BUF1) READ(BUF1,80,ERR=900) MFL(NMF) 80 FORMAT(BN,I2) MFU(NMF) = MFL(NMF) ! ! IF MF RANGE. GET FINAL VALUE ! CALL TOKEN(BUF2,'/',2,BUF1) IF(BUF1.EQ.' ') GO TO 100 READ(BUF1,80,ERR=900) MFU(NMF) ! ! PROCESS MT SELECTION EXPRESSION ! 100 IB = INDEX(BUF,'(') + 1 IF(IB.LE.1) GO TO 60 IE = INDEX(BUF,')') - 1 IF(IE.LE.0) GO TO 900 BUF3 = BUF(IB:IE) IF(BUF3.EQ.' ') GO TO 60 LTOK = 0 ! ! PROCESS EACH SUB-EXPRESSION ! 110 LTOK = LTOK + 1 CALL TOKEN(BUF3,';',LTOK,BUF2) IF(BUF2.EQ.' ') GO TO 60 IF(NMT.GE.20) GO TO 900 NMT = NMT + 1 ! ! EXTRACT FIRST (OR ONLY) MT FROM THE SUB-EXPRESSION ! CALL TOKEN(BUF2,'/',1,BUF1) READ(BUF1,15,ERR=900) MTN(NMT,NMF) ! ! IF MT RANGE. GET FINAL VALUE ! CALL TOKEN(BUF2,'/',2,BUF1) IF(BUF1.EQ.' ') GO TO 110 IF(NMT.GE.20) GO TO 900 NMT = NMT + 1 READ(BUF1,15,ERR=900) MTNN MTN(NMT,NMF) = -MTNN GO TO 110 ! ! SET ERROR FLAG ! 900 NMAT = NMAT - 1 910 IERR = 1 GO TO 1000 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 1 DATA ! COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEAD1/ZAH,AWRH,LRP,LFI,N1H,N2H,MATH,MFH,MTH COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! PROCESS REMAINING IDENTIFICATION CARDS IN FILE 1 SECTION 451 ! ZAI = ZAH MATI = MATH MFI = MFH MTI = MTH NLIB=N1H NMOD=N2H MATIN = MATH CALL CONT(ITAPE,ELIS,STA,LIS,LISO,N1,NFOR,MAT,MF,MT) IF(NFOR.NE.0) GO TO 5 ! ! ENDF-V FORMAT FILE ! NFOR = 5 NVER = 5 NREL = 0 IF((NLIB.GE.2.AND.NLIB.LE.4).OR.NLIB.EQ.35) NVER = 1 IF(NLIB.EQ.5) NVER = 2 IF(NLIB.EQ.6) NVER = 3 NSUB = 10 AWI = 1. GO TO 7 ! ! ENDF-VI OR LATER FORMAT ! 5 CALL CONT(ITAPE,AWI,EMAX,NREL,L2,NSUB,NVER,MAT,MF,MT) ! ! SET UP LIBRARY ID ! 7 CALL LIBID(NLIB,NVER,LIBBCD) ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 15 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 25 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 25 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS SECTION ! CALL HEADIN(0,0,MTI,-1.) SELECT CASE (MTI) ! ! SECTION 451 ! CASE (451) CALL FILE1A ! ! NUBAR ! CASE (452,455,456) CALL FILE1B ! ! ENERGY RELEASE IN FISSION ! CASE (458) CALL FILE1C ! ! SKIP SECTION WHICH CANNOT BE RECOGNIZED ! CASE DEFAULT CALL SKPSEC(ITAPE) GO TO 250 END SELECT ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 15 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1A ! ! ROUTINE TO PROCESS MT = 451 ! COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! CHARACTER(LEN=66) HOL CHARACTER(LEN=48) DFBCD CHARACTER(LEN=43) DBCD CHARACTER(LEN=13) BUF ! CHARACTER(LEN=30) DICTON PARAMETER (NTIT=93) CHARACTER(LEN=NTIT) PTITLE ! DATA DICTON/' Table of Contents '/ DATA PTITLE(1:50)/' File '/,& & PTITLE(51:80)/' Reaction '/, & & PTITLE(81:NTIT)/' Cards Mod'/ ! ! READ CONTROL CARD ! CALL CONT(ITAPE,C1,C2,L1,L2,NCD,NXC,MAT,MF,MT) ! ! INITIALIZE LINE PLOT PARAMETERS ! WD = 6.*HT/7. YSPC = 2.*WD XCEN = XORG + 0.5*XSIZE YB = YORG + YSIZE KLINES = INT(YB/YSPC) - 1 ! ! PROCESS ANY COMMENT CARDS ! IF(NCD.LE.0) GO TO 30 X = XCEN - 33.*WD Y = YB MFBCD = ' General Information' CALL MOVEON(1) ! ! PROCESS EACH TEXT CARD ! DO 25 N=1,NCD !*****OUTPUT NEW PAGE IF(MOD(N,KLINES).NE.1) GO TO 10 IF(N.EQ.1.OR.N.EQ.NCD) GO TO 10 CALL ENDPLT CALL MOVEON(1) Y = YB 10 CALL TEXTR(ITAPE,HOL,MAT,MF,MT) CALL LETTER(HOL,66,X,Y) Y = Y - YSPC 25 CONTINUE CALL ENDPLT ! ! PROCESS THE DIRECTORY IF PRESENT ! 30 IF(NXC.LE.0) GO TO 90 MFX = -1 XOFF = XORG + 50.*WD X = XORG Y = YB - 2.*YSPC MTBCD = DICTON CALL MOVEON(1) CALL LETTER(PTITLE,NTIT,XT,YB) ! ! LOOP OVER DIRECTORY CARDS ! LLINES = KLINES - 2 DO 80 N=1,NXC !*****OUTPUT NEW PAGE IF(MOD(N,LLINES).NE.1) GO TO 40 IF(N.EQ.1.OR.N.EQ.NXC) GO TO 40 CALL ENDPLT MFX = -1 CALL MOVEON(1) CALL LETTER(PTITLE,NTIT,XT,YB) Y = YB - 2.*YSPC 40 CALL CONT(ITAPE,C1,C2,MFZ,MTZ,NCZ,NMODZ,MAT,MF,MT) ! ! TAKE CARE OF 451 ! IF(N.NE.1) GO TO 45 DFBCD = ' General Information' MFX = -1 GO TO 48 ! ! IF FILE NUMBER HAS CHANGED COMPUTE NEW HOLLERITH ! 45 IF(MFZ.EQ.MFX) GO TO 50 CALL MFID(NSUB,MFZ,MTZ,DFBCD,IERR) MFX = MFZ 48 CALL LETTER(DFBCD,48,X,Y) ! ! COMPUTE NEW HOLLERITH FOR REACTION ! 50 CALL MTID(NFOR,NSUB,MTZ,DBCD,IERR) ! ! WRITE HOLLERITH EQIVALENTS OF FILE AND REACTION PLUS CARD COUNT ! WRITE(BUF,60) NCZ,NMODZ 60 FORMAT(' ',2I6) DBCD(31:43) = BUF CALL LETTER(DBCD,43,XOFF,Y) Y = Y - YSPC 80 CONTINUE CALL ENDPLT 90 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1B ! ! PROCESS NUBAR ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,LNU,N1I,N2I,MATI,MFI,MTI ! PARAMETER (ERANGE=2.0E+12) REAL C(10) ! ! READ DECAY CONSTANTS FOR DELAYED NU-BAR ! IF(MTI.EQ.455) CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,X) ! ! BRANCH ON DATA FORMAT ! IF(LNU.NE.1) GO TO 50 ! ! DATA IS POLYNOMIAL COEFFICIENTS ! CALL CANT(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,C) ! ! RECONSTRUCT POLYNOMIAL AT 1001 EQUALLY SPACED POINTS ! AINT = ALOG10(ERANGE)/1000. ALOGX = -5. - AINT DO 30 I=1,1001 ALOGX = ALOGX + AINT X(I) = 10.**ALOGX ET = X(I) Y(I) = C(1) IF(NR.LT.2)GO TO 30 DO 25 J=2,NR Y(I) = Y(I)+C(J)*ET ET = ET*X(I) 25 CONTINUE 30 CONTINUE NP = 201 NR = 1 INT(1) = 2 NBT(1) = NP GO TO 100 ! ! DATA IS TABULAR ! 50 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! PLOT NUBAR ! 100 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'$4',2) IF(LNU.EQ.1) CALL LETTER('Reconstructed Values of $4',25,XT,YT) CALL ENDPLT ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE1C ! ! ROUTINE TO PROCESS ENERGY RELEASE IN FISSION ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,LNU,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=38) LINE(9) PARAMETER (NTIT=77) CHARACTER(LEN=NTIT) PTITLE ! DATA LINE/'Fragment Kinetic Energy ', & & 'Prompt Fission Neutron Kinetic Energy ', & & 'Delayed Fission Neutron Kinetic Energy', & & 'Prompt Gamma Ray Emission ', & & 'Delayed Gamma Ray Emission ', & & 'Delayed Beta ', & & 'Neutrino ', & & 'Total Energy Less Neutrino Energy ', & & 'Total Energy Release per Fission '/ ! DATA PTITLE(1:42)/' Partial Energy Component '/, & & PTITLE(43:NTIT)/'Energy Release Error Estimates'/ ! ! READ IN DATA ! CALL CANT(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,X) ! ! INITIALIZE LINE PLOT PARAMETERS ! WD = 6.*HT/7. YSPC = 2.*WD YB = YORG + YSIZE CALL MOVEON(1) Y0 = YB - 2.*YSPC X0 = XORG X1 = X0 + 44*WD X2 = X0 + 64*WD CALL LETTER(PTITLE,NTIT,XT,YB) ! ! OUTPUT EACH LINE ! DO L=1,NP CALL LETTER(LINE(L),38,X0,Y0) D1 = X(2*L-1) CALL CIPHER(D1,.0001*D1,X1,Y0) D2 = X(2*L) CALL CIPHER(D2,.0001*D2,X2,Y0) Y0 = Y0 - YSPC END DO CALL ENDPLT ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE2 ! ! ROUTINE TO PROCESS RESONANCE REGION DATA ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,L1I,L2I,NIS,N2I,MATI,MFI,MTI COMMON/REPDAT/LRF,NCHAN,LRX(4),QX(4),NRS,NREP, & & AWRI2,L,AS,AJ COMMON/REPDT1/ZAIBCD CHARACTER(LEN=24) ZAIBCD ! REAL RES(10000) ! CHARACTER(LEN=6) ORD(4) CHARACTER(LEN=15) YLAB(5) INTEGER LYLAB(5) ! DATA ORD/'First ','Second','Third ','Fourth'/ DATA YLAB/'$< D $> ','$< $8>x< $> ', & & '$< $8>n<;<0> $>','$< $8>$2< $> ','$< $8>f< $> '/ DATA LYLAB/7,11,15,12,11/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.NE.0) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! CALL HEADIN(MATI,MFI,MTI,ZAI) ! ! SET UP LOOP OVER ISOTOPES ! DO 300 I=1,NIS CALL CONT(ITAPE,ZARI,ABN,L1,LFW,NER,N2,MAT,MF,MT) CALL ZAID(ZARI,ZAIBCD,IERR) ! ! SET UP LOOP OVER ENERGY RANGES ! DO 250 JJ=1,NER CALL CONT(ITAPE,EL,EH,LRU,LRF,NRO,N2,MAT,MF,MT) ! ! READ ENERGY DEPENDENT SCATTERING LENGTH ! IF(NRO.EQ.0) GO TO 10 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Scattering Length (10<-12>cm)',29) CALL LETTER('Energy Dependent Scattering Length for ',39, & & XT,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT ! ! BRANCH ON TYPE OF REPRESENTATION ! 10 LLRU=LRU+1 SELECT CASE (LLRU) ! ! NO RESONANCE PARAMETERS GIVEN ! CASE (1) CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) GO TO 250 ! ! RESONANCES ARE RESOLVED ! CASE (2) CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) ! ! SINGLE - AND MULTI-LEVEL BREIT-WIGNER AND R-MATRIX PARAMETERS ! IF(LRF.EQ.4) GO TO 55 IF(LRF.EQ.6) GO TO 100 DO 50 III=1,NLS CALL CANT(ITAPE,AWRI,C2,L,L2,NT,NRS,MAT,MF,MT,RES) AWRI2 = (1.+(1./AWRI))**2 NREP = NT/NRS NCHAN = 3 ! ! PLOT ! CALL RESPLT(RES) ! 50 CONTINUE GO TO 250 ! ! RESOLVED ADLER-ADLER PARAMETERS ! 55 CALL CANT(ITAPE,AWRI,C2,LI,L2,NT,NX,MAT,MF,MT,X) AWRI2 = (1.+(1./AWRI))**2 DO 60 III=1,NLS CALL CONT(ITAPE,C1,C2,L,L2,NJS,N2,MAT,MF,MT) DO JJJ=1,NJS CALL CANT(ITAPE,AJ,C2,L1,L2,NT,NRS,MAT,MF,MT,RES) NREP = 12 NCHAN = 3 CALL RESPLT(RES) END DO 60 CONTINUE GO TO 250 ! ! HYBRID R-FUNCTION ! 100 CALL CONT(ITAPE,C1,C2,NGRE,NFRE,NIRE,NCRE,MAT,MF,MT) NCOMCH = NIRE +NCRE CALL CONT(ITAPE,C1,C2,LRX(1),LRX(2),LRX(3),LRX(4),MAT,MF,MT) CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,QX) ! ! PROCESS CHARGED PARTICLE PENETRABILITIES ! IF(NCRE.GT.0) THEN DO 110 NCR=1,NCRE DO LIL=1,4 FLL = LIL CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Charged Particle Penetrability',30) CALL LETTER('Charged Particle Penetrability for ',35, & & XT,YT) CALL LETTER(ORD(NCR),6,999.,YT) CALL LETTER(' CP Channel L=',14,999.,YT) CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(' for ',5,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT END DO 110 CONTINUE ENDIF ! ! PROCESS ALL L-VALUES ! DO 175 NL=1,NLS CALL CONT(ITAPE,AWRI,C2,L,L2,NSS,N2,MAT,MF,MT) AWRI2 = (1.+(1./AWRI))**2 FLL = L ! ! PROCESS ALL CHANNEL SPIN STATES ! DO 172 NS=1,NSS CALL CONT(ITAPE,AS,C2,L1,L2,NJS,N2,MAT,MF,MT) ! ! PROCESS ALL TOTAL SPIN STATES ! DO NJ=1,NJS CALL CANT(ITAPE,AJ,C2,LBK,LPS,NT,NRS,MAT,MF,MT,RES) NREP = NT/NRS NCHAN = NCOMCH + 3 ! ! PLOT ! CALL RESPLT(RES) ! !*****BACKGROUND COMPONENT IF(LBK.NE.0) THEN CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Background R',12) CALL LETTER('Real Part of Background R',25,XT,YT) CALL LETTER(' for L = ',9,999.,YT) CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(' S = ',4,999.,YT) CALL DIGITS(AS,1,999.,YT) CALL LETTER(' J = ',4,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' for ',5,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Background R',12) CALL LETTER('Imaginary Part of Background R',30,XT,YT) CALL LETTER(' for L = ',9,999.,YT) CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(' S = ',4,999.,YT) CALL DIGITS(AS,1,999.,YT) CALL LETTER(' J = ',4,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' for ',5,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT ENDIF !*****OPTICAL MODEL PHASE SHIFT IF(LPS.NE.0) THEN CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Optical Phase Shift',19) CALL LETTER('Real Part of Optical Phase Shift',32,XT,YT) CALL LETTER(' for L = ',9,999.,YT) CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(' S = ',4,999.,YT) CALL DIGITS(AS,1,999.,YT) CALL LETTER(' J = ',4,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' for ',5,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6, & & 'Optical Phase Shift',19) CALL LETTER('Imaginary Part of Optical Phase Shift',35,XT,YT) CALL LETTER(' for L = ',9,999.,YT) CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(' S = ',4,999.,YT) CALL DIGITS(AS,1,999.,YT) CALL LETTER(' J = ',4,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' for ',5,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT ENDIF END DO 172 CONTINUE 175 CONTINUE ! ! RESONANCES ARE UNRESOLVED. ! CASE (3) IF(LRF.EQ.2) GO TO 220 IF(LFW.EQ.0) GO TO 200 ! ! ISOTOPE IS FISSILE ! CALL CANT(ITAPE,SPI,AP,L1,L2,NP,NLS,MAT,MF,MT,X) NR = 1 INT(1) = 2 NBT(1) = NP DO 195 III=1,NLS CALL CONT(ITAPE,C1,C2,L,L2,NJS,N2,MAT,MF,MT) DO 190 JJJ=1,NJS CALL CANT(ITAPE,C1,C2,L1,MUF,NEPL6,N2,MAT,MF,MT,RES) DO N=1,NP Y(N) = RES(N+6) END DO CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'$<$8>f<$>',9) CALL LETTER('Unresolved parameters for L = ',30,XT,YT) CALL DIGITS(FLOAT(L),-1,999.,YT) CALL LETTER(' and J = ',9,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' resonances in ',15,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT 190 CONTINUE 195 CONTINUE GO TO 250 ! ! ISOTOPE IS NON-FISSILE ! 200 CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) DO 210 I3=1,NLS CALL CANT(ITAPE,C1,C2,L,L2,NJS6X,NJS,MAT,MF,MT,RES) 210 CONTINUE GO TO 250 ! ! ALL ENERGY DEPENDENT PARAMETERS ! 220 CALL CONT(ITAPE,SPI,AP,L1,L2,NLS,N2,MAT,MF,MT) DO 240 I3=1,NLS CALL CONT(ITAPE,C1,C2,L,L2,NJS,N2,MAT,MF,MT) DO 235 JJJ=1,NJS CALL CANT(ITAPE,AJ,C2,JNT,L2,NEL6X,NP,MAT,MF,MT,RES) NR = 1 INT(1) = JNT NBT(1) = NP DO 230 N=1,5 IDO = 0 K6 = 7 DO NN=1,NP X(NN) = RES(K6) Y(NN) = RES(K6+N) IF(Y(NN).NE.0.) IDO = 1 K6 = K6 + 6 END DO IF(IDO.EQ.0) GO TO 230 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,YLAB(N),LYLAB(N)) CALL LETTER('Unresolved parameters for L = ',30,XT,YT) CALL DIGITS(FLOAT(L),-1,999.,YT) CALL LETTER(' and J = ',9,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' resonances in ',15,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT 230 CONTINUE 235 CONTINUE 240 CONTINUE ! END SELECT ! ! END OF LOOP ON ENERGY REGIONS ! 250 CONTINUE ! ! END OF LOOP ON ISOTOPES ! 300 CONTINUE ! ! SKIP TO THE END OF THE FILE ! 1000 CALL SKPFIL(ITAPE) ! RETURN END ! !*********************************************************************** ! SUBROUTINE RESPLT(RES) ! ! ROUTINE TO PLOT PEAK CROSS SECTIONS FOR RESOLVED RESONANCE ! REPRESENTATIONS ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,L1I,L2I,NIS,N2I,MATI,MFI,MTI COMMON/REPDAT/LRF,NCHAN,LRX(4),QX(4),NRS,NREP, & & AWRI2,L,AS,AJ COMMON/REPDT1/ZAIBCD CHARACTER(LEN=24) ZAIBCD ! REAL RES(8000) ! CHARACTER(LEN=10) RETYP(3) INTEGER LRETP(3) CHARACTER(LEN=17) RESTYP(6) INTEGER LRESTP(6) CHARACTER(LEN=7) RETYPA(3) INTEGER LRETPA(3) ! DATA RETYP/'scattering','capture ','fission '/ DATA LRETP/10,7,7/ DATA RESTYP/'Breit-Wigner (SL)','Breit-Wigner (ML)', & & 'R-matrix ','Adler-Adler ', & & 'Reich-Moore ','Hybrid R-function'/ DATA LRESTP/17,17,8,11,11,17/ DATA RETYPA/'total ','fission','capture'/ DATA LRETPA/5,7,7/ ! ! SET UP PLOT ARRAY OF PEAK CROSS SECTION VS RESONANCE ENERGY AS ! A HISTOGRAM PLOT ! NT = NRS*NREP NP = 3*NRS + 2 NR = 1 NBT(1) = NP INT(1) = 1 K = 1 DO 30 NN=1,NT,NREP ERES = RES(NN) DO NNN=1,3 K = K + 1 X(K) = ERES Y(K) = 0. END DO 30 CONTINUE X(1) = .9*X(2) IF(X(2).LT.0.) X(1) = 1.1*X(2) Y(1) = 0. X(NP) = 1.1*X(NP-1) Y(NP) = 0. ! ! CALCULATE AND PLOT PEAK CROSS SECTION FOR EACH PARTIAL ! IF(LRF.EQ.4) GO TO 70 IF(LRF.EQ.6) GO TO 100 ! ! BREIT-WIGNER AND R-MATRIX(REICH-MOORE) ! SCON = 1.304E+6*AWRI2/(2.*FLOAT(L)+1.) DO 60 K=3,NCHAN+2 K6 = 1 IDO = 0 DO N=1,NRS ER = RES(K6) AJ = ABS(RES(K6+1)) IF(LRF.NE.3) THEN GT = RES(K6+2) GN = RES(K6+3) GR = RES(K6+K) ELSE GN = RES(K6+2) GR = RES(K6+K-1) IF(K.EQ.5) GR = ABS(GR) + ABS(RES(K6+K)) GT = GN + RES(K6+3) + ABS(RES(K6+4)) + ABS(RES(K6+5)) END IF N3 = 3*N Y(N3) = SCON*(2.*AJ+1.)*GN*GR/(GT**2)/ABS(ER) IF(Y(N3).NE.0.) IDO = 1 K6 = K6 + NREP END DO !*****PLOT UNLESS ALL WIDTHS FOR PARTIAL AE ZERO IF(IDO.EQ.0) GO TO 60 CALL PLOTXY(0.,0.,-1,0.,0.,1,'E>o< (eV)',9,'$7>o< (barns)',13) YTYP = YORG + YSIZE + HT + 15.5*HT/7. LRFC = LRF IF(NFOR.EQ.5.AND.LRF.EQ.3) LRFC = 5 CALL LETTER(RESTYP(LRFC),LRESTP(LRFC),XT,YTYP) CALL LETTER('Peak ',5,XT,YT) CALL LETTER(RETYP(K-2),LRETP(K-2),999.,YT) CALL LETTER(' cross section for L = ',23,999.,YT) CALL DIGITS(FLOAT(L),-1,999.,YT) CALL LETTER(' resonances in ',15,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT 60 CONTINUE GO TO 1000 ! ! ADLER-ADLER ! 70 SCON = .652E+6*AWRI2 DO 90 K=1,NCHAN K6 = 1 IDO = 0 DO N=1,NRS N3 = 3*N ERES = ABS(RES(K6)) Y(N3) = SCON*RES(K6+4*K-2)/(SQRT(ERES)*RES(K6+1)) IF(Y(N3).NE.0.) IDO = 1 K6 = K6 + 12 END DO !*****PLOT UNLESS ALL WIDTHS FOR THE PARTIAL ARE ZERO IF(IDO.EQ.0) GO TO 90 CALL PLOTXY(0.,0.,-1,0.,0.,1,'E>o< (eV)',9,'$7>o< (barns)',13) YTYP = YORG + YSIZE + HT + 15.5*HT/7. CALL LETTER(RESTYP(LRF),LRESTP(LRF),XT,YTYP) CALL LETTER('Peak ',5,XT,YT) CALL LETTER(RETYPA(K),LRETPA(K),999.,YT) CALL LETTER(' cross section for L = ',23,999.,YT) CALL DIGITS(FLOAT(L),-1,999.,YT) CALL LETTER(' and J = ',9,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' resonances in ',15,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT 90 CONTINUE GO TO 1000 ! ! HYBRID R-FUNCTION ! 100 SCON = 1.304E+6*AWRI2/(2.*FLOAT(L)+1.) DO 140 K=1,NCHAN K6 = 1 IDO = 0 DO N=1,NRS ER = RES(K6) GT = 0. DO ILI=1,NCHAN GT = GT + RES(K6+ILI) END DO GN = RES(K6+1) GR = RES(K6+K) N3 = 3*N Y(N3) = SCON*(2.*AJ+1.)*GN*GR/(GT**2)/ABS(ER) IF(Y(N3).NE.0.) IDO = 1 K6 = K6 + NREP END DO !*****PLOT UNLESS ALL WIDTHS FOR THE PARTIAL ARE ZERO IF(IDO.EQ.0) GO TO 140 CALL PLOTXY(0.,0.,-1,0.,0.,1,'E>o< (eV)',9,'$7>o< (barns)',13) YTYP = YORG + YSIZE + HT + 15.5*HT/7. CALL LETTER(RESTYP(LRF),LRESTP(LRF),XT,YTYP) CALL LETTER('Peak ',5,XT,YT) IF(K.LE.3) THEN CALL LETTER(RETYP(1),LRETP(1),999.,YT) ELSE CALL LETTER('MT = ',5,999.,YT) FLMT = LRX(K-3) CALL DIGITS(FLMT,-1,999.,YT) ENDIF CALL LETTER(' cross section for L = ',23,999.,YT) FLL = L CALL DIGITS(FLL,-1,999.,YT) CALL LETTER(', S = ',6,999.,YT) CALL DIGITS(AS,1,999.,YT) CALL LETTER(', J = ',6,999.,YT) CALL DIGITS(AJ,1,999.,YT) CALL LETTER(' resonances in ',15,999.,YT) CALL LETTER(ZAIBCD,24,999.,YT) CALL ENDPLT 140 CONTINUE GO TO 1000 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE3 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 3 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! READ AND PLOT DATA FOR THE SECTION ! CALL CANT1(ITAPE,QM,QI,L1,LR,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'Cross Section',13) ! ! OUTPUT Q VALUE(S) ! IF(NFOR.GT.5.OR.LR.NE.0) GO TO 20 IF(QI.EQ.0.0) GO TO 50 CALL LETTER('Reaction Q-value = ',19,XT,YT) CALL PENRGY(QI,999.,YT) GO TO 50 20 XB = XT IF(QM.EQ.0.0) GO TO 30 CALL LETTER('Reaction Q-value = ',19,XT,YT) CALL PENRGY(QM,999.,YT) CALL LETTER(' ',1,999.,YT) XB = 999. 30 IF(QI.EQ.0.0) GO TO 50 CALL LETTER('Intermediate State Q-value = ',29,XB,YT) CALL PENRGY(QI,999.,YT) 50 CALL ENDPLT ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE4 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 4 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,LVT,LTT,N1I,N2I,MATI,MFI,MTI COMMON/SFOUR/NL,LCT,E,EG,ES ! PARAMETER (NANG=81,NCOF=64) REAL PL(NANG,NCOF),FL(NCOF) ! EQUIVALENCE (X(1000),PL(1,1)) ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! READ FIRST RECORD ! IF(LVT.EQ.0) THEN CALL CONT(ITAPE,C1,C2,LI,LCT,N1,N2,MAT,MF,MT) ELSE CALL CANT(ITAPE,C1,C2,LI,LCT,NK,NM,MAT,MF,MT,Y) ENDIF ! ! SKIP PLOTS IF ALL ARE ISOTROPIC ! IF(LI.EQ.1) GO TO 200 ! ! PROCESS ALL SUBSECTIONS WHEN ALL NOT ISOTROPIC ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ! ! DATA IS IN THE FORM OF LEGENDRE COEFFICIENTS ! IF(LTT.EQ.2) GO TO 150 ! ! GENERATE TABLES OF LEGENDRE POLYNOMIALS ! CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) DO J=1,NANG X(J) = PL(J,1) END DO ! ! SET UP LOOP OVER ENERGIES ! NP = NANG DO 110 I=1,NE ! ! READ TABLE OF LEGENDRE COEFFICIENTS ! CALL CANT(ITAPE,C1,E,L1,L2,NL,N2,MAT,MF,MT,FL) ! ! RECONSTRUCT AND PLOT ANGULAR DISTRIBUTION ! CALL ANGLAR(Y,FL,PL,NL,NCOF,NANG) INT(1) = 2 NBT(1) = NP NR = 1 CALL PLOT4(1) 110 CONTINUE ! ! SEE IF DUAL REPRESENTATION ! IF(LTT.EQ.1) GO TO 200 CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ! ! DATA IS IN TABULAR FORM ! 150 CONTINUE ! ! SET UP LOOP OVER ENERGIES ! DO 160 I=1,NE ! ! READ TABULATED ANGULAR DISTRIBUTION ! CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! PLOT TABULAR ANGULAR DISTRIBUTION ! CALL PLOT4(1) 160 CONTINUE ! ! SKIP SEND RECORD ! 200 CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,LVT,LTT,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE5 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 5 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,NK,N2I,MATI,MFI,MTI ! PARAMETER (NLAWS=6) CHARACTER(LEN=32) LAWS(NLAWS) INTEGER ILAW(NLAWS) CHARACTER(LEN=2) YLAB(NLAWS) ! DATA LAWS/'Arbitrary Tabulated Function ', & & 'General Evaporation Spectrum ', & & 'Maxwellian Spectrum ', & & 'Evaporation Spectrum ', & & 'Watt Fission Spectrum ', & & 'Madland-Nix Fission Spectrum '/ DATA ILAW/1,5,7,9,11,12/ DATA YLAB/' ','$9','$9','$9','a ','tm'/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS EACH PARTIAL ENERGY DISTRIBUTION ! DO 200 I=1,NK CALL CANT1(ITAPE,U,C2,L1,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! CHECK FOR VALID LAW ! DO 20 J=1,NLAWS IF(LF.EQ.ILAW(J)) GO TO 30 20 CONTINUE GO TO 225 ! ! PLOT PARTIAL PROBABILITY ! 30 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'P(E)',4) CALL LETTER(LAWS(J),32,XT,YT) CALL ENDPLT ! ! TABULAR FUNCTION ! IF(LF.NE.1) GO TO 50 CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) !*****PROCESS EACH INCIDENT ENERGY DO 40 J1=1,NE CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E<$,> (eV)',10,'P(E<$,>)',8) CALL LETTER(LAWS(J),32,XT,YT) CALL LETTER(' - E = ',7,999.,YT) CALL PENRGY(E,999.,YT) CALL ENDPLT 40 CONTINUE GO TO 200 ! ! GENERAL AND SIMPLE EVAPORATION, MAXWELLIAN, WATT AND MADLAND-NIX ! REPRESENTATION ! 50 CALL CANT1(ITAPE,EFL,EFH,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,YLAB(J),2) CALL LETTER(LAWS(J),32,XT,YT) IF(J.NE.6) GO TO 100 CALL LETTER(' E>fl< = ',10,999.,YT) CALL PENRGY(EFL,999.,YT) CALL LETTER(' E>fh< = ',10,999.,YT) CALL PENRGY(EFH,999.,YT) 100 CALL ENDPLT IF(J.NE.2.AND.J.NE.5) GO TO 200 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(J.EQ.5) GO TO 125 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E<$,>/$9',8,'P(E<$,>/$9)',11) GO TO 150 125 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'b ',2) 150 CALL LETTER(LAWS(J),32,XT,YT) CALL ENDPLT ! 200 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! SKIP SECTION IF LAW IS NOT LEGAL ! 225 CALL SKPSEC(ITAPE) GO TO 250 ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE6 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 6 DATA ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,L1I,LTT,NK,N2I,MATI,MFI,MTI COMMON/SFOUR/NL,LCT,E,EP,ES ! CHARACTER(LEN=7) SBCD CHARACTER(LEN=10) ZAPSB ! PARAMETER (NANG=81,NCOF=64) REAL PL(NANG,NCOF),FL(NCOF),Z(50000) ! EQUIVALENCE (X(1000),PL(1,1)) ! PARAMETER (NPARTS=8) CHARACTER(LEN=10) OPARTS(NPARTS) INTEGER IPARTS(NPARTS) PARAMETER (NLAWS=8) CHARACTER(LEN=30) LTEXT(NLAWS) ! DATA OPARTS/'Photons ','Neutrons ', & & 'Protons ','Deuterons ','Tritons ', & & 'Alphas ','Electrons ','Positrons '/ DATA IPARTS/0,1,1001,1002,1003,2004,-1000,1000/ ! DATA LTEXT/'Unknown ', & & 'Continuum Energy-Angle ', & & 'Discrete Two-body ', & & 'Isotropic Discrete Two-body ', & & 'Recoil Two-body ', & & 'Charged Particle Elastic ', & & 'N-body Phase Space ', & & 'Laboratory Angle-Energy '/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS EACH PARTIAL DISTRIBUTION ! LCT = LTT DO 190 I=1,NK CALL CANT1(ITAPE,ZAP,C2,LIP,LAW,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! SET PRODUCT TEXT STRING ! IZAP = ABS(ZAP) + .001 IF(ZAP.LT.0.) IZAP = -IZAP DO 20 J=1,NPARTS IF(IPARTS(J).EQ.IZAP) THEN ZAPSB = OPARTS(J) GO TO 25 ENDIF 20 CONTINUE CALL NUSYM(ZAP,SBCD,NSBCD,IERR) ZAPSB = SBCD 25 CALL SCOUNT(ZAPSB,NZS) ! ! OUTPUT YIELDS ! CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'Particle Yield',14) CALL LETTER('Yield of ',9,XT,YT) CALL LETTER(ZAPSB,NZS,999.,YT) IF(LIP.GT.0) THEN CALL LETTER(' Partial ',9,999.,YT) CALL DIGITS(FLOAT(LIP),-1,999.,YT) ENDIF IF(LCT.EQ.2) THEN CALL LETTER(' in the CM system,',18,999.,YT) ELSE CALL LETTER(' in the Lab system,',19,999.,YT) ENDIF CALL LETTER(' Law type is ',15,999.,YT) CALL LETTER(LTEXT(LAW+1),30,999.,YT) CALL ENDPLT ! ! BRANCH ON LAW ! IF(LAW.GT.7) GO TO 200 LF = LAW + 1 SELECT CASE (LF) ! ! TABULAR FUNCTION ! CASE (2) ! CALL CANT2(ITAPE,C1,C2,LANG,LEP,NR,NE,MAT,MF,MT,NBT,INT) LCT = LCT + 3 LTT = 2 !*****ANGULAR DISTRIBUTIONS TO BE RECONSTRUCTED FROM LEGENDRE COEFF IF(LANG.GT.2) GO TO 40 LTT = 1 CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) ! ! PROCESS EACH INCIDENT PARTICLE ENERGY ! 40 DO 70 K=1,NE CALL CANT(ITAPE,C1,E,ND,NA,NW,NEP,MAT,MF,MT,Z) NREPT = NW/NEP ! ! PLOT EMITTED PARTICLE ENERGY DISTRIBUTION ! IF(ND.EQ.0) GO TO 45 !*****DISCRETE EMITTED ENERGIES NP = 1 X(1) = .95*Z(1) Y(1) = 0.0 DO 43 N=1,ND IND = NREPT*(N-1) + 1 NP = NP + 3 X(NP-2) = Z(IND) Y(NP-2) = 0.0 X(NP-1) = Z(IND) Y(NP-1) = Z(IND+1) X(NP) = Z(IND) Y(NP) = 0.0 43 CONTINUE NP = NP + 1 X(NP) = 1.05*Z(IND) Y(NP) = 0.0 INT(1) = 1 NBT(1) = NP NR = 1 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E<$,> (eV)',10, & & 'f(E,E<$,>)',10) CALL LETTER('Discrete Distribution of ',25,XT,YT) CALL LETTER(ZAPSB,NZS,999.,YT) CALL LETTER(' at E = ',8,999.,YT) CALL PENRGY(E,999.,YT) CALL ENDPLT !*****CONTINUUM EMITTED ENERGIES 45 IF(ND.EQ.NEP) GO TO 48 NP = 0 DO 46 N=ND+1,NEP IND = NREPT*(N-1) + 1 NP = NP + 1 X(NP) = Z(IND) Y(NP) = Z(IND+1) 46 CONTINUE INT(1) = LEP NBT(1) = NP NR = 1 CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E<$,> (eV)',10, & & 'f(E,E<$,>)',10) CALL LETTER('Continuum Distribution of ',26,XT,YT) CALL LETTER(ZAPSB,NZS,999.,YT) CALL LETTER(' at E = ',8,999.,YT) CALL PENRGY(E,999.,YT) CALL ENDPLT ! ! PLOT ANGULAR DISTRIBUTIONS FOR EACH EMITTED ENERGY ! 48 IF(NA.EQ.0) GO TO 70 IF(LANG.GT.10) GO TO 50 DO J=1,NANG X(J) = PL(J,1) END DO NP = NANG 50 DO 65 N=1,NEP IOFF = NREPT*(N-1) + 2 EP = Z(IOFF-1) BNORM = Z(IOFF) IF(BNORM.EQ.0.) GO TO 65 !*****LEGENDRE COEFFICIENTS IF(LANG.GT.10) GO TO 55 IF(LANG.EQ.2) GO TO 52 NL = NA DO NN=1,NA FL(NN) = Z(IOFF+NN)/BNORM END DO CALL ANGLAR(Y,FL,PL,NL,NCOF,NANG) GO TO 54 !*****KALBACH-MANN REPRESENTATION 52 NL = 6 EPM = EP/1.0E+06 ECM = (AWRI*E)/(AWRI+AWI)/1.0E+6 IZA1 = NSUB/10 IZA2 = NINT(ZAP) IZAT = NINT(ZAI) AKAL = BACH(IZA1,IZA2,IZAT,ECM,EPM) RKAL = Z(IOFF+1) CALL KALB(AKAL,RKAL,X,Y,NANG) 54 INT(1) = 2 NBT(1) = NP NR = 1 CALL PLOT4(LANG) GO TO 65 !*****TABULAR 55 NP = 0 DO NN=1,NA,2 NP = NP + 1 X(NP) = Z(IOFF+NN) Y(NP) = Z(IOFF+NN+1) END DO INT(1) = LANG - 10 NBT(1) = NP NR = 1 CALL PLOT4(LANG) 65 CONTINUE 70 CONTINUE LCT = LCT - 3 ! ! DISCRETE TWO BODY SCATTERING ! CASE (3) ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ! ! PROCESS EACH INCIDENT ENERGY ! DO 100 K=1,NE CALL CANT(ITAPE,C1,E,LANG,L2,NW,NL,MAT,MF,MT,Z) !*****ANGULAR DISTRIBUTIONS TO BE RECONSTRUCTED FROM LEGENDRE COEFF IF(LANG.NE.0) GO TO 85 LTT = 1 CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) DO J=1,NANG X(J) = PL(J,1) END DO NP = NANG DO NN=1,NL FL(NN) = Z(NN) END DO CALL ANGLAR(Y,FL,PL,NL,NCOF,NANG) INT(1) = 2 NBT(1) = NP NR = 1 CALL PLOT4(LANG) GO TO 100 !*****TABULAR 85 LTT = 2 NP = 0 DO NN=1,NW,2 NP = NP + 1 X(NP) = Z(NN) Y(NP) = Z(NN+1) END DO INT(1) = LANG - 10 NBT(1) = NP NR = 1 CALL PLOT4(LANG) 100 CONTINUE ! ! CHARGED PARTICLE ELASTIC ! CASE (6) CALL CANT2(ITAPE,SPI,C2,LIDP,L2,NR,NE,MAT,MF,MT,NBT,INT) DO 175 K=1,NE CALL CANT(ITAPE,C1,E,LTP,L2,NW,NL,MAT,MF,MT,Z) IF(LTP.LE.10) GO TO 175 !*****TABULAR LTT = 2 NP = 0 DO NN=1,NW,2 NP = NP + 1 X(NP) = Z(NN) Y(NP) = Z(NN+1) END DO INT(1) = LTP - 10 NBT(1) = NP NR = 1 CALL PLOT4(0) 175 CONTINUE ! ! LABORATORY ANGLE-ENERGY ! CASE (8) ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) DO 185 N=1,NE CALL CANT2(ITAPE,C1,E,L1,L2,NRM,NMU,MAT,MF,MT,NBT,INT) DO NM=1,NMU CALL CANT1(ITAPE,C1,FMU,L1,L2,NREP,NEP,MAT,MF,MT,NBT,INT,X,Y) NR = NREP NP = NEP CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E<$,> (eV)',10, & & 'f(E,$5,E<$,>)',13) CALL LETTER('distribution of ',16,XT,YT) CALL LETTER(ZAPSB,NZS,999.,YT) CALL LETTER(' at E = ',8,999.,YT) CALL PENRGY(E,999.,YT) CALL LETTER(' and $5 = ',10,999.,YT) CALL CIPHER(FMU,0.01*FMU,999.,YT) CALL ENDPLT END DO 185 CONTINUE ! END SELECT 190 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! INVALID LAW, SKIP REST OF SECTION ! 200 CALL SKPSEC(ITAPE) ! ! CHECK FOR NEW SECTION OR END OF FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,LCT,NK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE KALB(A,R,X,Y,NA) ! ! CALCULATE AN ANGULAR DISTRIBUTION FOR KALBACH REPRESENTATION ! REAL X(NA),Y(NA) ! DO 20 NN=1,NA W = X(NN) T = 0.5*A*(COSH(A*W)+R*SINH(A*W))/SINH(A) IF (T.LT.0.) THEN Y(NN) = 0.0 ELSE Y(NN) = T ENDIF 20 CONTINUE ! RETURN END ! !*********************************************************************** ! FUNCTION BACH(IZA1,IZA2,IZAT,E,EP) ! ! COMPUTE THE KALBACH A PARAMETER (R.MACFARLANE, LANL) ! REAL AC,AB,NC,NB,ZC,ZB ! IZA=IZAT IF (IZA.EQ.6000) IZA=6012 IF (IZA.EQ.12000) IZA=12024 IF (IZA.EQ.14000) IZA=14028 IF (IZA.EQ.16000) IZA=16032 IF (IZA.EQ.17000) IZA=17035 IF (IZA.EQ.19000) IZA=19039 IF (IZA.EQ.20000) IZA=20040 IF (IZA.EQ.22000) IZA=22048 IF (IZA.EQ.23000) IZA=23051 IF (IZA.EQ.24000) IZA=24052 IF (IZA.EQ.26000) IZA=26056 IF (IZA.EQ.50000) IZA=50120 IF (IZA.EQ.74000) IZA=74184 IF (IZA.EQ.82000) IZA=82208 AA=MOD(IZA,1000) IF (AA.EQ.0.) THEN BACH = 0 RETURN ENDIF ZA=IZA/1000 AC=AA+MOD(IZA1,1000) ZC=ZA+IZA1/1000 AB=AC-MOD(IZA2,1000) ZB=ZC-IZA2/1000 NA=NINT(AA-ZA) NB=NINT(AB-ZB) NC=NINT(AC-ZC) SA=15.68*(AC-AA) & & -28.07*((NC-ZC)**2/AC-(NA-ZA)**2/AA) & & -18.56*(AC**0.66667-AA**0.66667) & & +33.22*((NC-ZC)**2/AC**1.33333-(NA-ZA)**2/AA**1.33333) & & -0.717*(ZC**2/AC**.33333-ZA**2/AA**.33333) & & +1.211*(ZC**2/AC-ZA**2/AA) IF (IZA1.EQ.1002) SA=SA-2.22 IF (IZA1.EQ.1003) SA=SA-8.48 IF (IZA1.EQ.2003) SA=SA-7.72 IF (IZA1.EQ.2004) SA=SA-28.3 SB=15.68*(AC-AB) & & -28.07*((NC-ZC)**2/AC-(NB-ZB)**2/AB) & & -18.56*(AC**0.66667-AB**0.66667) & & +33.22*((NC-ZC)**2/AC**1.33333-(NB-ZB)**2/AB**1.33333) & & -0.717*(ZC**2/AC**.33333-ZB**2/AB**.33333) & & +1.211*(ZC**2/AC-ZB**2/AB) IF (IZA2.EQ.1002) SB=SB-2.22 IF (IZA2.EQ.1003) SB=SB-8.48 IF (IZA2.EQ.2003) SB=SB-7.72 IF (IZA2.EQ.2004) SB=SB-28.3 ECM=AA*E/AC EA=ECM*1.E-6+SA EB=1.E-6*EP*AC/AB+SB X1=EB IF (EA.GT.130.) X1=130.*EB/EA X3=EB IF (EA.GT.41.) X3=41.*EB/EA FA=1. IF (IZA1.EQ.2004) FA=0. FB=1. IF (IZA2.EQ.1) FB=.5 IF (IZA2.EQ.2004) FB=2. BACH=0.04*X1+1.8E-6*X1**3+6.7E-7*FA*FB*X3**4 ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE7 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 7 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,LTHR,LAT,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=60) PTITLE CHARACTER(LEN=3) CNS REAL B(30),CFLAG(4) ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! INCOHERENT INELASTIC SCATTERING ! IF(LTHR.GT.0) GO TO 150 ! ! READ IN CONSTANTS ! CALL CANT(ITAPE,C1,C2,LLN,L2,NL,NS,MAT,MF,MT,B) DO NNN=1,NS+1 CFLAG(NNN) = B(6*(NNN-1)+1) END DO ! ! PROCESS S(ALPHA,BETA) IF PRESENT ! IF(CFLAG(1).LE.0.) GO TO 125 CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NB,MAT,MF,MT,NBT,INT) !*****LOOP OVER ALL BETA VALUES DO 100 J=1,NB CALL CANT1(ITAPE,T,BETA,LT,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) IF(LLN.NE.1) THEN CALL PLOTXY(0.,0.,-1,0.,0.,-1,'$0',2,'S($0,$1)',8) ELSE CALL PLOTXY(0.,0.,-1,0.,0.,-1,'$0',2,'ln S($0,$1)',11) ENDIF WRITE(PTITLE,25) T,BETA 25 FORMAT('Temperature = ',1PE11.4,' $.K $1 = ',1PE11.4) CALL LETTER(PTITLE,48,XT,YT) CALL ENDPLT !*****PROCESS ALL ADDITIONAL TEMPERATURES IF(LT.LE.0)GO TO 100 DO 50 K=1,LT CALL CANT(ITAPE,T,C2,INTER,L2,NP,N2,MAT,MF,MT,Y) IF(LLN.NE.1) THEN CALL PLOTXY(0.,0.,-1,0.,0.,-1,'$0',2,'S($0,$1)',8) ELSE CALL PLOTXY(0.,0.,-1,0.,0.,-1,'$0',2,'ln S($0,$1)',11) ENDIF WRITE(PTITLE,25) T,BETA CALL LETTER(PTITLE,48,XT,YT) CALL ENDPLT 50 CONTINUE 100 CONTINUE ! ! PROCESS EFFECTIVE TEMPERATURE RECORD ! 125 IF(NFOR.LT.6) GO TO 225 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'Moderator Temperature ($.K)', & & 27,'Effective Temperature ($.K)',27) PTITLE = 'Effective Temperature Table Principle Atom' CALL LETTER (PTITLE,42,XT,YT) CALL ENDPLT IF(NS.LE.0) GO TO 225 DO 140 NN=1,NS IF(CFLAG(NN+1).GT.0.) GO TO 140 CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'Moderator Temperature ($.K)', & & 27,'Effective Temperature ($.K)',27) WRITE(CNS,145) NS 145 FORMAT(I3) PTITLE(29:) = 'Minor Atom '//CNS CALL LETTER (PTITLE,42,XT,YT) CALL ENDPLT 140 CONTINUE GO TO 225 ! ! COHERENT ELASTIC SCATTERING ! 150 IF(LTHR.NE.1) GO TO 200 CALL CANT1(ITAPE,T,C2,LT,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'Energy (eV)',11,'Factor',6) WRITE(PTITLE,175) T 175 FORMAT('Coherent Elastic Structure Factors at T =',1PE11.4) CALL LETTER(PTITLE,52,XT,YT) CALL ENDPLT !*****PROCESS ALL ADDITIONAL TEMPERATURES IF(LT.LE.0)GO TO 250 DO 190 K=1,LT CALL CANT(ITAPE,T,C2,INTER,L2,NP,N2,MAT,MF,MT,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'Energy (eV)',11,'Factor',6) WRITE(PTITLE,175) T CALL LETTER(PTITLE,52,XT,YT) CALL ENDPLT 190 CONTINUE GO TO 250 ! ! INCOHERENT ELASTIC SCATTERING ! 200 IF(LTHR.NE.2) GO TO 250 CALL CANT1(ITAPE,SB,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'Temperature ($.K)',17, & & 'Debye-Waller Integral/A',23) WRITE(PTITLE,210) SB 210 FORMAT('Elastic Incoherent Cross Section =',1PE11.4,' barns') CALL LETTER(PTITLE,51,XT,YT) CALL ENDPLT ! ! SKIP SEND RECORD ! 225 CALL SKPREC(ITAPE,1) GO TO 250 ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,LTHR,LAT,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 8 ! COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,NSP,MATI,MFI,MTI ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 100 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) IF(MTI.EQ.454.OR.MTI.EQ.459) GO TO 20 IF(MTI.EQ.457) GO TO 30 ! ! RADIOACTIVE NUCLIDE PRODUCTION, NO PLOTTING REQUIRED ! CALL SKPSEC(ITAPE) GO TO 100 ! ! FISSION PRODUCT YIELDS ! 20 CALL FILE8B CALL HEADIN(0,0,MTI,-1.0) GO TO 100 ! ! DECAY DATA ! 30 CALL HEADIN(0,0,MTI,-1.0) CALL FILE8C(NSP) ! ! LOOK FOR FILE END CARD ! 100 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,NSP,MATI,MFI,MTI) IF(MFI.NE.0) GO TO 5 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8B ! ! FISSION PRODUCT YIELDS ! COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! CREATE NEW PLOT HEADING FOR SECTION ! MFBCD = ' Fission Product Yields' ! ! READ FIRST SECTION ! CALL CANT(ITAPE,E,C2,LE,L2,N2NFP,NFP,MATI,MFI,MTI,X) CALL PLOT8B(E,NFP) ! ! READ AND PLOT REMAINING SECTIONS ! IF(LE.LE.0)GO TO 100 DO 50 I=1,LE CALL CANT(ITAPE,E,C2,INTE,L2,N2NFP,NFP,MATI,MFI,MTI,X) CALL PLOT8B(E,NFP) 50 CONTINUE ! ! SKIP SEND RECORD ! 100 CALL SKPREC(ITAPE,1) ! RETURN END ! !*********************************************************************** ! SUBROUTINE PLOT8B(E,NFP) ! ! PLOT FISSION PRODUCT YIELD VERSUS MASS NUMBER CURVE ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT ! PARAMETER (IMAX=250) ! ! INITIALIZE MASS YIELDS AND MASS RANGE ! DO I=1,IMAX Y(I) = 0.0 END DO JMAX = 0 JMIN = IMAX ! ! PROCESS EACH YIELD TO GET MASS YIELDS ! I = 0 DO J=1,NFP IWEIGH = AMOD(X(I+1),1000.) + .001 IF(IWEIGH.LT.1.OR.IWEIGH.GT.250) GO TO 40 JMIN = MIN0(JMIN,IWEIGH) JMAX = MAX0(JMAX,IWEIGH) Y(IWEIGH) = Y(IWEIGH) + X(I+3) 40 I = I + 4 END DO ! ! PREPARE PLOTTING ARRAYS ! NP = 0 DO 50 J=JMIN,JMAX IF(Y(J).LE.0.0) GO TO 50 NP = NP + 1 X(NP) = J Y(NP) = Y(J) 50 CONTINUE NR = 1 INT(1) = 2 NBT(1) = NP ! ! PLOT MASS YIELD CURVE ! CALL PLOTXY(0.,0.,0,0.,0.,1,'Atomic weight',13, & & 'Fractional yield',16) ! ! PLOT INCIDENT ENERGY FOR TITLE ! IF(E.LE.0.) GO TO 100 CALL LETTER('E = ',3,XT,YT) CALL PENRGY(E,999.,YT) 100 CALL ENDPLT ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE8C(NSP) ! ! DECAY DATA ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT ! CHARACTER(LEN=2) ITIME CHARACTER(LEN=15) ERAD CHARACTER(LEN=23) EAV INTEGER INT2(100),NBT2(100) REAL X1(500),Y1(500),X2(2000),Y2(2000),R(12) ! EQUIVALENCE (X1(1),X(2501)),(Y1(1),Y(2501)),(X2(1),X(3001)), & ! & (Y2(1),Y(3001)),(INT2(1),INT(101)),(NBT2(1),NBT(101)) ! PARAMETER (NTIMES=4) CHARACTER(LEN=2) NTIME(NTIMES) REAL TIMAX(NTIMES) PARAMETER (NTYPES=11) CHARACTER(LEN=5) ATYP(NTYPES) INTEGER NCTYP(NTYPES) REAL MC2 ! DATA NTIME/' m',' h',' d',' y'/ DATA TIMAX/60.,60.,24.,365.25/ DATA ATYP/'$2 ','$1<->','$1<+>','it ','$0 ', & & 'n ','sf ','p ','e<-> ','x ','$= '/ DATA NCTYP/2,5,5,2,2,1,2,1,4,1,2/ ! DATA MC2/1.022E+6/ ! ! READ FIRST RECORD ! CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,X) HL = C1 DHL = C2 ITIME = 's' DO I=1,NTIMES TIM = TIMAX(I) IF(HL.LT.TIM) GO TO 20 ITIME = NTIME(I) HL = HL/TIM DHL = DHL/TIM END DO ! ! CREATE NEW PLOT HEADING FOR SECTION ! 20 MFBCD = ' Radioactive Decay Data ' ! ! READ LIST OF DECAY MODES ! CALL CANT(ITAPE,C1,C2,L1,L2,N1,NDK,MAT,MF,MT,X) ! ! READ ENERGY/INTENSITY AND PLOT ! IF(NSP.EQ.0) GO TO 250 DO 200 I4=1,NSP CALL CANT(ITAPE,C1,STYP,LCON,L2,N6,NER,MAT,MF,MT,R) IF(LCON.EQ.0.AND.NER.EQ.0) GO TO 200 FD = R(1) FC = R(5) AVER = R(3) DAVER = R(4) ND = 0 NC = 0 LCOV = 0 ! ! CREATE RADIATION TYPE TITLE ! NTYP = STYP + 1.001 MTBCD = ' '//ATYP(NTYP) ML = 10 + NCTYP(NTYP) MTBCD(ML:) = ' radiation' ! ! PROCESS DISCRETE RADIATIONS ! IF(LCON.EQ.1) GO TO 40 DO 30 N=1,NER CALL CANT(ITAPE,ER,DER,L1,L2,NT,N2,MAT,MF,MT,R) ND = ND + 1 IF(NTYP.NE.3) GO TO 25 X1(ND) = ER - MC2 Y1(ND) = R(5)*FD IF(ER.LE.MC2) ND = ND - 1 GO TO 30 25 X1(ND) = ER Y1(ND) = R(3)*FD 30 CONTINUE ! ! PROCESS CONTINUUM SPECTRUM ! 40 IF(LCON.EQ.0) GO TO 60 CALL CANT1(ITAPE,RTYP,C2,L1,LCOV,NR,NC,MAT,MF,MT,NBT2,INT2, & & X2,Y2) IRTYP = RTYP + .0001 IF(NTYP.EQ.6.AND.IRTYP.EQ.6) GO TO 60 DO I=1,NC Y2(I) = Y2(I)*FC END DO ! ! MERGE DISCRETE AND CONTINUUM SPECTRA ! 60 ID = 1 IC = 1 YC = 0.0 NP = 0 JINT = 1 IF(LCON.NE.1) GO TO 65 INT(1) = INT2(1) X1(1) = 1.E30 GO TO 75 65 IF(LCON.NE.0) GO TO 70 INT(1) = 1 NR = 1 X2(1) = 1.E30 NP = 1 X(NP) = .9*X1(ID) Y(NP) = 0. GO TO 75 70 INT(1) = INT2(1) X2(NC+1) = 2.*X2(NC) Y2(NC+1) = Y2(NC) ! ! ENERGY OF DISCRETE GT ENERGY OF CONTINUUM ! 75 IF(X1(ID).LT.X2(IC)) GO TO 125 NP = NP + 1 X(NP) = X2(IC) Y(NP) = Y2(IC) NBT(JINT) = NP IC = IC + 1 IF(IC.GT.NC) GO TO 100 80 IF(IC.LE.NBT2(JINT).OR.JINT.GE.NR) GO TO 90 JINT = JINT + 1 INT(JINT) = INT2(JINT) GO TO 80 90 IF(X1(ID).NE.X2(IC-1)) GO TO 75 YC = Y2(IC-1) GO TO 120 ! ! ALL CONTINUUM POINTS MERGED ! 100 IF(ND.EQ.0) GO TO 140 NP = NP + 1 X(NP) = X(NP-1) Y(NP) = 0.0 NBT(JINT) = NP YC = 0.0 X2(IC) = 1.E30 NC = 0 GO TO 75 ! ! ENERGY OF DISCRETE LT ENERGY OF THE CONTINUUM ! 110 NP = NP + 1 X(NP) = X1(ID) Y(NP) = YC 120 NP = NP + 1 X(NP) = X1(ID) Y(NP) = YC + Y1(ID) NP = NP + 1 X(NP) = X1(ID) Y(NP) = YC NBT(JINT) = NP ID = ID + 1 IF(ID.GT.ND) GO TO 130 IF(X1(ID).GE.X2(IC)) GO TO 75 125 IF(LCON.EQ.0) GO TO 110 CALL TERP1(X2(IC-1),Y2(IC-1),X2(IC),Y2(IC),X1(ID),YC,INT2(JINT)) GO TO 110 ! ! ALL DISCRETE GAMMAS MERGED ! 130 IF(NC.EQ.0) GO TO 140 X1(ID) = 1.E30 ND = 0 GO TO 75 ! ! ALL POINTS MERGED ! 140 IF(LCON.GT.0) GO TO 150 NP = NP + 1 X(NP) = 1.1*X(NP-1) Y(NP) = 0.0 NBT(JINT) = NP 150 NR = JINT ! ! MAKE X-AXIS LABEL ! ERAD = 'E>'//ATYP(NTYP) ML = 3 + NCTYP(NTYP) ERAD(ML:) = '< (eV)' MU = ML + 6 ! ! PLOT SPECTRUM ! IF(LCON.NE.0) GO TO 175 CALL GETLIM(XDMIN,XDMAX,YDMIN,YDMAX,1) YDMIN = .5*YDMIN CALL PLOTXY(0.0,0.0,-1,YDMIN,YDMAX,1,ERAD,MU,'Intensity',9) GO TO 180 175 CALL PLOTXY(0.0,0.0,-1,0.0,0.0,-1,ERAD,MU,'Intensity',9) ! ! WRITE TITLE LINE ! 180 CALL LETTER('t>1/2< = ',9,XT,YT) CALL CIPHER(HL,DHL,999.,YT) CALL LETTER(' $+ ',4,999.,YT) CALL CIPHER(DHL,DHL,999.,YT) CALL LETTER(ITIME,2,999.,YT) EAV = ' $'//ATYP(NTYP) ML = 12 + NCTYP(NTYP) EAV(ML:) = '<$> = ' MU = ML + 5 CALL LETTER(EAV,MU,999.,YT) CALL CIPHER(AVER,DAVER,999.,YT) CALL LETTER(' $+ ',4,999.,YT) CALL CIPHER(DAVER,DAVER,999.,YT) CALL LETTER(' eV',3,999.,YT) CALL ENDPLT ! ! SKIP OVER ANY COVARIANCE RECORD ! IF(LCOV.EQ.0) GO TO 200 CALL CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,X) 200 CONTINUE ! ! SKIP SEND RECORD ! 250 CALL SKPREC(ITAPE,1) ! RETURN END ! !*********************************************************************** ! SUBROUTINE FILE9 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 9 AND 10 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,NS,N2I,MATI,MFI,MTI ! CHARACTER(LEN=15) YLABEL(2) INTEGER YLEN(2) ! DATA YLABEL/'$RATIO','$CROSS $SECTION'/ DATA YLEN/6,15/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ITP = MFI - 8 ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS AND PLOT ALL PARTIAL RADIOACTIVE NUCLIDE PRODUCTION ! DO 50 N=1,NS CALL CANT1(ITAPE,C1,Q,LISO,LFSO,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'$E (E$V)',8,YLABEL(ITP),YLEN(ITP)) CALL LETTER('Q =',3,XT,YT) CALL CIPHER(Q,0.0001*Q,999.,YT) CALL LETTER(' MeV',4,999.,YT) CALL LETTER(' target level = ',16,999.,YT) CALL DIGITS(FLOAT(LISO),-1,999.,YT) CALL LETTER(' residual nucleus level = ',26,999.,YT) CALL DIGITS(FLOAT(LFSO),-1,999.,YT) CALL ENDPLT 50 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NS,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE12 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 12 AND 13 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,LO,LG,NSNK,N2I,MATI,MFI,MTI ! CHARACTER(LEN=15) YLABEL(2) INTEGER YLEN(2) ! DATA YLABEL/'Yield','Cross Section'/ DATA YLEN/5,13/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ITP = MFI - 11 ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! BRANCH ON REPRESENTATION ! IF(LO.EQ.2) GO TO 200 ! ! DATA ARE MULTIPLICITIES OR CROSS SECTIONS ! NK=NSNK IF(NK.LE.1) GO TO 25 ! ! READ AND PLOT TOTAL PHOTON PRODUCTION ! CALL CANT1(ITAPE,C1,C2,LP,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,YLABEL(ITP),YLEN(ITP)) CALL LETTER('Total $2 Production',19,XT,YT) CALL ENDPLT ! ! PROCESS AND PLOT ALL PARTIAL PHOTON PRODUCTION ! 25 DO 50 N=1,NK CALL CANT1(ITAPE,EG,ES,LP,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,YLABEL(ITP),YLEN(ITP)) !*****CONTINUUM GAMMA PRODUCTION IF(EG.GT.0.) GO TO 30 CALL LETTER('Continuum $2 Production',23,XT,YT) GO TO 45 !*****DISCRETE GAMMA PRODUCTION 30 CALL LETTER('production of E>$2< = ',22,XT,YT) CALL PENRGY(EG,999.,YT) IF(LP.EQ.1) CALL LETTER(' (primary)',10,999.,YT) IF(LP.EQ.2) CALL LETTER(' (nonprimary)',13,999.,YT) CALL LETTER(' E>L< = ',8,999.,YT) IF(ES.NE.0.) CALL PENRGY(ES,999.,YT) IF(ES.EQ.0.) CALL LETTER('Unknown',7,999.,YT) 45 CALL ENDPLT 50 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) GO TO 250 ! ! TRANSITION PROBABILITIES SO SKIP PLOTTING ! 200 CALL SKPSEC(ITAPE) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,LO,LG,NSNK,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE14 ! ! ROUTINE TO PROCESS FILE 14 DATA ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,LI,LTT,NK,NI,MATI,MFI,MTI COMMON/SFOUR/NL,LCT,E,EG,ES ! PARAMETER (NANG=81,NCOF=64) REAL PL(NANG,NCOF),FL(NCOF) ! EQUIVALENCE (X(1000),PL(1,1)) ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! SKIP PLOTS IF ALL ARE ISOTROPIC ! IF(LI.EQ.1) GO TO 225 ! ! PROCESS ALL SUBSECTIONS WHEN ALL NOT ISOTROPIC ! LCT = 3 DO 200 N=1,NK ! ! AN ISOTROPIC PHOTON DISTRIBUTION SO SKIP IT ! IF(N.LE.NI) GO TO 200 ! ! NON-ISOTROPIC PHOTON ! CALL CANT2(ITAPE,ES,EG,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ! ! DATA IS IN THE FORM OF LEGENDRE COEFFICIENTS ! IF(LTT.GT.1) GO TO 150 ! ! GENERATE TABLES OF LEGENDRE POLYNOMIALS ! CALL LEGEND(PL,NCOF,NANG,1.0,-1.0) DO J=1,NANG X(J) = PL(J,1) END DO ! ! SET UP LOOP OVER ENERGIES ! NP = NANG DO 110 I=1,NE ! ! READ TABLE OF LEGENDRE COEFFICIENTS ! CALL CANT(ITAPE,C1,E,L1,L2,NL,N2,MAT,MF,MT,FL) ! ! RECONSTRUCT AND PLOT ANGULAR DISTRIBUTION ! CALL ANGLAR(Y,FL,PL,NL,NCOF,NANG) INT(1) = 2 NBT(1) = NP NR = 1 CALL PLOT4(1) 110 CONTINUE GO TO 200 ! ! DATA IS IN TABULAR FORM ! 150 CONTINUE ! ! SET UP LOOP OVER ENERGIES ! DO 160 I=1,NE ! ! READ TABULATED ANGULAR DISTRIBUTION ! CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! PLOT TABULAR ANGULAR DISTRIBUTION ! CALL PLOT4(0) 160 CONTINUE 200 CONTINUE ! ! SKIP SEND RECORD ! 225 CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,LI,LTT,NK,NI,MATI,MFI,MTI) IF(MFI.NE.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE15 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 15 ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,L1I,L2I,NC,N2I,MATI,MFI,MTI ! CHARACTER(LEN=41) PTITLE DATA PTITLE/'Arbitrary tabulated function at E = '/ DATA NTIT/36/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) ! ! PROCESS ALL SUBSECTIONS ! DO 200 I=1,NC CALL CANT1(ITAPE,C1,C2,L1,LF,NR,NP,MAT,MF,MT,NBT,INT,X,Y) ! ! PLOT PROBABILITY FOR THE SUBSECTION ! CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E (eV)',6,'P(E)',4) CALL ENDPLT ! ! READ ENERGY INTERPOLATION ! CALL CANT2(ITAPE,C1,C2,L1,L2,NR,NE,MAT,MF,MT,NBT,INT) ! ! PROCESS TABULAR DISTRIBUTION FOR EACH INCIDENT ENERGY ! DO 150 J1=1,NE CALL CANT1(ITAPE,C1,E,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,'E>$2< (eV)',10,'P(E>$2<)',8) CALL LETTER(PTITLE,NTIT,XT,YT) CALL PENRGY(E,999.,YT) CALL ENDPLT 150 CONTINUE 200 CONTINUE ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,NC,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE FILE23 ! ! ROUTINE TO CONTROL PROCESSING OF FILE 23 AND 27 DATA ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=18) XLAB(3) INTEGER LXLAB(3) CHARACTER(LEN=13) YLAB(3) INTEGER LYLAB(3) ! DATA XLAB/'E (eV) ','Momentum (1./ang)', & & 'E (eV) '/ DATA LXLAB/6,17,6/ DATA YLAB/'$7 (barns) ','Form factor','Factor'/ DATA LYLAB/10,12,6/ ! ! IS FILE TO BE PLOTTED? ! CALL ISFILE(ISKIP) IF(ISKIP.EQ.0) GO TO 5 CALL SKPFIL(ITAPE) GO TO 1000 ! ! SET IDENTIFICATION FOR THE FILE ! 5 CALL HEADIN(MATI,MFI,0,ZAI) ! ! IS SECTION TO BE PLOTTED? ! 10 CALL ISSECT(ISKIP) IF(ISKIP.EQ.0) GO TO 15 CALL SKPSEC(ITAPE) GO TO 250 ! ! SET SECTION IDENTIFICATION INFORMATION ! 15 CALL HEADIN(0,0,MTI,-1.0) IHEAD = 1 IF(MFI.EQ.27) THEN IF(MTI.EQ.505.OR.MTI.EQ.506) THEN IHEAD = 3 ELSE IHEAD = 2 ENDIF ENDIF ! ! READ AND PLOT DATA FOR THE SECTION ! CALL CANT1(ITAPE,C1,C2,L1,L2,NR,NP,MAT,MF,MT,NBT,INT,X,Y) CALL PLOTXY(0.,0.,-1,0.,0.,-1,XLAB(IHEAD),LXLAB(IHEAD), & & YLAB(IHEAD),LYLAB(IHEAD)) CALL ENDPLT ! ! SKIP SEND RECORD ! CALL SKPREC(ITAPE,1) ! ! DETERMINE IF THERE ARE MORE SECTIONS IN THE FILE ! 250 CALL CONT(ITAPE,ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI) IF(MFI.GT.0) GO TO 10 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE PLOT4(LANG) ! ! ROUTINE TO PLOT AN ANGULAR DISTRIBUTION ! COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/IODATA/INPUT,OUTPUT,ITAPE INTEGER OUTPUT COMMON/HEADI/ZAI,AWRI,LI,LTT,NK,NI,MATI,MFI,MTI COMMON/SFOUR/NL,LCT,E,EG,ES ! ! PLOT THE DATA ! CALL PLOTXY(1.0,-1.0,0,0.0,0.0,-1,'$5',2,'d$7/d$5/$7',10) ! ! HEADING FOR PLOT OF DATA RECONSTRUCTED FROM LEGENDRE COEFFICIENTS ! IF(LTT.EQ.1) THEN IF(LANG.NE.2) THEN CALL LETTER('Reconstructed from ',19,XT,YT) CALL DIGITS(FLOAT(NL+1),-1,999.,YT) CALL LETTER(' Legendre coef.',15,999.,YT) ELSE CALL LETTER('Kalbach-Mann Systematics',24,XT,YT) ENDIF ELSE ! ! HEADING FOR TABULAR DATA ! CALL LETTER(' Tabulated values ',18,XT,YT) ENDIF ! ! BRANCH FOR LAB, CM OR PHOTON DATA ! SELECT CASE (LCT) ! CASE (1,4) CALL LETTER(' in the Lab system at ',22,999.,YT) CASE (2,5) CALL LETTER(' in the CM system at ',21,999.,YT) CASE (3) CALL LETTER(' at ',4,999.,YT) ! END SELECT ! ! ADD INCIDENT NEUTRON ENERGY TO HEADING ! CALL LETTER(' E = ',5,999.,YT) CALL PENRGY(E,999.,YT) ! ! ADD GAMMA AND SOURCE ID FOR PHOTONS ! IF(LCT.NE.3) GO TO 90 !*****DISCRETE PHOTONS IF(EG.EQ.0.0) GO TO 80 CALL LETTER(' E>$2< = ',9,999.,YT) CALL PENRGY(EG,999.,YT) CALL LETTER(' E>$L< = ',9,XT,YT) IF(ES.GT.0.) CALL PENRGY(ES,999.,YT) IF(ES.EQ.0.) CALL LETTER('Unknown',7,999.,YT) GO TO 100 !*****CONTINUUM PHOTONS 80 CALL LETTER(' for the continuum',18,999.,YT) ! ! ADD SECONDARY ENERGY FOR FILE 6 ! 90 IF(LCT.LT.4) GO TO 100 CALL LETTER(' for E<$,> = ',13,999.,YT) CALL PENRGY(EG,999.,YT) ! 100 CALL ENDPLT ! RETURN END ! !*********************************************************************** ! SUBROUTINE ISFILE(ISKIP) ! ! ROUTINE TO DETERMINE IF CURRENT FILE HAS BEEN SELECTED FOR ! PLOTTING ! COMMON/INDAT/IOPT,NLABEL COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! NO TEST IF ALL FILES REQUIRED ! IF(IOPT.EQ.1.OR.NMF.EQ.0) GO TO 20 ! ! INITIALIZE TO SKIP THE FILE ! ISKIP = 1 ! ! CHECK LIST OF FILES IN REQUEST ! DO 10 J=1,NMF IF(MFI.LT.MFL(J).OR.MFI.GT.MFU(J)) GO TO 10 MFJ = J GO TO 20 10 CONTINUE GO TO 100 ! ! FILE SHOULD BE PROCESSED ! 20 ISKIP = 0 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE ISSECT(ISKIP) ! ! ROUTINE TO DETERMINE IF CURRENT FILE HAS BEEN SELECTED FOR ! PLOTTING ! COMMON/INDAT/IOPT,NLABEL COMMON/REQUST/RTAPE,MATN(30),ZAN(30),NMAT,MFJ,MFL(12),MFU(12),NMF,& & MTN(20,12) INTEGER RTAPE COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! ! NO TEST IF ALL FILES REQUIRED ! IF(IOPT.EQ.1.OR.MTN(1,MFJ).EQ.0) GO TO 30 ! ! INITIALIZE TO SKIP THE FILE ! ISKIP = 1 ! ! SEE IF SECTION NEEDED ! DO 20 I=1,20 IF(MTN(I,MFJ).EQ.0) GO TO 100 IF(MTN(I,MFJ).LT.0) GO TO 20 IF(MTN(I,MFJ).EQ.MTI) GO TO 30 IF(I.EQ.20) GO TO 20 IF(MTI.GT.MTN(I,MFJ).AND.MTI.LE.(-MTN(I+1,MFJ))) GO TO 30 20 CONTINUE GO TO 100 ! ! FILE SHOULD BE PROCESSED ! 30 ISKIP = 0 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE PLOTXY(XLEFTI,XRITEI,LGLNXI,YDOWNI,YUPI,LGLNYI, & & BCDX,NBCDX,BCDY,NBCDY) ! ! ROUTINE TO CONTROL PLOTTING OF A FUNCTION Y(X) ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT ! CHARACTER(LEN=*) BCDX,BCDY PARAMETER (PLTSTP=.001) ! ! INITIATE NEW PLOT ! CALL MOVEON(1) ! ! GET DATA LIMITS ! LGY = LGLNYI CALL GETLIM(XMIN,XMAX,YDOWN,YUP,LGY) IF(YDOWN.NE.0.0.OR.YUP.NE.0.0) GO TO 3 YDOWN = -0.5 YUP = 0.5 ! ! DETERMINE X-AXIS PARAMETERS ! 3 LGLNX = LGLNXI !*****USE INPUT INDEPENDENT VARIABLE LIMITS IF(XLEFTI.EQ.XRITEI) GO TO 5 XMIN = XLEFTI XMAX = XRITEI ! ! AN ANGULAR DISTRIBUTION ! IF(XMIN.NE.1.0.OR.XMAX.NE.-1.) GO TO 5 LGLNX = 0 XMIN = -1. XMAX = 1. AXMIN = 1. AXMAX = -1. AXSTEP = -.25 NXTICK = 5 GO TO 12 ! ! DETERMINE X AXIS GRID PARAMETERS ! 5 NDIV = XSIZE/(10.*HT) IF(LGLNXI.GE.0) GO TO 7 CALL DECIDE(XMIN,XMAX,NDIV,LGLNX,AXMIN,AXMAX,AXSTEP,NXTICK) GO TO 12 7 IF(LGLNXI.NE.0) GO TO 10 CALL AXLIN(XMIN,XMAX,NDIV,AXMIN,AXMAX,AXSTEP,NXTICK) GO TO 12 10 CALL AXLOG(XMIN,XMAX,NDIV,AXMIN,AXMAX,AXSTEP,NXTICK) IF(NXTICK.GE.0) GO TO 12 LGLNX = 0 NXTICK = -NXTICK ! ! DETERMINE Y-AXIS PARAMETERS ! 12 LGLNY = LGLNYI !*****USE INPUT DEPENDENT VARIABLE LIMITS IF(YDOWNI.EQ.YUPI) GO TO 15 YDOWN = YDOWNI YUP = YUPI ! ! DETERMINE Y-AXIS GRID PARAMETERS ! 15 NDIV = YSIZE/.75 IF(LGLNYI.GE.0) GO TO 20 CALL DECIDE(YDOWN,YUP,NDIV,LGLNY,AYMIN,AYMAX,AYSTEP,NYTICK) GO TO 30 20 IF(LGLNYI.NE.0) GO TO 25 CALL AXLIN(YDOWN,YUP,NDIV,AYMIN,AYMAX,AYSTEP,NYTICK) GO TO 30 25 CALL AXLOG(YDOWN,YUP,NDIV,AYMIN,AYMAX,AYSTEP,NYTICK) IF(NYTICK.GE.0) GO TO 30 LGLNY = 0 NYTICK = -NYTICK ! ! GENERATE PLOT AXES ! 30 CALL STICKX(1) CALL XRULER(XORG,YORG,XSIZE,LGLNX,AXMIN,AXMAX,AXSTEP,NXTICK,1, & & BCDX,NBCDX) CALL STICKX(-1) CALL XRULER(XORG,YORG+YSIZE,XSIZE,LGLNX,AXMIN,AXMAX,AXSTEP,NXTICK,& & 0,' ',0) CALL STICKY(1) CALL YRULER(XORG,YORG,YSIZE,LGLNY,AYMIN,AYMAX,AYSTEP,NYTICK,1, & & BCDY,NBCDY) CALL STICKY(-1) CALL YRULER(XORG+XSIZE,YORG,YSIZE,LGLNY,AYMIN,AYMAX,AYSTEP,NYTICK,& & 0,' ',0) ! ! LIMIT PLOT RANGE TO THE AREA INSIDE THE PLOT ! YTOP = YORG + YSIZE XTOP = XORG + XSIZE ! ! SET NATURAL PLOT INTERPOLATION ! LAWPLT = 2*LGLNY + LGLNX + 2 ! ! INITIALIZE LIMITS WHEN PAGING SYSTEM NOT USED ! IF(NCONT.GT.0) GO TO 35 NA = 1 NB = NP NN = NP ! ! IS ANY DATA WITHIN PLOT RANGE ! 35 NOFSET = NA - 1 NU = NB - NA + 1 IF(X(1).LE.XMAX.AND.X(NU).GE.XMIN) GO TO 40 IF(NB.EQ.NN) GO TO 300 XPRE = X(NU) YPRE = Y(NU) CALL RDTAB(X,Y) GO TO 35 ! ! FIND FIRST POINT TO BE PLOTTED ! 40 DO 45 I=1,NU IF(X(I).GE.XMIN) GO TO 50 45 CONTINUE GO TO 250 50 IF(I.EQ.1) GO TO 55 XPRE = X(I-1) YPRE = Y(I-1) 55 I1 = I ! ! FIND PROPER INTERPOLATION CODE FOR FIRST POINT ! IOFF = I + NOFSET JINT = 1 60 CONTINUE IF(IOFF.LE.NBT(JINT)) GO TO 65 JINT = JINT + 1 IF(JINT.GT.NR) JINT = NR GO TO 60 65 LAWCRV = MOD(INT(JINT),10) IF(LAWCRV.EQ.6) LAWCRV = 5 ! ! FIND BEGINNING OF PLOTTED CURVE ! IF(IOFF.GT.1) GO TO 75 XLAST = SCALEX(X(I1)) XPRE = X(I1) YPRE = Y(I1) I1 = I1 + 1 !*****HISTOGRAM PLOT IF(LAWCRV.GT.1) GO TO 70 CALL MOVETO(XLAST,YORG) YLAST = YORG - .1 IF(Y(I1-1).GE.AYMIN) YLAST = SCALEY(Y(I1-1)) IF(YLAST.GE.YORG) CALL DRAWTO(XLAST,YLAST) IF(YLAST.LT.YORG) CALL MOVETO(XLAST,YORG) GO TO 100 !*****LINEAR PLOT 70 IF(Y(I1-1).GE.AYMIN) GO TO 72 YLAST = SCALEY(AYMIN) GO TO 74 72 YLAST = SCALEY(Y(I1-1)) 74 CALL MOVETO(XLAST,YLAST) GO TO 100 ! ! FIRST POINT IN PLOT NOT FIRST IN TABLE ! 75 XLAST = SCALEX(XMIN) !*****HISTOGRAM PLOT IF(LAWCRV.GT.1) GO TO 80 YLAST = YORG - .1 IF(YPRE.GE.AYMIN) YLAST = SCALEY(YPRE) GO TO 90 !*****LINEAR PLOT 80 CALL TERP1(XPRE,YPRE,X(I1),Y(I1),XMIN,YBOUND,LAWCRV) YLAST = SCALEY(YBOUND) 90 CALL MOVETO(XLAST,YLAST) ! ! LOOP OVER EACH POINT ! 100 IDONE = 0 DO 200 I=I1,NU !*****FIND INTERPOLATION CODE IOFF = I + NOFSET IF(IOFF.LE.NBT(JINT)) GO TO 110 JINT = JINT + 1 IF(JINT.GT.NR) JINT = NR LAWCRV = MOD(INT(JINT),10) IF(LAWCRV.EQ.6) LAWCRV = 5 ! ! HISTOGRAM PLOT ! 110 IF(LAWCRV.GT.1) GO TO 125 XLAST = SCALEX(X(I)) XLAST = AMIN1(XLAST,XTOP) IF(YLAST.LT.YORG) CALL MOVETO(XLAST,YORG) IF(YLAST.GE.YORG) CALL DRAWTO(XLAST,YLAST) IF(XLAST.GE.XTOP) GO TO 300 YLAST = YORG - .1 IF(Y(I).GE.AYMIN) YLAST = SCALEY(Y(I)) IF(YLAST.LT.YORG) CALL MOVETO(XLAST,YORG) IF(YLAST.GE.YORG) CALL DRAWTO(XLAST,YLAST) XPRE = X(I) YPRE = Y(I) GO TO 200 ! ! LINEAR PLOT ! 125 X1 = XPRE Y1 = YPRE X2 = X(I) Y2 = Y(I) IF(X2.LE.XMAX) GO TO 130 X2 = XMAX IDONE = 1 CALL TERP1(X1,Y1,X(I),Y(I),X2,Y2,LAWCRV) ! ! PLOT MODE DIFFERS FROM INTERPOLATION MODE SO POINTS MUST BE ! INSERTED TO PRESERVE SHAPE ! 130 IF(LAWPLT.EQ.LAWCRV) GO TO 190 XST = X2 YST = Y2 ! ! FIND A POINT WHERE MODES DIFFER BY LESS THAN PLTSTP ! 160 IF(ABS(XLAST-SCALEX(X2)).LT.PLTSTP) GO TO 190 XI = (X1+X2)/2. CALL TERP1(X1,Y1,X2,Y2,XI,YCRV,LAWCRV) CALL TERP1(X1,Y1,X2,Y2,XI,YPLT,LAWPLT) IF(ABS(SCALEY(YCRV)-SCALEY(YPLT)).LT.PLTSTP) GO TO 165 X2 = XI Y2 = YCRV GO TO 160 ! ! POINT FOUND SO DRAW LINE ! 165 XLAST = SCALEX(X2) YLAST = SCALEY(Y2) YDIST = AMIN1(YLAST,YTOP) YDIST = AMAX1(YDIST,YORG) CALL DRAWTO(XLAST,YDIST) X1 = X2 Y1 = Y2 X2 = XST Y2 = YST GO TO 160 ! ! NO FURTHER ITERATION REQUIRED ! 190 XLAST = SCALEX(X2) YLAST = SCALEY(Y2) YDIST = AMIN1(YLAST,YTOP) YDIST = AMAX1(YDIST,YORG) CALL DRAWTO(XLAST,YDIST) IF(IDONE.EQ.1) GO TO 300 XPRE = X2 YPRE = Y2 200 CONTINUE ! ! GET NEXT PAGE ! 250 IF(NB.EQ.NN) GO TO 300 CALL RDTAB(X,Y) I1 = 1 NU = NB - NA + 1 NOFSET = NA - 1 GO TO 100 ! ! RESTORE TO INITIAL PAGE IN CORE ! 300 IF(NCONT.GT.0) CALL RDTAB(X,Y) ! RETURN END ! !*********************************************************************** ! SUBROUTINE TERP1(XA,YA,XB,YB,XI,YI,I) ! ! INTERPOLATE ONE POINT============================================= ! (XA,YA) AND(XB,YB) ARE THE END POINTS OF THE LINE ! I IS THE INTERPOLATION CODE ! (XI,YI) IS THE INTERPOLATED POINT ! NOTE- IF A NEGATIVE OR ZERO ARGUMENT OF A LOG IS ! DETECTED, THE INTERPOLATION CODE IS AUTOMATICALLY ! CHANGED FROM LOG TO LINEAR ! IMPLICIT NONE ! INTEGER(KIND=4) I REAL(KIND=4) XA,YA,XB,YB,XI,YI ! IF(I.EQ.1) THEN YI = YA ELSE IF(I.EQ.2) THEN YI = YA + (XI-XA)*(YB-YA)/(XB-XA) ELSE IF(I.EQ.3) THEN IF(XA.LE.0..OR.XB.LE.0.) THEN YI = YA + (XI-XA)*(YB-YA)/(XB-XA) ELSE YI = YA + ALOG(XI/XA)*(YB-YA)/ALOG(XB/XA) END IF ELSE IF(I.EQ.4) THEN IF(YA.LE.0..OR.YB.LE.0.) THEN YI = YA + (XI-XA)*(YB-YA)/(XB-XA) ELSE YI = YA*EXP((XI-XA)*ALOG(YB/YA)/(XB-XA)) END IF ELSE IF(I.EQ.5) THEN IF(YA.LE.0..OR.YB.LE.0.) THEN IF(XA.LE.0..OR.XB.LE.0.) THEN YI = YA + (XI-XA)*(YB-YA)/(XB-XA) ELSE YI = YA + ALOG(XI/XA)*(YB-YA)/ALOG(XB/XA) END IF ELSE IF(XA.LE.0..OR.XB.LE.0.) THEN YI = YA*EXP((XI-XA)*ALOG(YB/YA)/(XB-XA)) ELSE IF(XI.LE.0.) THEN YI = YA + ALOG(XI/XA)*(YB-YA)/ALOG(XB/XA) ELSE YI = YA*EXP(ALOG(XI/XA)*ALOG(YB/YA)/ALOG(XB/XA)) END IF END IF END IF ! 100 RETURN END SUBROUTINE TERP1 ! !*********************************************************************** ! SUBROUTINE MOVEON(ITOP) ! ! ROUTINE TO INITIATE A NEW PLOT AND OPTIONALLY PUT A TITLE ON IT ! COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR COMMON/PLTDEP/ULIM,VLIM,HT,THETA,XORG,YORG,XSIZE,YSIZE,XT,YT COMMON/HEADI/ZAI,AWRI,L1I,L2I,N1I,N2I,MATI,MFI,MTI ! CHARACTER(LEN=80) LINE ! DATA FRAME/0.0/ ! ! INITIALIZE NEW PLOT ! CALL BGNPLT(VLIM,ULIM) CALL THITE(HT) CALL TANGLE(THETA) FRAME = FRAME + 1. WRITE(6,5) FRAME,MATI,MFI,MTI 5 FORMAT(' FRAME NO. - ',F5.0,I7,I3,'/',I3) ! ! OUTPUT TITLING INFO ! IF(ITOP.EQ.0) GO TO 100 WWD = 6.*HT/7. YLIN1 = YORG + YSIZE + HT + 27.5*HT/7. YLIN2 = YLIN1 - 12.*HT/7. ! ! ISOTOPE IDENTIFICATION ! X= XORG CALL LETTER(ZABCD,24,X,YLIN1) ! ! REACTION TYPE ! X = XORG + 0.5*XSIZE - 15.*WWD CALL LETTER(MTBCD,30,X,YLIN1) ! ! LIBRARY AND MATERIAL NUMBER ! LINE = LIBBCD CALL SCOUNT(LINE,NLL) IF(NREL.GT.0) THEN WRITE(LINE(NLL+1:),'(A,I2.2,A)') ', Rel.-',NREL,' Mat. No.' ELSE NLN = MAX0(16,NLL+2) WRITE(LINE(NLN:),'(A)') 'Material No.' ENDIF CALL SCOUNT(LINE,NLL) WRITE(LINE(NLL+2:),'(I4.4)') MATIN NLL = NLL + 5 X = XORG + XSIZE - FLOAT(NLL)*WWD CALL LETTER(LINE,NLL,X,YLIN1) ! ! DATA TYPE ! X = XORG + 0.5*XSIZE - 24.*WWD CALL LETTER(MFBCD,48,X,YLIN2) ! ! ADD MF/MT NUMBERS ! X = XORG + XSIZE - 14.*WWD CALL LETTER('MF/MT = ',8,X,YLIN2) CALL DIGITS(FLOAT(MFI),-1,999.,YLIN2) CALL LETTER('/',1,999.,YLIN2) CALL DIGITS(FLOAT(MTI),-1,999.,YLIN2) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE GETLIM(XMIN,XMAX,YDOWN,YUP,IGY) ! ! ROUTINE TO GET EXTREMA LIMITS FROM A TAB1 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN COMMON/XYDATA/X(50000),Y(50000),NP,INT(200),NBT(200),NR ! PARAMETER (YMIN=1.E-15) ! ! INITIALIZE MINIMA AND MAXIMA ! XMIN = 1.E20 XMAX = -1.E20 YDOWN = 1.E20 YUP = -1.E20 ! ! INITIALIZE LIMITS WHEN PAGING SYSTEM NOT USED ! IF(NCONT.GT.0) GO TO 20 NA = 1 NB = NP NN = NP ! ! PROCESS ALL X-Y PAIRS ! 20 NU = NB - NA + 1 DO 50 N=1,NU XMIN = AMIN1(XMIN,X(N)) XMAX = AMAX1(XMAX,X(N)) IF(IGY.EQ.1.AND.Y(N).LE.YMIN) GO TO 50 YDOWN = AMIN1(YDOWN,Y(N)) YUP = AMAX1(YUP,Y(N)) 50 CONTINUE ! ! GET NEXT PAGE ! IF(NB.EQ.NN) GO TO 100 CALL RDTAB(X,Y) GO TO 20 ! ! RESTORE TO INITIAL PAGE IN CORE ! 100 IF(NCONT.GT.0) CALL RDTAB(X,Y) ! RETURN END ! !*********************************************************************** ! SUBROUTINE PENRGY(E,XP,YP) ! ! ROUTINE TO PLOT AN ENERGY AS TEXT IN COMMON UNITS ! CHARACTER(LEN=6) UNITS(3) DATA UNITS/' eV ',' keV ',' MeV '/ ! ISCF = 0 IF(ABS(E).GE.1.E+3) ISCF = 1 IF(ABS(E).GE.1.E+6) ISCF = 2 ET = E*10.0**(-3*ISCF) CALL CIPHER(ET,ET*0.0001,XP,YP) CALL LETTER(UNITS(ISCF+1),5,999.,YP) ! RETURN END ! !*********************************************************************** ! SUBROUTINE LIBID(NLIB,NVER,LIBBCD) ! ! ROUTINE TO GENERATE LIBRARY ID FROM NLIB AND NVER ! CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=1) TCHAR CHARACTER(LEN=14) LIBTMP ! PARAMETER (NLIBS=13) CHARACTER(LEN=8) TLIBS(NLIBS) INTEGER LIBS(NLIBS) CHARACTER(LEN=5) NUMS(20) ! DATA TLIBS/'ENDF/B ','ENDF/A ','JEF ','EFF ', & & 'ENDF/HE ','CENDL ','JENDL ','INDL/V ', & & 'INDL/A ','INDL/F ','IRDF ','BROND ', & & 'UNKNOWN '/ DATA LIBS/0,1,2,3,4,5,6,31,32,33,34,41,99/ ! DATA NUMS/'I','II','III','IV','V','VI','VII','VIII', & & 'IX','X','XI','XII','XIII','XIV','XV','XVI','XVII', & & 'XVIII','XIX','?????'/ ! ! FIND LIBRARY ID ! DO 10 I=1,NLIBS-1 IF(NLIB.EQ.LIBS(I)) GO TO 15 10 CONTINUE I = NLIBS ! ! BUILD LIBRARY ID ! 15 IF(NLIB.NE.0.AND.NLIB.NE.4) GO TO 30 INVER = NVER IF(NVER.LT.1.OR.NVER.GT.19) INVER = 20 WRITE(LIBTMP,20) TLIBS(I),NUMS(INVER) 20 FORMAT(A8,'-',A5) GO TO 45 30 IF(NLIB.EQ.2) THEN WRITE(LIBTMP,35) TLIBS(I),NVER/10,MOD(NVER,10) 35 FORMAT(A8,'-',I2,'.',I1) ELSE WRITE(LIBTMP,40) TLIBS(I),NVER 40 FORMAT(A8,'-',I5) ENDIF ! ! PACK ID LEFT JUSTIFIED ! 45 LIBBCD = ' ' NCF = 0 DO 50 N=1,14 TCHAR = LIBTMP(N:N) IF(TCHAR.EQ.' ') GO TO 50 NCF = NCF + 1 LIBBCD(NCF:NCF) = TCHAR 50 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE HEADIN(MAT,MF,MT,ZA) ! ! ROUTINE TO CREATE AND STORE EXPANDED TEXT FOR ZA, MF AND MT ! COMMON/TOPPER/LIBBCD,MFBCD,MTBCD,ZABCD CHARACTER(LEN=14) LIBBCD CHARACTER(LEN=48) MFBCD CHARACTER(LEN=30) MTBCD CHARACTER(LEN=24) ZABCD COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! ! SAVE MAT NUMBER IF GREATER THAN ZERO ! IF(MAT.GT.0) MATIN = MAT ! ! IF MF IS POSITIVE CHANGE FILE IDENTIFICATION ! IF(MF.GT.0) CALL MFID(NSUB,MF,MT,MFBCD,IERR) ! ! IF MT IS POSITIVE CHANGE REACTION IDENTIFICATION ! IF(MT.GT.0) CALL MTID(NFOR,NSUB,MT,MTBCD,IERR) ! ! IF IZ IS POSITIVE CHANGE ISOTOPE IDENTIFICATION ! IF(ZA.GT.0.0) CALL ZAID(ZA,ZABCD,IERR) ! RETURN END ! !*********************************************************************** ! SUBROUTINE ZAID(ZA,BCD,IERR) ! ! CONSTRUCTION OF THE ALPHANUMERIC REPRESENTATION OF AN ISOTOPE ! HAVING A GIVEN ATOMIC NUMBER AND WEIGHT. IF THE ATOMIC NUMBER IS ! LESS THAN OR EQUAL TO ZERO THE ISOTOPE IS ASSUMED TO BE A NATURAL ! ELEMENT ! ! SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS..... ! ZA = 1000.*Z + A ! BCD =RESULTING ALPHANUMERIC EQUIVALENT. ! IERR =ERROR INDICATOR. SET EQUAL TO ONE IF IZ IS NOT IN THE RANGE ! 1 TO 104, OR IA IS NOT IN THE RANGE 1 TO 999. IT IS ! SET EQUAL TO ZERO IF BOTH ARE IN ACCEPTABLE RANGE. ! ! THE NAME OF THE ELEMENT FOLLOWED BY ITS ATOMIC NUMBER IS LEFT ! ADJUSTED INTO ID. FOR NATURAL MATERIALS THE WORD 'NATURAL' ! FOLLOWED BY THE ELEMENT NAME IS USED INSTEAD. ! COMMON/TOPI/NLIB,NVER,NREL,NSUB,MATIN,AWI,NMOD,NFOR ! CHARACTER(LEN=*) BCD CHARACTER(LEN=24) BCDX CHARACTER(LEN=1) CCHAR ! CHARACTER(LEN=24) GOOF PARAMETER (ISPEC5=20) CHARACTER(LEN=20) SPMAT5(ISPEC5) INTEGER SANUM5(ISPEC5) PARAMETER (ISPEC6=18) CHARACTER(LEN=20) SPMAT6(ISPEC6) INTEGER SANUM6(ISPEC6) CHARACTER(LEN=3) NUMBER(7) CHARACTER(LEN=5) LETTER(3) CHARACTER(LEN=12) SPEED(2) PARAMETER (IELM=109) CHARACTER(LEN=13) ELEMNT(IELM) ! DATA GOOF/'********(ERROR)*********'/ ! ! DEFINE SPECIAL MATERIAL LIBRARY FOR ENDF-5 FORMAT ! DATA SPMAT5/ 'Pure 1/V absorber ', & & 'Pure scatterer ','Water ', & & 'Heavy Water ','Biphenyl ', & & 'Sodium Hydroxide ','Santowax R ', & & 'Dowtherm A ','Benzene ', & & 'Beryllea ','Beryllium Carbide ', & & 'Beryllium Fluoride ','Zirconium Hydride ', & & 'Polystyrene ','Polyethylene ', & & 'Zircalloy 1 ','Zircalloy 2 ', & & '304 Stainless Steel ','Uranium Dioxide ', & & 'Uranium Carbide '/ DATA SANUM5/1,2,100,101,102,103,104,105,106,200, & & 201,202,203,204,205,301,302,304,310,315/ ! ! DEFINE SPECIAL MATERIAL LIBRARY FOR ENDF-6 FORMAT ! DATA SPMAT6/ 'Water ', & & 'Para Hydrogen ','Ortho Hydrogen ', & & 'Hydrogen in ZrH ','Heavy Water ', & & 'Para Deuterium ','Ortho Deuterium ', & & 'Beryllea ','Beryllium Oxide ', & & 'Beryllium Carbide ','Graphite ', & & 'Methane ','S-methane ', & & 'Polyethylene ','Benzene ', & & 'Zirconium in ZrH ','Uranium Dioxide ', & & 'Uranium Carbide '/ DATA SANUM6/1,2,3,7,11,12,13,26,27,28, & & 31,33,34,37,40,58,75,76/ ! ! DEFINE FISSION PRODUCT PARAMETERS ! DATA NUMBER/'23 ','25 ','49 ','41 ','02 ','28 ','40 '/ DATA LETTER/'RSFP ','SSFP ','NSFP '/ DATA SPEED/'SLOW REACTOR','FAST REACTOR'/ ! ! DEFINE ELEMENT NAMES ! DATA (ELEMNT(IJK),IJK=1,10)/ 'Hydrogen ', & & 'Helium ', & & 'Lithium ', & & 'Beryllium ', & & 'Boron ', & & 'Carbon ', & & 'Nitrogen ', & & 'Oxygen ', & & 'Fluorine ', & & 'Neon '/ DATA (ELEMNT(IJK),IJK=11,20)/ 'Sodium ', & & 'Magnesium ', & & 'Aluminum ', & & 'Silicon ', & & 'Phosphorus ', & & 'Sulfur ', & & 'Chlorine ', & & 'Argon ', & & 'Potassium ', & & 'Calcium '/ DATA (ELEMNT(IJK),IJK=21,30)/ 'Scandium ', & & 'Titanium ', & & 'Vanadium ', & & 'Chromium ', & & 'Manganese ', & & 'Iron ', & & 'Cobalt ', & & 'Nickel ', & & 'Copper ', & & 'Zinc '/ DATA (ELEMNT(IJK),IJK=31,40)/ 'Gallium ', & & 'Germanium ', & & 'Arsenic ', & & 'Selenium ', & & 'Bromine ', & & 'Krypton ', & & 'Rubidium ', & & 'Strontium ', & & 'Yttrium ', & & 'Zirconium '/ DATA (ELEMNT(IJK),IJK=41,50)/ 'Niobium ', & & 'Molybdenum ', & & 'Technetium ', & & 'Ruthenium ', & & 'Rhodium ', & & 'Palladium ', & & 'Silver ', & & 'Cadmium ', & & 'Indium ', & & 'Tin '/ DATA (ELEMNT(IJK),IJK=51,60)/ 'Antimony ', & & 'Tellurium ', & & 'Iodine ', & & 'Xenon ', & & 'Cesium ', & & 'Barium ', & & 'Lanthanum ', & & 'Cerium ', & & 'Praseodymium', & & 'Neodymium '/ DATA (ELEMNT(IJK),IJK=61,70)/ 'Promethium ', & & 'Samarium ', & & 'Europium ', & & 'Gadolinium ', & & 'Terbium ', & & 'Dysprosium ', & & 'Holmium ', & & 'Erbium ', & & 'Thulium ', & & 'Ytterbium '/ DATA (ELEMNT(IJK),IJK=71,80)/ 'Lutetium ', & & 'Hafnium ', & & 'Tantalum ', & & 'Tungsten ', & & 'Rhenium ', & & 'Osmium ', & & 'Iridium ', & & 'Platinum ', & & 'Gold ', & & 'Mercury '/ DATA (ELEMNT(IJK),IJK=81,90)/ 'Thallium ', & & 'Lead ', & & 'Bismuth ', & & 'Polonium ', & & 'Astatine ', & & 'Radon ', & & 'Francium ', & & 'Radium ', & & 'Actinium ', & & 'Thorium '/ DATA (ELEMNT(IJK),IJK=91,100)/ 'Protactinium', & & 'Uranium ', & & 'Neptunium ', & & 'Plutonium ', & & 'Americium ', & & 'Curium ', & & 'Berkelium ', & & 'Californium ', & & 'Einsteinium ', & & 'Fermium '/ DATA (ELEMNT(IJK),IJK=101,IELM)/'Mendelevium ', & & 'Nobelium ', & & 'Lawrencium ', & & 'Rutherfordium', & & 'Dubnium', & & 'Seborgium', & & 'Bohrium', & & 'Hassium', & & 'Meitnerium'/ ! ! INITIALIZE ! IERR=0 BCD = ' ' ! ! DETERMINE IZ AND IA ! IZ = ZA/1000. IA = ZA - 1000.*FLOAT(IZ) ! ! DETERMINE IF IZ AND IA ARE IN THE ALLOWABLE RANGE. ! IF(IZ.LT.0.OR.IZ.GT.IELM.OR.IA.GE.1000) GO TO 90 ! ! ZERO Z CORRESPONDS TO SPECIAL MATERIALS. ! IF(IZ.EQ.0) GO TO 50 ! ! ZERO A CORRESPONDS TO NATURAL ELEMENTS ! IF(IA.GT.0) GO TO 20 ! ! CONSTRUCT IDENTIFICATION FOR NATURAL MATERIAL ! BCD = 'Natural '//ELEMNT(IZ) GO TO 100 ! ! BUILD ISOTOPE NAME ! 20 WRITE(BCDX,25) IZ,ELEMNT(IZ),IA 25 FORMAT(I3,'-',A12,'-',I3) ! ! ELIMINATE IMBEDDED BLANKS ! NC = 0 DO 30 I=1,24 CCHAR = BCDX(I:I) IF(CCHAR.EQ.' ') GO TO 30 NC = NC + 1 BCD(NC:NC) = CCHAR 30 CONTINUE GO TO 100 ! ! CHECK AGAINST LIST OF SPECIAL ATOMIC WEIGHTS ! 50 IF(NFOR.GT.5) GO TO 75 IF(IA.GE.400.AND.IA.LE.499) GO TO 70 DO 55 I=1,ISPEC5 IF(IA.EQ.SANUM5(I)) THEN BCD = SPMAT5(I) GO TO 100 ENDIF IF(IA.LT.SANUM5(I)) GO TO 90 55 CONTINUE GO TO 90 ! ! LUMPED FISSION PRODUCTS ! !*****COMPUTE MAJOR FISSION PRODUCT GROUP INDEX. 70 I1=MOD(IA,10)+1 IF(I1.GT.7) GO TO 90 !*****COMPUTE MINOR FISSION PRODUCT GROUP INDEX. I2=MOD(IA,100)/10 IF(I2.GT.5) GO TO 90 !*****DETERMINE CLASS OF REACTOR I3=I2/3+1 I2=MOD(I2,3)+1 !*****LOAD FISSION PRODUCT NUMBER, GROUP AND REACTOR CLASS BCD = NUMBER(I1)//LETTER(I2)//SPEED(I3) GO TO 100 ! ! ENDF-6 ! 75 IAM1 = IA - 100 IF(IAM1.LT.1.OR.IAM1.GT.99) GO TO 90 DO 80 I=1,ISPEC6 IF(IAM1.EQ.SANUM6(I)) THEN BCD = SPMAT6(I) GO TO 100 END IF IF(IAM1.LT.SANUM6(I)) GO TO 90 80 CONTINUE GO TO 90 ! ! IZ AND/OR IA NOT VALID ! 90 BCD = GOOF IERR=1 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE MFID(NSUB,MF,MT,BCD,IERR) ! ! DETERMINE THE ALPHANUMERIC EQUIVALENT FOR EACH FILE NUMBER. ! THE SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS.... ! MF =FILE NUMBER ! BCD =ALPHANUMERIC IDENTIFICATION FOR FILE MF. RETURNED AS ! CHARACTER*48 ! IERR =ERROR INDICATOR. IS SET TO ZERO IF MF IS AN ALLOWED. ! SET EQUAL TO ONE IF MF IS NOT ALLOWED. ! CHARACTER(LEN=48) BCD CHARACTER(LEN=48) GOOF PARAMETER (NMFS=24) CHARACTER(LEN=48) MMF(NMFS) INTEGER IMFS(NMFS) ! DATA GOOF/'********************(ERROR)*********************'/ ! ! DEFINE FILE IDENTIFICATION FOR NEUTRON INTERACTION DATA FILES ! DATA (MMF(IJK),IJK=1,7)/ & & ' Fission Parameters ', & & ' Resonance Parameters ', & & ' Reaction Cross Section ', & & ' Emitted Neutron Angular Distributions ', & & ' Emitted Neutron Energy Distributions ', & & ' Emitted Particle Energy-Angle Distributions ', & & ' Thermal Neutron Scattering Laws '/ DATA (IMFS(IJK),IJK=1,7)/1,2,3,4,5,6,7/ ! ! DEFINE FILE IDENTIFICATION FOR RADIOACTIVE DECAY FILES ! DATA (MMF(IJK),IJK=8,10)/ & & ' Radioactive Reaction Product Information ', & & ' Radioactive Nuclide Production Multiplicities ', & & ' Radioactive Nuclide Production Cross Sections '/ DATA (IMFS(IJK),IJK=8,10)/8,9,10/ ! ! DEFINE FILE IDENTIFICATION FOR PHOTON PRODUCTION FILES ! DATA (MMF(IJK),IJK=11,14)/ & & ' Photon Multiplicities (Neutron Induced) ', & & ' Photon Cross Sections (Neutron Induced) ', & & ' Photon Angular Distributions (Neutron Induced) ', & & ' Photon Energy Distributions (Neutron Induced) '/ DATA (IMFS(IJK),IJK=11,14)/12,13,14,15/ ! ! DEFINE FILE IDENTIFICATION FOR PHOTON INTERACTION FILES ! DATA (MMF(IJK),IJK=15,18)/ & & ' Photon Interaction Cross Section ', & & ' Emitted Particle Energy-Angle Distributions ', & & 'Incoherent and Coherent Photon Form Factor Data ', & & ' Atomic Relaxation Data '/ DATA (IMFS(IJK),IJK=15,18)/23,26,27,28/ ! ! DEFINE FILE IDENTIFICATION FOR COVARIANCE FILES ! DATA (MMF(IJK),IJK=19,NMFS)/ & & ' Nu Bar Covariance Data ', & & ' Resonance Parameter Covariance Data ', & & ' Reaction Cross Section Covariance Data ', & & ' Emitted Neutron Angular Covariance Data ', & & ' Emitted Neutron Energy Covariance Data ', & & ' Radioactive Nuclide Production Covariance Data '/ DATA (IMFS(IJK),IJK=19,NMFS)/31,32,33,34,35,40/ ! ! SEARCH FOR MATCHING FILE NUMBER (MF) ! DO I=1,NMFS IF(MF.LT.IMFS(I)) GO TO 20 IF(MF.EQ.IMFS(I)) GO TO 100 END DO ! ! FILE NUMBER IS NOT RECOGNIZED. SET IDENTIFICATION TO ERROR AND ! ERROR INDICATOR TO ONE. ! 20 BCD = GOOF IERR=1 GO TO 1000 ! ! FILE NUMBER IS RECOGNIZED. SET IDENTIFICATION TO CORRESPONDING ! TEXT AND SET ERROR INDICATOR TO ZERO ! 100 IF(MF.EQ.8) THEN IF(MT.EQ.457) THEN BCD = ' Radioactive Decay Data' ELSE IF(MT.EQ.454.OR.MT.EQ.459) THEN BCD = ' Fission Product Yields' ELSE BCD = MMF(I) ENDIF ELSE IF(MF.EQ.23) THEN IF(NSUB.EQ.113) THEN BCD = ' Electron'//MMF(I)(15:) ELSE BCD = MMF(I) ENDIF ELSE BCD = MMF(I) END IF 250 IERR=0 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE MTID(NFOR,NSUB,MTIN,BCD,IERR) ! ! DETERMINE THE ALPHANUMERIC EQUIVALENT OF A REACTION TYPE NUMBER. ! THE SUBROUTINE ARGUMENTS ARE DEFINED AS FOLLOWS.... ! NSUB =SUBLIBRARY NUMBER (CONTAINS INCIDENT PARTICLE ID) ! MT =REACTION NUMBER ! BCD =ALPHANUMERIC EQUIVALENT OF A REACTION TYPE. RETURNED AS 5A4 ! IERR =ERROR INDICATOR. IF MT IS NOT IN THE LIBRARY IERR IS SET ! EQUAL TO ONE. IF MT O.K. IERR IS SET EQUAL TO ZERO ! CHARACTER(LEN=30) GOOF PARAMETER (NCRS=30) CHARACTER(LEN=*) BCD CHARACTER(LEN=1) CCHAR CHARACTER(LEN=30) BCDT CHARACTER(LEN=20) ILEV,JLEV PARAMETER (NPARTS=8) CHARACTER(LEN=6) PCODES(NPARTS+1) INTEGER ICLEN(NPARTS) INTEGER INMT(NPARTS) INTEGER IPZA(NPARTS) PARAMETER (NSHELS=39) CHARACTER(LEN=4) SHELL(NSHELS) CHARACTER(LEN=3) SUFO(4) PARAMETER (NMTS=93) CHARACTER(LEN=30) MMT(NMTS) INTEGER IMTS(NMTS) ! DATA GOOF/'***********(ERROR)************'/ ! ! DEFINE INCIDENT PARTICLE CODES ! DATA PCODES/'g','n','e','p','d','t','He-3','a',' '/ DATA ICLEN/6*1,4,1/ DATA INMT/102,4,0,103,104,105,106,107/ DATA IPZA/0,1,11,1001,1002,1003,2003,2004/ ! ! DEFINE SUBSHELLS ! DATA SHELL/'K ','L1 ','L2 ','L3 ','M1 ','M2 ','M3 ','M4 ','M5 ', & & 'N1 ','N2 ','N3 ','N4 ','N5 ','N6 ','N7 ','O1 ','O2 ', & & 'O3 ','O4 ','O5 ','O6 ','O7 ','O8 ','O9 ','P1 ','P2 ', & & 'P3 ','P4 ','P5 ','P6 ','P7 ','P8 ','P9 ','P10','P11', & & 'Q1 ','Q2 ','Q3 '/ ! ! DEFINE NUMERICAL SUFFIXES ! DATA SUFO/'-st','-nd','-rd','-th'/ ! ! DEFINE MT NUMBER CODES ! DATA (MMT(IJK),IJK=1,15)/ & & ',Total)', & & ',Elastic)', & & ',Non-Elastic)', & & ',n)', & & ',complex)', & & ',continuum emission)', & & ',2nd)', & & ',2n)', & & ',3n)', & & ',fission)', & & ',f)', & & ',nf)', & & ',2nf)', & & ',na)', & & ',n3a)'/ DATA (IMTS(IJK),IJK=1,15)/1,2,3,4,5,10,11,16,17,18,19,20,21,22,23/ DATA (MMT(IJK),IJK=16,32)/ & & ',2na)', & & ',3na)', & & ',absorption)', & & ',np)', & & ',n2a)', & & ',2n2a)', & & ',nd)', & & ',nt)', & & ',nHe-3)', & & ',nd2a)', & & ',nt2a)', & & ',4n)', & & ',3nf)', & & ',2np)', & & ',3np)', & & ',n2p)', & & ',npa)'/ DATA (IMTS(IJK),IJK=16,32)/24,25,27,28,29,30,32,33,34,35, & & 36,37,38,41,42,44,45/ DATA (MMT(IJK),IJK=33,48)/ & & ',disappearance)', & & ',g)', & & ',p)', & & ',d)', & & ',t)', & & ',He-3)', & & ',a)', & & ',2a)', & & ',3a)', & & ',2p)', & & ',pa)', & & ',t2a)', & & ',d2a)', & & ',pd)', & & ',pt)', & & ',da)'/ DATA (IMTS(IJK),IJK=33,48)/101,102,103,104,105,106,107,108,109, & & 111,112,113,114,115,116,117/ DATA (MMT(IJK),IJK=49,59)/ & & ',resonance data)', & & ',n production)', & & ',g production)', & & ',p production)', & & ',d production)', & & ',t production)', & & ',He-3 production)', & & ',He-4 production)', & & ',pi+ production)', & & ',pi0 production)', & & ',pi- production)'/ DATA (IMTS(IJK),IJK=49,59)/151,201,202,203,204,205,206,207,208, & & 209,210/ DATA (MMT(IJK),IJK=60,70)/ & & ',mu+ production)', & & ',mu- production)', & & ',K+ production)', & & ',K0(long) production)', & & ',K0(short) production)', & & ',K- production)', & & ',anti-p production)', & & ',anti-n production)', & & 'Mu Bar', & & 'Xi', & & 'Gamma'/ DATA (IMTS(IJK),IJK=60,70)/211,212,213,214,214,216,217,128,251, & & 252,253/ DATA (MMT(IJK),IJK=71,78)/ & & 'DOCUMENTATION', & & 'Fission Neutron Yields', & & 'Independent Yields', & & 'Delayed Fission Neutron Yields', & & 'Prompt Fission Neutron Yields', & & 'Decay Data', & & 'Energy Release per Fission', & & 'Cumulative Yields'/ DATA (IMTS(IJK),IJK=71,78)/451,452,454,455,456,457,458,459/ ! ! DEFINE PHOTON REACTIONS ! DATA (MMT(IJK),IJK=79,NMTS)/ & & 'Charged Part. Stopping Power', & & 'Photon Interaction Sigma', & & 'Photon Coherent Scattering ', & & 'Photon Incoherent Scattering', & & 'Imaginary Scattering Factor', & & 'Real Scattering Factor', & & 'Pair Prod.(Electron Field) ', & & 'Total Pair Production', & & 'Pair Prod.(Nuclear Field)', & & 'Photoelectric', & & 'Photo-Excitation', & & 'Electro-Atomic Elastic', & & 'Electro-Atomic Bremsstrahlung', & & 'Electro-Atomic Excitation', & & 'Atomic Relaxation'/ ! DATA (IMTS(IJK),IJK=79,NMTS)/500,501,502,504,505,506,515, & & 516,517,522,523,526,527,528,533/ ! ! INITIALIZE ! IERR = 0 BCD = ' ' MT = MTIN ! ! CONVERT IF INPUT FILE IS IN ENDF-V FORMAT ! IF(NFOR.GT.5) GO TO 30 IF(MT.GT.799) GO TO 30 IF(MT.GE.700) GO TO 10 IF(MT.EQ.602) MT = 522 GO TO 30 10 INDX = MT - 700 IPAR = INDX/20 INDX = INDX - 20*IPAR IF(INDX.EQ.19) INDX = 48 IF(INDX.EQ.18) INDX = 49 MT = 600 + 50*IPAR + INDX ! ! DETERMINE INCIDENT PARTICLE CODE ! 30 IPART = NSUB/10 DO I=1,NPARTS IF(IPART.EQ.IPZA(I)) THEN JPAR = I JPLEN = ICLEN(JPAR) GO TO 40 END IF IF(IPART.LT.IPZA(I)) GO TO 900 END DO CALL NUSYM(FLOAT(IPART),PCODES(NPARTS+1),JPLEN,IERR) IF(IERR.GT.0) GO TO 900 JPAR = NPARTS + 1 ! ! CHECK FOR NEUTRON EXCITED STATES ! 40 IF(MT.LT.50) GO TO 200 IF(MT.GT.91) GO TO 50 IPAR = 2 INDX = MT - 50 GO TO 60 ! ! CHECK FOR PROTON, TRITON, HELIUM-3 AND ALPHA EXCITED STATES ! 50 IF(MT.LT.600) GO TO 150 IF(MT.GT.849) GO TO 250 INDX = MT - 600 IPAR = INDX/50 + 3 INDX = INDX - 50*(IPAR-3) ! ! CREATE STRING TO DESCRIBE EXCITED FINAL STATE ! 60 IPLEN = ICLEN(IPAR) IF(INDX.GT.0) GO TO 75 !*****GROUND STATE ILEV = ') ground state' GO TO 100 !*****EXCITED STATE 75 IF(IPAR.EQ.2.AND.INDX.EQ.41) GO TO 90 IF(IPAR.GT.2.AND.INDX.EQ.49) GO TO 90 IF(NFOR.GT.5.OR.(IPAR.LE.2.OR.INDX.NE.48)) GO TO 78 ILEV = ') redundant' GO TO 100 78 ISUF = MIN0(INDX,4) WRITE(ILEV,80) INDX,SUFO(ISUF) 80 FORMAT(''')',I2,A3,' level') GO TO 95 !*****CONTINUUM 90 ILEV = ''') continuum' 95 IF(IPAR.NE.JPAR) THEN JLEV = ILEV(2:) ILEV = JLEV ENDIF 100 BCDT = '('//PCODES(JPAR)(1:JPLEN)//','//PCODES(IPAR)(1:IPLEN)// & & ILEV GO TO 800 ! ! ENERGY RELEASE RATE PARAMETERS ! 150 IF(MT.LT.301.OR.MT.GT.450) GO TO 180 MTER = MT - 300 WRITE(BCDT,175) MTER 175 FORMAT('E*SIGMA (MT=',I3,')') GO TO 800 ! ! PHOTO ELECTRIC SUBSHELLS ! 180 IF(MT.LT.534.OR.MT.GT.572) GO TO 200 ISHELL = MT - 533 IIND = INDEX(SHELL(ISHELL),' ') - 1 BCDT = SHELL(ISHELL)(1:IIND)//' Photoelectric Subshell' GO TO 800 ! ! SEARCH FOR MATCHING REACTION NUMBER ! 200 DO 210 I=1,NMTS IF(MT.EQ.IMTS(I)) GO TO 220 IF(MT.LT.IMTS(I)) GO TO 900 210 CONTINUE GO TO 900 ! ! TRANSFER REPRESENTATION TO THE ARRAY BCDT ! 220 IF(MT.EQ.INMT(JPAR)) GO TO 230 CCHAR = MMT(I)(1:1) IF(CCHAR.EQ.',') GO TO 225 BCDT = MMT(I) GO TO 800 225 BCDT = '('//PCODES(JPAR)(1:JPLEN)//MMT(I) GO TO 800 !*****SPECIAL CASE OF INELASTIC 230 BCDT = '('//PCODES(JPAR)(1:JPLEN)//',Inelastic)' GO TO 800 ! ! LUMPED REACTION USED IN COVARIANCE FILES ! 250 IF(MT.GT.870) GO TO 900 BCDT = 'Lumped Reaction' GO TO 800 ! ! SECTION NUMBER IS RECOGNIZED. CENTER TEXT ! 800 DO I=NCRS,1,-1 CCHAR = BCDT(I:I) IF(CCHAR.NE.' ') GO TO 820 END DO GO TO 1000 820 INIT = (NCRS-I)/2 + 1 DO J=1,I BCD(INIT:INIT) = BCDT(J:J) INIT = INIT + 1 END DO GO TO 1000 ! ! SECTION NUMBER IS NOT RECOGNIZED, SET IDENTIFICATION TO ERROR ! AND ERROR FLAG TO ONE ! 900 BCD = GOOF IERR = 1 ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE NUSYM(ZA,BCD,NCBCD,IERR) ! ! ROUTINE TO CONSTRUCT A NUCLIDE SYMBOL FROM ITS Z AND A ! CHARACTER(LEN=*) BCD CHARACTER(LEN=6) BCDX CHARACTER(LEN=1) CCHAR ! CHARACTER(LEN=6) GOOF PARAMETER(IELM=109) CHARACTER(LEN=2) ELEMNT(IELM) ! DATA GOOF/'******'/ ! ! DEFINE ELEMENT SYMBOLS ! DATA (ELEMNT(IJK),IJK=1,60)/ & & 'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne', & & 'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca', & & 'Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn', & & 'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ','Zr', & & 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', & & 'Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd'/ DATA (ELEMNT(IJK),IJK=61,IELM)/ & & 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', & & 'Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg', & & 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', & & 'Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm', & & 'Md','No','Lr','Rf','Db','Sg','Bh','Hs','Mt'/ ! ! INITIALIZE ! IERR=0 BCD = ' ' ! ! DETERMINE IZ AND IA ! IZ = ZA/1000. IA = ZA - 1000.*FLOAT(IZ) ! ! DETERMINE IF IZ AND IA ARE IN THE ALLOWABLE RANGE. ! IF(IZ.LT.0.OR.IZ.GT.IELM) GO TO 90 IF(IA.LT.0.OR.IA.GT.999) GO TO 90 ! ! NATURAL ELEMENT ! IF(IA.GT.0) GO TO 20 BCDX = 'nat-'//ELEMNT(IZ) GO TO 28 ! ! BUILD ISOTOPE NAME ! 20 WRITE(BCDX,25) IA,ELEMNT(IZ) 25 FORMAT(I3,'-',A2) ! ! ELIMINATE IMBEDDED BLANKS ! 28 NC = 0 DO 30 I=1,6 CCHAR = BCDX(I:I) IF(CCHAR.EQ.' ') GO TO 30 NC = NC + 1 BCD(NC:NC) = CCHAR 30 CONTINUE NCBCD = NC GO TO 100 ! ! IZ AND/OR IA NOT VALID ! 90 BCD = GOOF NCBCD = 6 IERR = 1 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE TEXTR(ITAPE,TEXT,MAT,MF,MT) ! ! SUBROUTINE TO READ A TEXT RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! CHARACTER(LEN=66) TEXT ! NCONT = 0 READ(ITAPE,10) TEXT,MAT,MF,MT 10 FORMAT(A66,I4,I2,I3) RETURN ! END ! !*********************************************************************** ! SUBROUTINE CONT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT) ! ! READ A CONT RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! NCONT = 0 READ(ITAPE,10) C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! RETURN END ! !*********************************************************************** ! SUBROUTINE CANT(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,B) ! ! READ A LIST RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! REAL B(*) ! ! READ CONT RECORD ! NCONT = 0 READ(ITAPE,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ IN ARRAY ! READ(ITAPE,20) (B(I),I=1,N1) 20 FORMAT(6E11.4) ! RETURN END ! !*********************************************************************** ! SUBROUTINE CANT1(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NBT,INT,X,Y) ! ! READ A TAB1 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! INTEGER NBT(20),INT(20) REAL X(*),Y(*) ! ! READ CONT RECORD ! NCONT = 0 READ(ITAPE,10)C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ INTERPOLATION TABLE ! READ(ITAPE,20) (NBT(I),INT(I),I=1,N1) 20 FORMAT(6I11) ! ! READ IN ARRAY ! IF(N2.GT.MAXY)GO TO 50 READ(ITAPE,30) (X(I),Y(I),I=1,N2) 30 FORMAT(6E11.4) GO TO 100 ! ! POINT LIMIT IS EXCEDED SO CREATE PAGING FILE ! 50 CALL OPSCR(1) NCONT = 3*(MAXY/3) ! ! FILL PAGING FILE ! 70 NU = MIN0(NCONT,N2-NN) READ(ITAPE,30) (X(I),Y(I),I=1,NU) WRITE(NSCR) (X(I),Y(I),I=1,NU) NN = NN + NU IF(NN.LT.N2) GO TO 70 ! ! LOAD FIRST PAGE INTO CORE ! CALL OPSCR(2) CALL RDTAB(X,Y) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE CANT2(ITAPE,C1,C2,L1,L2,N1,N2,MAT,MF,MT,NBT,INT) ! ! READ A TAB2 RECORD ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! INTEGER NBT(20),INT(20) ! ! READ CONT RECORD ! NCONT = 0 READ(ITAPE,10) C1,C2,L1,L2,N1,N2,MAT,MF,MT 10 FORMAT(2E11.4,4I11,I4,I2,I3) ! ! READ INTERPOLATION TABLE ! READ(ITAPE,20) (NBT(I),INT(I),I=1,N1) 20 FORMAT(6I11) ! RETURN END ! !*********************************************************************** ! SUBROUTINE OPSCR(INEW) ! ! ROUTINE TO INITIALIZE A PAGING FILE ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! LOGICAL SCROPN ! ! BRANCH ON OPTION ! IF(INEW.EQ.2) GO TO 50 ! ! DELETE ANY EXISTING FILE ! NCONT = 0 INQUIRE(UNIT=NSCR,OPENED=SCROPN) IF(SCROPN) CLOSE(UNIT=NSCR,STATUS='DELETE') ! ! OPEN NEW PAGE FILE ! OPEN(UNIT=NSCR,STATUS='NEW',ACCESS='SEQUENTIAL', & & FORM='UNFORMATTED') NN = 0 GO TO 100 ! ! PREPARE PAGE FILE FOR READING ! 50 ENDFILE (UNIT=NSCR) REWIND (UNIT=NSCR) NA = 0 NB = 0 ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE RDTAB(X,Y) ! ! ROUTINE TO READ A PAGE OF A TAB1 RECORD FROM SCRATCH ! COMMON/XYCONT/NSCR,MAXY,NCONT,NA,NB,NN ! REAL X(50000),Y(50000) ! 10 NA = NB + 1 NB = MIN0(NB+NCONT,NN) NU = NB - NA + 1 IF(NU.GT.0) GO TO 20 REWIND (UNIT=NSCR) NB = 0 GO TO 10 20 READ(NSCR) (X(I),Y(I),I=1,NU) ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPMAT(ITAPE) ! ! SKIP REMAINDER OF A DATA SET (MATERIAL) ! 10 READ(ITAPE,20) MAT 20 FORMAT(66X,I4) IF(MAT.GT.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPFIL(ITAPE) ! ! SKIP THE REMAINDER OF A FILE ! 10 READ(ITAPE,20) MF 20 FORMAT(70X,I2) IF(MF.NE.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPSEC(ITAPE) ! ! SKIP THE REMAINDER OF A SECTION ! 10 READ(ITAPE,20) MT 20 FORMAT(72X,I3) IF(MT.NE.0) GO TO 10 ! RETURN END ! !*********************************************************************** ! SUBROUTINE SKPREC(ITAPE,I) ! ! SKIP I RECORDS ! DO 20 J=1,I READ(ITAPE,10) MT 10 FORMAT(72X,I3) 20 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE LEGEND(P,N,M,X0,X1) ! ! GENERATE A TABLE OF LEGENDRE POLYNOMIAL FROM P1 TO PN AT M ! EQUALLY SPACED POINTS SUCH THAT THE FIRST IS X0 AND THE LAST IS ! X1. THE ORDER N MUST BE AT LEAST 3 AND THE NUMBER OF POINTS ! MUST BE AT LEAST 2. NO CHECK IS MADE TO SEE IF THESE CRITERIA ARE ! MET. THEREFORE FAILURE TO SATISFY THEM MAY RESULT IN ERRORS. ! REAL P(M,N) ! ! COMPUTE SPACING ! DX=(X0-X1)/FLOAT(M-1) ! ! INITIALIZE POSITION ! X=X0 ! ! BEGIN LOOP OVER POINTS ! DO 100 I=1,M ! ! COMPUTE P1 AND P2 ! P(I,1)=X P(I,2)=1.5*X*X-0.5 AJ=2. ! ! BEGIN LOOP OVER ORDERS ! DO J=3,N AJ=AJ+1. ! ! USE RECURSION RELATIONSHIP TO GENERATE HIGHER ORDER TERMS ! P(I,J)=((2.*AJ-1.)*X*P(I,J-1)-(AJ-1.)*P(I,J-2))/AJ END DO ! ! INCREMENT POSITION ! X=X-DX 100 CONTINUE ! RETURN END ! !*********************************************************************** ! SUBROUTINE ANGLAR(DSDO,FL,P,NL,N,M) ! ! RECONSTRUCT ANGULAR DISTRIBUTION FROM LEGENDRE COEFFICIENTS ! REAL DSDO(M),FL(NL),P(M,N) ! ! INITIALIZE DISTRIBUTION TO P0 CONTRIBUTION AND (2*J+1)/2 TO 0.5 ! DO J=1,M DSDO(J)=0.5 END DO IF(NL.LT.1) RETURN AJ=0.5 DO K=1,NL AJ=AJ+1. AJFLK=AJ*FL(K) DO J=1,M DSDO(J)=DSDO(J)+AJFLK*P(J,K) END DO END DO ! RETURN END !======================================================================= ! ! DEVICE INDEPENDENT USER-CALLABLE GRAPHICS ROUTINES ! WRITTEN BY C.L. DUNFORD ! !======================================================================= ! !*********************************************************************** ! SUBROUTINE PLTTR(IDUM,I) ! ! ROUTINE TO INITIALIZE GRAPHICS DEVICE ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! IUMES = 6 IHWROT = 1 IHWSCL = 1 PSCALE = 1. NPLOTS = 0 NVECTS = 0 ! IF(I.GE.5) CALL DEPLOT(0.,0.,-2) RETURN END ! !*********************************************************************** ! SUBROUTINE DEPLOT(X,Y,I) ! ! ROUTINE TO OUTPUT A GRAPHICS INSTRUCTION ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES COMMON/QQRPIT/PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM, & & XRASTR,YRASTR,RDUMMY(15) COMMON/NDCWHR/XC,YC REAL X,Y SAVE ! IF(I.NE.0) GO TO 100 XPAGE = X*PSCALE YPAGE = Y*PSCALE XC = 0. YC = 0. ! ! SET UP FOR POSSIBLE ROTATION ! IROTF = 1 IF(IHWROT.LT.2) GO TO 20 IF(IHWROT.EQ.2) GO TO 15 !*****ROTATE IF MAJOR AXIS NOT ALIGNED WITH DEVICE MAJOR AXIS IPL = 1 IF(XPLIM.LT.YPLIM) IPL = 0 IFL = 1 IF(XPAGE.LT.YPAGE) IFL = 0 IF(IPL.EQ.IFL) GO TO 20 !*****ROTATE 15 XT = XPAGE XPAGE = YPAGE YPAGE = XT IROTF = 2 ! ! SET UP ANY AUTOMATIC SCALING ! 20 FRAT = 1. IF(IHWSCL.EQ.3) GO TO 50 DRAT = XPAGE/XPLIM DRATP = YPAGE/YPLIM IF(DRAT.LT.DRATP) DRAT = DRATP IF(XPAGE.LT.XPLIM.AND.YPAGE.LT.YPLIM.AND.IHWSCL.EQ.1) GO TO 50 XPAGE = XPAGE/DRAT YPAGE = YPAGE/DRAT FRAT = DRAT 50 CALL DEVOUT(XPAGE,YPAGE,I) GO TO 1000 ! 100 IF(I.LT.2.OR.I.GT.3) GO TO 900 ! ! CALCULATE X AND Y POSITIONS, ROTATED IF REQUIRED ! XC = X XP = (XC+XORIG)*PSCALE/FRAT YC = Y YP = (YC+YORIG)*PSCALE/FRAT IF(IROTF.EQ.1) GO TO 105 X1 = XPAGE - YP Y1 = XP GO TO 110 105 X1 = XP Y1 = YP 110 CALL DEVOUT(X1,Y1,I) NVECTS = NVECTS + 1 GO TO 1000 ! 900 CALL DEVOUT(X,Y,I) ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE DEVOUT(X,Y,I) ! ! ROUTINE TO SELECT PROPER ROUTINE TO OUTPUT GRAPHICS INSTRUCTION ! COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE CHARACTER(LEN=4) DNAME CHARACTER(LEN=1) RESPON CHARACTER(LEN=1) PSET CHARACTER(LEN=100) PLTFLE COMMON/QQRPIT/PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM, & & XRASTR,YRASTR,RDUMMY(15) REAL X,Y,XX(2),YY(2) SAVE !*********************************************************************** ! INSTALLATION DEPENDENT CODE ! NDEVS IS THE NUMBER OF GRAPHIC DEVICES TO WHICH GRAPHIC ! OUTPUT CAN BE SENT FROM THIS GRAPHICS PACKAGE ! DNAMES IS THE ARRAY CONTAINING THE UNIQUE 4-CHARACTER NAME ! FOR EACH DEVICE AS ASSIGNED IN THE DEVICE NOMINATION ! ROUTINE IN THE DEVICE INTERFACE PACKAGE !*********************************************************************** PARAMETER (NDEVS=2) CHARACTER(LEN=4) DNAMES(NDEVS) DATA DNAMES/'PSCR','REGS'/ DATA ISETUP/0/ ! ! SET UP ASSIGNED GO TO ON DEVICE INITIALIZATION ! IF(ISETUP.EQ.1) GO TO 15 ISETUP = 1 ! ! DETERMINE THE DEVICE ! DO N=1,NDEVS IF(DNAMES(N).EQ.DNAME) GO TO 10 END DO N = 1 !*********************************************************************** ! INSTALLATION DEPENDENT CODE ! THE FOLLOWING CODE UP TO BUT NOT INCLUDING FORTRAN STATEMENT ! NUMBER 100 IS USED AT DEVICE INITIATION TIME TO INSURE THAT ! ALL FOLLOWING GRAPHICS INSTRUCTIONS ARE PROCESSED BY THE ! APPROPRIATE DEVICE OUTPUT SUBROUTINE. THERE SHOULD BE ONE ! BRANCH IN THE MULTIPLE "GO TO" FOR EACH GRAPHICS DEVICE ! DEFINED, BRANCHING TO THE REQUIRED "ASSIGN" STATEMENT. !*********************************************************************** ! ! POSTSCRIPT ! 10 IF(N.EQ.1) THEN IGO = 1 ! ! VT240 (REGIS) ! ELSE IGO = 2 END IF GO TO 20 !*********************************************************************** ! END OF INSTALLATION DEPENDENT CODING !*********************************************************************** ! ! CHECK FOR DEVICE TERMINATION ! 15 XX(1) = X YY(1) = Y IF(I.NE.5) GO TO 20 ISETUP = 0 !*********************************************************************** ! INSTALLATION DEPENDENT CODE ! THE FOLLOWING CODE UP TO BUT NOT INCLUDING FORTRAN STATEMENT ! 1000 PROVIDES THE CALLS TO THE APPROPRIATE DEVICE DEPENDENT ! GRAPHIC INSTRUCTION PROCESSING ROUTINES. THERE SHOULD BE ONE ! CALL SEQUENCE FOR EACH POSSIBLE GRAPHIC OUTPUT DEVICE, THAT IS ! ONE FOR EACH POSSIBLE VALUE OF THE "ASSIGNED GO TO" ABOVE. !*********************************************************************** ! ! POSTSCRIPT ! 20 IF (IGO.EQ.1) THEN CALL QQPOST(XX,YY,I) ! ! VT240 ! !+++MDC+++ !...VMS !/ ELSE IF(IGO.EQ.2) THEN !/ CALL QQVT(XX,YY,I) !---MDC--- ENDIF ! !*********************************************************************** ! END OF INSTALLATION DEPENDENT CODING !*********************************************************************** ! RETURN END ! !*********************************************************************** ! SUBROUTINE HWSCAL(IOPT) ! ! ROUTINE TO SET HARDWARE SCALING PARAMETER ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! CHARACTER(LEN=*) IOPT PARAMETER (NSCAO=3) CHARACTER(LEN=4) SCAOPS(NSCAO),SCAOPT DATA SCAOPS/'DOWN','SCRE','NONE'/ ! SCAOPT = IOPT ! DO 20 I=1,NSCAO IF(SCAOPT.EQ.SCAOPS(I)) GO TO 40 20 CONTINUE I = 1 40 IHWSCL = I RETURN END ! !*********************************************************************** ! SUBROUTINE HWROT(IOPT) ! ! ROUTINE TO SET HARDWARE ROTATION OPTION ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! CHARACTER(LEN=*) IOPT PARAMETER (NROTO=3) CHARACTER(LEN=4) ROTOPS(NROTO),ROTOP DATA ROTOPS/'COMI','MOVI','AUTO'/ ! ROTOP = IOPT ! DO 50 I=1,NROTO IF(ROTOP.EQ.ROTOPS(I)) GO TO 70 50 CONTINUE I = 1 70 IHWROT = I RETURN END ! !*********************************************************************** ! SUBROUTINE BGNPLT(X,Y) ! ! ROUTINE TO INITIALIZE A PLOT ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES COMMON/NDCCHR/HIGH,THETA COMMON/NDCWHR/XC,YC COMMON/NDCTKS/ITXOPT,ITYOPT ! ! INITIALIZE PARAMETERS ! HIGH = .14 THETA = 0. XORIG = 0. YORIG = 0. XC = 0. YC = 0. ITXOPT = 0 ITYOPT = 0 NPLOTS = NPLOTS + 1 ! ! START THE PLOT ! CALL DEPLOT(X,Y,0) RETURN END ! !*********************************************************************** ! SUBROUTINE ENDPLT ! ! ENTRY POINT TO TERMINATE THE PLOT ! CALL DEPLOT(0.,0.,-3) RETURN END ! !*********************************************************************** ! SUBROUTINE DONEPL ! ! TERMINATE ALL PLOTTING ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! CALL DEPLOT(0.,0.,5) IF(IUMES.GT.0) WRITE(IUMES,10) NPLOTS,NVECTS 10 FORMAT(//3X,I6,' PLOTS PRODUCED CONTAINING',I10,' VECTORS') RETURN ! END ! !*********************************************************************** ! SUBROUTINE ORIGIN(XO,YO) ! ! ROUTINE TO SET AN OFFSET ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! XORIG = XO YORIG = YO ! RETURN END ! !*********************************************************************** ! SUBROUTINE SCALE(SCAL) ! ! ROUTINE TO SET SCALE FACTOR ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES ! PSCALE = SCAL RETURN END ! !*********************************************************************** ! SUBROUTINE DECIDE(ZMIN,ZMAX,NDIV,LOGLIN,AMIN,AMAX,ASTEP,NTICK) ! ! ROUTINE TO SELECT SCALE TYPE AS WELL AS PARAMETERS ! IF(ZMAX.LE.ZMIN.OR.ZMIN.LE.0.) GO TO 50 IF((ZMAX/ZMIN).LT.15.) GO TO 50 ! ! LOG SCALING ! LOGLIN = 1 CALL AXLOG(ZMIN,ZMAX,NDIV,AMIN,AMAX,ASTEP,NTICK) IF(NTICK.GE.0) GO TO 100 NTICK = - NTICK LOGLIN = 0 GO TO 100 ! ! LINEAR SCALING ! 50 LOGLIN = 0 CALL AXLIN(ZMIN,ZMAX,NDIV,AMIN,AMAX,ASTEP,NTICK) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE STICKX(ISX) ! ! ROUTINE TO SET X TICK OPTIONS ! ! ISX = 1; TICKS ON TOP SIDE OF AXIS ! 0; TICKS ON BOTH SIDES OF AXIS ! -1; TICKS ON BOTTOM SIDE OF AXIS ! COMMON/NDCTKS/ITXOPT,ITYOPT ! ITXOPT = ISX ! RETURN END ! !*********************************************************************** ! SUBROUTINE STICKY(ISY) ! ! ROUTINE TO SET Y TICK OPTIONS ! ! ISY = 1; TICKS ON RIGHT SIDE OF AXIS ! 0; TICKS ON BOTH SIDES OF AXIS ! -1; TICKS ON LEFT SIDE OF AXIS ! COMMON/NDCTKS/ITXOPT,ITYOPT ! ITYOPT = ISY ! RETURN END ! !*********************************************************************** ! SUBROUTINE AXLOG(ZMIN,ZMAX,NDIV,AMIN,AMAX,ASTEP,NTICK) ! ! ROUTINE TO SELECT AXIS PARAMETERS FOR A LOGARITHMIC AXIS ! INTEGER ITICK(4),NDEC(4) DATA EPS/.00001/,ITICK/6,3,1,0/,NDEC/9,3,2,1/ ! ! INITIALIZE PARAMETERS ! ZLOW = ZMIN ZHIGH = ZMAX ! ! DON'T LET MIN AND MAX BE THE SAME ! ADIF = ABS(ZMAX-ZMIN)/ZMAX IF(ADIF.GT.EPS) GO TO 5 ZLOW = 0.0 ZHIGH = 2.0*ZHIGH ! ! SWITCH TO LINEAR IF LIMITS REVERSED OR ONE LIMIT NEGATIVE ! 5 IF(ZHIGH.LE.ZLOW.OR.ZLOW.LE.0.) GO TO 300 ! ! SET SCALE FACTOR FOR HIGH VALUE ! IPOW = IPOWER(ZHIGH) FACTH = 10.**IPOW ! ! SET SCALE FACTOR FOR LOW VALUE ! JPOW = IPOWER(ZLOW) FACTL = 10.**JPOW ! ! SCALE DATA LIMITS ! AZMIN = ZLOW/FACTL AZMAX = ZHIGH/FACTH ! ! TAKE A GROSS CUT AT THE APPROPRIATE BREAKS ! NDECS = IPOW - JPOW DO NW=1,4 NDIVS = NDEC(NW)*NDECS IF(NDIVS.LT.NDIV) GO TO 25 END DO NW = 4 ! ! DETERMINE FINAL PARAMETERS ! 25 IMIN = AZMIN IMAX = AZMAX 30 SELECT CASE (NW) ! ! TRY NINE DIVISIONS PER DECADE ! CASE (1) AMIN = FLOAT(IMIN)*FACTL AMAX = FLOAT(IMAX)*FACTH IF(ZHIGH.GT.AMAX) AMAX = AMAX + FACTH NLOW = 10-IMIN NHIGH = IFIX((AMAX+EPS)/FACTH) - 1 ! ! TRY THREE DIVISIONS PER DECADE ! CASE (2) AMIN = FACTL IF(AZMIN.GE.2.) AMIN = 2.0*FACTL IF(AZMIN.GE.5.) AMIN = 5.0*FACTL AMAX = FACTH IF(AZMAX.GT.1.) AMAX = 2.*FACTH IF(AZMAX.GT.2.) AMAX = 5.*FACTH IF(AZMAX.GT.5.) AMAX = 10.*FACTH NLOW = 3 IF(AZMIN.GT.1.) NLOW = IFIX(8.0-(AMIN+EPS)/FACTL)/3 NHIGH = 0 IF(AZMAX.GT.1.) NHIGH = IFIX((AMAX+EPS)/(2.*FACTH)) ! ! TRY TWO DIVISIONS PER DECADE ! CASE (3) AMIN = FACTL IF(AZMIN.GE.5.) AMIN = 5.0*FACTL AMAX = FACTH IF(AZMAX.GT.1.) AMAX = 5.*FACTH IF(AZMAX.GT.5.) AMAX = 10.*FACTH NLOW = IFIX(9.0-(AMIN+EPS)/FACTL)/4 NHIGH = IFIX((AMAX+EPS)/(5.*FACTH)) ! ! TRY ONE DIVISION PER DECADE ! CASE (4) AMIN = FACTL AMAX = 10.*FACTH IF(AZMAX.EQ.1.) AMAX = FACTH NLOW = 1 NHIGH = 1 IF(AZMAX.EQ.1.) NHIGH = 0 ! CASE DEFAULT GO TO 120 ! END SELECT ! ! TEST NUMBER OF DIVISIONS ! 100 NTOT = NLOW + NDEC(NW)*(NDECS-1) + NHIGH IF(NTOT.LE.NDIV) GO TO 150 NW = NW + 1 GO TO 30 ! ! OPTION DETERMINED ! 120 NW = 4 150 ASTEP = NDEC(NW) NTICK = ITICK(NW) GO TO 500 ! ! SWITCH TO LINEAR ! 300 CALL AXLIN(ZMIN,ZMAX,NDIV,AMIN,AMAX,ASTEP,NTICK) NTICK = - NTICK ! 500 RETURN END ! !*********************************************************************** ! SUBROUTINE AXLIN(ZMIN,ZMAX,NDIV,AMIN,AMAX,ASTEP,NTICK) ! ! ROUTINE TO SELECT AXIS PARAMETERS FOR A LINEAR AXIS ! INTEGER ITICK(10) INTEGER ITICKB(10) REAL AFRACT(10) REAL FRACTB(10) DATA ITICK/2*4,8*5/ DATA ITICKB/8*5,2*4/ DATA AFRACT/.2,.2,.25,.5,.5,.5,1.,1.,1.,1./ DATA FRACTB/.5,.5,.5,1.,1.,1.,2.,2.,2.,2./ DATA EPS/.00001/ ! ! INITIALIZE PARAMETERS ! ZLOW = ZMIN ZHIGH = ZMAX ! ! DON'T LET MIN AND MAX BE THE SAME ! ADIF = ABS(ZMAX-ZMIN) IF(ADIF.GT.EPS) GO TO 5 ZLOW = 0.0 ZHIGH = 2.0*ZHIGH ! 5 ZHIGHP = ZHIGH - ZLOW IPOW = IPOWER(ZHIGHP) ZFACT = 10.**IPOW AZMAX = ZHIGHP/ZFACT ! ISEL = IFIX(AZMAX+EPS) ASTEP = ZFACT*AFRACT(ISEL) NTICK = ITICK(ISEL) IDONE = 0 ! 80 MFACT = IFIX(ZLOW/ASTEP) AMIN = ASTEP*FLOAT(MFACT) IF(AMIN.GT.ZLOW) AMIN = AMIN - ASTEP ! AMAX = AMIN DO 85 N=1,200 AMAX = AMAX + ASTEP IF(AMAX.GE.ZHIGH) GO TO 90 85 CONTINUE 90 NDIVS = N + 1 IF(NDIVS.GT.NDIV.AND.IDONE.EQ.0) THEN ASTEP = ZFACT*FRACTB(ISEL) NTICK = ITICKB(ISEL) IDONE = 1 GO TO 80 ENDIF ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE XRULER(XOR,YOR,AXLEN,LOGLIN,AMIN,AMAX,ASTEP,NTICK, & & LTICK,LABEL,NC) ! ! ROUTINE TO SET UP AN X-DIRECTION AXIS ! COMMON/NDCCHR/HIGH,THETA COMMON/NDCSCL/IXYSC(2),ASCLE(2),BSCLE(2) COMMON/NDCMSH/AXTIC(130),ITLEN(130),ITLAB(130),NMARK COMMON/NDCTKS/ITXOPT,ITYOPT ! CHARACTER(LEN=*) LABEL ! ! SET SCALE TYPE ! ILOG = LOGLIN IF(ILOG.NE.1) ILOG = 0 IF(AMAX.LE.AMIN.OR.AMIN.LE.0.) ILOG = 0 IXYSC(1) = ILOG ! ! SET LINEAR SCALING PARAMETERS ! IF(ILOG.EQ.1) GO TO 25 ADIF = AMAX - AMIN ASCLE(1) = AXLEN/ADIF BSCLE(1) = XOR - AMIN*ASCLE(1) GO TO 50 ! ! SET LOG SCALING PARAMETERS ! 25 ADIF = ALOG10(AMAX) - ALOG10(AMIN) ASCLE(1) = AXLEN/ADIF BSCLE(1) = XOR - ALOG10(AMIN)*ASCLE(1) ! ! DETERMINE AXIS TICK MARK AND LABELING ARRAYS ! 50 CALL MESH(ILOG,AMIN,AMAX,ASTEP,NTICK,NDIG,ISPOW) ! ! PLOT BASE LINE ! CALL DEPLOT(XOR+AXLEN,YOR,3) CALL DEPLOT(XOR,YOR,2) ! ! PLOT TICK MARKS AND TICK MARK LABELS ! HIGH0 = HIGH HIGH = .75*HIGH0 IF(LTICK.GE.0) THEN YLOC = YOR - 2.5*HIGH0 ELSE YLOC = YOR + 1.5*HIGH0 ENDIF DO 100 N=1,NMARK ! ! PLOT TICK MARK ! XLOC = SCALEX(AXTIC(N)) DY = FLOAT(ITLEN(N))*HIGH0/4. DY1 = FLOAT(1+ITXOPT)*DY DY2 = FLOAT(1-ITXOPT)*DY CALL DEPLOT(XLOC,YOR+DY1,3) CALL DEPLOT(XLOC,YOR-DY2,2) ! ! PLOT TICK LABEL IF REQUIRED ! IF(ITLAB(N).EQ.0.OR.LTICK.EQ.0) GO TO 100 CALL ANTICK(AXTIC(N),NDIG,ISPOW,XLOC,YLOC,0) 100 CONTINUE ! ! PLOT AXIS LABEL ! HIGH = HIGH0 IF(NC.EQ.0) GO TO 150 NCC = IABS(NC) YLOC = YOR - 5.*HIGH0 IF(NC.LT.0) YLOC = YOR + 4.*HIGH0 CALL EXTENT(LABEL,NCC,TLEN) XLOC = XOR + (AXLEN-TLEN)/2. CALL LETTER(LABEL,NCC,XLOC,YLOC) ! 150 RETURN END ! !*********************************************************************** ! SUBROUTINE YRULER(XOR,YOR,AXLEN,LOGLIN,AMIN,AMAX,ASTEP,NTICK, & & LTICK,LABEL,NC) ! ! ROUTINE TO SET UP AN Y-DIRECTION AXIS ! COMMON/NDCCHR/HIGH,THETA COMMON/NDCSCL/IXYSC(2),ASCLE(2),BSCLE(2) COMMON/NDCMSH/AXTIC(130),ITLEN(130),ITLAB(130),NMARK COMMON/NDCTKS/ITXOPT,ITYOPT ! CHARACTER(LEN=*) LABEL ! ! SET SCALE TYPE ! ILOG = LOGLIN IF(ILOG.NE.1) ILOG = 0 IF(AMAX.LE.AMIN.OR.AMIN.LE.0.) ILOG = 0 IXYSC(2) = ILOG ! ! SET LINEAR SCALING PARAMETERS ! IF(ILOG.EQ.1) GO TO 25 ADIF = AMAX - AMIN ASCLE(2) = AXLEN/ADIF BSCLE(2) = YOR - AMIN*ASCLE(2) GO TO 50 ! ! SET LOG SCALING PARAMETERS ! 25 ADIF = ALOG10(AMAX) - ALOG10(AMIN) ASCLE(2) = AXLEN/ADIF BSCLE(2) = YOR - ALOG10(AMIN)*ASCLE(2) ! ! DETERMINE AXIS TICK MARK AND LABELING ARRAYS ! 50 CALL MESH(ILOG,AMIN,AMAX,ASTEP,NTICK,NDIG,ISPOW) ! ! PLOT BASE LINE ! CALL DEPLOT(XOR,YOR+AXLEN,3) CALL DEPLOT(XOR,YOR,2) ! ! PLOT TICK MARKS AND TICK MARK LABELS ! HIGH0 = HIGH HIGH = .75*HIGH0 IF(LTICK.GE.0) THEN XLOC = XOR - 1.25*HIGH0 ELSE XLOC = XOR + 1.25*HIGH0 ENDIF TOFF = HIGH0/3. DO 100 N=1,NMARK ! ! PLOT TICK MARK ! YLOC = SCALEY(AXTIC(N)) DX = FLOAT(ITLEN(N))*HIGH0/4. DX1 = FLOAT(1+ITYOPT)*DX DX2 = FLOAT(1-ITYOPT)*DX CALL DEPLOT(XOR+DX1,YLOC,3) CALL DEPLOT(XOR-DX2,YLOC,2) ! ! PLOT TICK LABEL IF REQUIRED ! IF(ITLAB(N).EQ.0.OR.LTICK.EQ.0) GO TO 100 IJUST = -1 IF(LTICK.LT.0) IJUST = 1 CALL ANTICK(AXTIC(N),NDIG,ISPOW,XLOC,YLOC-TOFF,IJUST) 100 CONTINUE ! ! PLOT AXIS LABEL ! HIGH = HIGH0 IF(NC.EQ.0) GO TO 150 NCC = IABS(NC) XLOC = XOR - 8.*HIGH0 IF(NC.LT.0) XLOC = XOR + 9.*HIGH0 THETA0 = THETA THETA = 90. CALL EXTENT(LABEL,NCC,TLEN) YLOC = YOR + (AXLEN-TLEN)/2. CALL LETTER(LABEL,NCC,XLOC,YLOC) THETA = THETA0 ! 150 RETURN END ! !*********************************************************************** ! SUBROUTINE MESH(LOGLIN,AMIN,AMAX,ASTEP,NTICK,NDIG,ISPOW) ! ! ROUTINE TO GENERATE AXIS TICK MARK CONTROL ARRAYS ! COMMON/NDCMSH/AXTIC(130),ITLEN(130),ITLAB(130),NMARK ! INTEGER ITLABS(9,9) DATA EPS/.00001/ !*****ARRAY MAPPING NUMBER OF ANNOTATED TICKS PER DECADE TO WHETHER !*****TO DISPLAY AN ANNOTATION FOR A GIVEN TENTH OF A DECADE DATA ITLABS/2*0,7*1,3*0,6*1,5*0,4*1,0,8*1,6*0,3*1,4*0,5*1, & & 7*0,2*1,8*0,1,9*1/ ! ! SET UP INITIAL TICK MARK ! NMARK = 1 AXTIC(1) = AMIN ITLEN(1) = 2 ITLAB(1) = 1 ! ! LINEAR AXIS ! IF(LOGLIN.EQ.1) GO TO 50 ASTEP2 = ASTEP/FLOAT(NTICK) JTICK = MAX0(1,NTICK) JTICK = MIN0(15,JTICK) ! ! DETERMINE NUMBER OF DIGITS IN ASTEP ! ISPOW = IPOWER(ASTEP) ISNUM = EPS + ASTEP/10.**(ISPOW-3) 5 DO I=1,3 IF(MOD(ISNUM,10).NE.0) GO TO 15 ISNUM = ISNUM/10 END DO I = 4 15 NDIG = 5 - I IF(NDIG.NE.4) GO TO 20 LDIG = MOD(ISNUM,100) IF(LDIG.NE.99) GO TO 20 ISNUM = ISNUM + 1 GO TO 5 ! ! PROCESS MINOR TICK MARKS ! 20 IF(JTICK.EQ.1) GO TO 35 DO N=2,JTICK NMARK = NMARK + 1 IF(NMARK.EQ.130) GO TO 100 AXTIC(NMARK) = AXTIC(NMARK-1) + ASTEP2 ITLEN(NMARK) = 1 ITLAB(NMARK) = 0 END DO ! ! NEXT MAJOR TICK MARK ! 35 NMARK = NMARK + 1 IF(NMARK.EQ.130) GO TO 100 AXTIC(NMARK) = AXTIC(NMARK-JTICK) + ASTEP TTEST = ABS(AXTIC(NMARK)/ASTEP) IF(TTEST.LT.1.0E-06) AXTIC(NMARK) = 0.0 ITLEN(NMARK) = 2 ITLAB(NMARK) = 1 ! ! SEE IF MORE TO GO ! AXTEST = ABS((AXTIC(NMARK)-AMAX)/AMAX) IF(AXTEST.LE.EPS) GO TO 100 GO TO 20 ! ! LOG AXIS ! 50 ILABL = ASTEP + EPS + .5 ILABL = MAX0(ILABL,1) ILABL = MIN0(ILABL,9) JTICK = MAX0(0,NTICK) JTICK = MIN0(9,JTICK) NDIG = -2 ISPOW = 0 ! ! GET DECADE FACTOR FOR AMIN ! IPOW = IPOWER(AMIN) FACT = 10.**IPOW !*****WHICH TENTH DECADE DO WE START ON NLOW = IFIX((AMIN/FACT)+EPS) ! ! PROCESS EACH DECADE ! 60 NHALF = 2 !*****DO WE MARK AT TWENTIETHS OF A DECADE IF(NLOW.GT.JTICK) NHALF = 1 DFACT = FACT/FLOAT(NHALF) ! ! PROCESS EACH DECADE ! DO 80 N=NLOW,9 DO J=1,NHALF NMARK = NMARK + 1 IF(NMARK.EQ.130) GO TO 100 AXTIC(NMARK) = AXTIC(NMARK-1) + DFACT ITLEN(NMARK) = 1 IF(J.EQ.1.AND.NHALF.EQ.2) ITLEN(NMARK) = 0 ITLAB(NMARK) = 0 END DO !*****SEE IF WE ARE ALL DONE AXTEST = ABS(AXTIC(NMARK)-AMAX)/AMAX IF(AXTEST.LE.EPS) GO TO 100 !*****SEE IF WE CONTINUE TO MARK 1/2 OF TENTH DECADES IF(JTICK.NE.N) GO TO 70 DFACT = FACT NHALF = 1 ! ! SET LABEL MARKER ARRAY ! 70 ITLAB(NMARK) = ITLABS(ILABL,N) IF(ITLAB(NMARK).GT.0) ITLEN(NMARK) = 2 80 CONTINUE ! ! INITIALIZE FOR NEXT DECADE ! NLOW = 1 FACT = 10.*FACT GO TO 60 ! ! LAST TICK MARK ! 100 AXTIC(NMARK) = AMAX ITLEN(NMARK) = 2 ITLAB(NMARK) = 1 ! RETURN END ! !*********************************************************************** ! SUBROUTINE ANTICK(VALUE,NDIG,ISPOW,X,Y,JUSTFY) ! ! OUTPUT GRID TICK ANNOTATIONS ! COMMON/NDCCHR/HIGH,THETA DATA ABUT/999./ ! ! INITIALIZE ! SVALUE = VALUE VALU = ABS(VALUE) IPOW = 0 NCHARA = 0 NC = IABS(NDIG) - (1+ISPOW) IF(SVALUE.EQ.0.) GO TO 100 ! ! DETERMINE POWER OF TEN ! IPOW = IPOWER(VALUE) ! ! DECIDE IF POWER NOTATION SHOULD BE USED ! IF(VALU.GE.1000..OR.VALU.LT..001) GO TO 50 IF(NDIG.LT.0) NC = NC - IPOW IPOW = 0 GO TO 100 ! ! USE POWER NOTATION ! 50 SVALUE = SVALUE/10.**IPOW IF(NDIG.GE.0) NC = NC + IPOW NCHARA = 4 IF(IPOW.LT.0) NCHARA = 5 ! ! CALCULATE STARTING LOCATION ! 100 NC = MAX0(NC,0) TLEN = 0. IJUST = JUSTFY IF(JUSTFY.LT.-1.OR.JUSTFY.GT.1) IJUST = 1 IF(IJUST.EQ.1) GO TO 120 CALL NUMLEN(SVALUE,NC,TLEN) TLEN = TLEN + 6.*HIGH*NCHARA/7. TLEN = 0.5*FLOAT((IJUST-1))*TLEN 120 XSTART = X + TLEN YSTART = Y ! ! OUTPUT FLOATING PART ! CALL DIGITS(SVALUE,NC,XSTART,YSTART) ! ! OUTPUT EXPONENT IF REQUIRED ! IF(IPOW.EQ.0) GO TO 1000 CALL LETTER('$*10<',5,ABUT,ABUT) CALL DIGITS(FLOAT(IPOW),-1,ABUT,ABUT) CALL LETTER('>',1,ABUT,ABUT) ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE CIPHER(VALUE,DELTA,X,Y) ! ! ROUTINE OUTPUTS A FLOATING POINT NUMBER WITH THE NUMBER OF ! SIGNIFICANT FIGURES INDICATED BY DELTA ! COMMON/NDCCHR/HIGH,THETA DATA EPS/.00001/,ABUT/999./ ! ! CONSIDER ONLY ABSOLUTE VALUES ! ABVALU = ABS(VALUE) ABDELT = ABS(DELTA) NDELTA = 0 NPOWER = 0 VALU = VALUE ! ! DETERMINE SIGNIFICANT FIGURES TO BE CARRIED ! IF(ABDELT.EQ.0.0.OR.ABVALU.EQ.0.) GO TO 50 NDELTA = INT(ALOG10(ABDELT) + EPS) ! ! USE POWER OF TEN NOTATION IF REQUIRED BY NUMBER SIZE ! IF(ABVALU.LT.1000..AND.ABVALU.GT.0.001) GO TO 50 NPOWER = NDELTA NDELTA = 0 30 VALU = VALUE/(10.**NPOWER) ABVALU = ABS(VALU) IF(ABVALU.LT.10.) GO TO 50 NPOWER = NPOWER + 1 NDELTA = NDELTA - 1 GO TO 30 ! ! OUTPUT FLOATING PART ! 50 NDECPT = MAX0(1-NDELTA,-1) CALL DIGITS(VALU,NDECPT,X,Y) ! ! OUTPUT EXPONENT IF REQUIRED ! IF(NPOWER.EQ.0) GO TO 1000 CALL LETTER('$*10<',5,ABUT,ABUT) CALL DIGITS(FLOAT(NPOWER),-1,ABUT,ABUT) CALL LETTER('>',1,ABUT,ABUT) ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE PLOTSY(X,Y,NS,SIZE) ! ! ROUTINE TO PLOT A POINT WITH A SYMBOL ON A GRAPH ! ! NS = 1 --- AN X ! NS = 2 --- A BOX ! NS = 3 --- A DIAMOND ! ! SET SYMBOL LOCATION ! XLOC = SCALEX(X) YLOC = SCALEY(Y) ! SELECT CASE (NS) ! ! AN X ! CASE (1) DX = SIZE/3. DY = SIZE/2. CALL DEPLOT(XLOC-DX,YLOC-DY,3) CALL DEPLOT(XLOC+DX,YLOC+DY,2) CALL DEPLOT(XLOC+DX,YLOC-DY,3) CALL DEPLOT(XLOC-DX,YLOC+DY,2) ! ! A BOX ! CASE (2) DX = SIZE/2. DY = DX CALL DEPLOT(XLOC-DX,YLOC-DY,3) CALL DEPLOT(XLOC-DX,YLOC+DY,2) CALL DEPLOT(XLOC+DX,YLOC+DY,2) CALL DEPLOT(XLOC+DX,YLOC-DY,2) CALL DEPLOT(XLOC-DX,YLOC-DY,2) ! ! A DIAMOND ! CASE (3) DX = SIZE/3. DY = SIZE/2. CALL DEPLOT(XLOC-DX,YLOC,3) CALL DEPLOT(XLOC,YLOC+DY,2) CALL DEPLOT(XLOC+DX,YLOC,2) CALL DEPLOT(XLOC,YLOC-DY,2) CALL DEPLOT(XLOC-DX,YLOC,2) END SELECT ! RETURN END ! !*********************************************************************** ! SUBROUTINE DCURVE(X,Y,NP) ! ! ROUTINE TO DRAW A CURVE ON A GRAPH ! REAL X(NP),Y(NP) ! ! MUST HAVE AT LEAST 2 POINTS TO PLOT A CURVE ! IF(NP.LT.2) GO TO 100 ! ! DRAW EACH SEGMENT AFTER SCALING THE END POINT ! IPEN = 3 DO N=1,NP XLOC = SCALEX(X(N)) YLOC = SCALEY(Y(N)) CALL DEPLOT(XLOC,YLOC,IPEN) IPEN = 2 END DO ! 100 RETURN END ! !*********************************************************************** ! FUNCTION SCALEX(XVALUE) ! ! CONVERT AN X COORDINATE TO ABSOLUTE LOCATION ! COMMON/NDCSCL/IXYSC(2),ASCLE(2),BSCLE(2) ! XVAL = XVALUE IF(IXYSC(1).EQ.1) XVAL = ALOG10(XVAL) SCALEX = ASCLE(1)*XVAL + BSCLE(1) ! RETURN END ! !*********************************************************************** ! FUNCTION SCALEY(YVALUE) ! ! CONVERT AN Y COORDINATE TO ABSOLUTE LOCATION ! COMMON/NDCSCL/IXYSC(2),ASCLE(2),BSCLE(2) ! YVAL = YVALUE IF(IXYSC(2).EQ.1) YVAL = ALOG10(YVAL) SCALEY = ASCLE(2)*YVAL + BSCLE(2) ! RETURN END ! !*********************************************************************** ! SUBROUTINE DIGITS(FPN,N1,XT,YT) ! ! SPECIAL VERSION OF THE STANDARD "NUMBER" SUBROUTINE ! COMMON/NDCCHR/HIGH,THETA CHARACTER(LEN=1) INUM(10) DATA INUM/'0','1','2','3','4','5','6','7','8','9'/,ABUT/999./ ! ! STORE PASSED VARIABLES ! X=XT Y=YT N=N1 FLNUM=FPN ! ! SET NUMBER OF DIGITS LEFT OR RIGHT TO LESS THAN 10 ! IF(N.GT.9) N=9 IF(N.LT.-9)N=-9 ! ! BRANCH ON NUMBER TO BE PLOTTED ! IF(FLNUM.EQ.0) GO TO 90 ! ! NEGATIVE NUMBER SO PLOT LEADING MINUS ! IF(FLNUM.LT.0) THEN CALL LETTER('-',1,X,Y) FLNUM=-FLNUM X=ABUT Y=ABUT END IF ! ! ROUND NUMBER TO PROPER SIGNIFICANT FIGURES ! 20 MN=-N IF(N.LT.0)MN=MN-1 TFPN=(FLNUM+0.5*10.0**MN) ! ! FIND NUMBER OF DIGITS TO LEFT OF DECIMAL POINT TO BE PLOTTED ! I=ALOG10(TFPN)+1.0 I1=I IF(N.LT.-1)I1=I+N+1 IF(I1.GT.0)GO TO 55 CALL LETTER(INUM(1),1,X,Y) X = ABUT Y = ABUT GO TO 65 ! ! PLOT THOSE DIGITS ! 55 DO J=1,I1 FACT = 10.0**(J-I) K= TFPN*FACT CALL LETTER(INUM(K+1),1,X,Y) TFPN=(TFPN*FACT-FLOAT(K))/FACT X=ABUT Y=ABUT END DO !*****DONE IF ONLY INTEGER TO BE PLOTTED IF(N.LT.0) GO TO 100 GO TO 70 ! ! NO DIGITS TO THE LEFT OF THE DECIMAL ! 65 IF(N.GT.0)GO TO 70 IF(N.LT.0) N = -1 GO TO 90 ! ! PLOT DECIMAL POINT ! 70 CALL LETTER('.',1,X,Y) X=ABUT Y=ABUT !*****DONE IF NO DIGITS TO RIGHT OF DECIMAL ARE TO BE PLOTTED IF(N.EQ.0) GO TO 100 ! ! PLOT DIGITS TO RIGHT OF DECIMAL ! DO I = 1,N K= TFPN *10.0 CALL LETTER(INUM(K+1),1,X,Y) TFPN= TFPN*10.0-FLOAT(K) END DO GO TO 100 ! ! PLOT A ZERO VALUE ! 90 I=N+2 CALL LETTER('0.000000000',I,X,Y) ! 100 RETURN END ! !*********************************************************************** ! SUBROUTINE NUMLEN(FPN,N1,TLEN) ! ! SUBROUTINE TO CALCULATE LENGTH OF TEXT STRING WHICH WOULD BE ! GENERATED BY DIGITS ! COMMON/NDCCHR/HIGH,THETA ! ! STORE PASSED VARIABLES AND INITIALIZE CHARACTER COUNT ! N=N1 FLNUM=FPN NCHARS = 0 ! ! SET NUMBER OF DIGITS LEFT OR RIGHT TO LESS THAN 10 ! IF(N.GT.9) N=9 IF(N.LT.-9)N=-9 ! ! BRANCH ON NUMBER TO BE PLOTTED ! IF(FLNUM.EQ.0.) GO TO 90 ! ! NEGATIVE NUMBER SO PLOT LEADING MINUS ! IF(FLNUM.LT.0.) THEN NCHARS = NCHARS + 1 FLNUM=-FLNUM END IF ! ! ROUND NUMBER TO PROPER SIGNIFICANT FIGURES ! MN=-N IF(N.LT.0)MN=MN-1 TFPN=(FLNUM+0.5*10.0**MN) ! ! FIND NUMBER OF DIGITS TO LEFT OF DECIMAL POINT TO BE PLOTTED ! I=ALOG10(TFPN)+1.0 I1=I IF(N.LT.-1)I1=I+N+1 IF(I1.GT.0)GO TO 55 NCHARS = NCHARS + 1 GO TO 65 55 NCHARS = NCHARS + I1 !*****DONE IF ONLY INTEGER TO BE PLOTTED IF(N.LT.0) GO TO 100 GO TO 70 ! ! NO DIGITS TO THE LEFT OF THE DECIMAL ! 65 IF(N.GT.0)GO TO 70 IF(N.LT.0) N = -1 GO TO 90 ! ! PLOT DECIMAL POINT ! 70 NCHARS = NCHARS + 1 !*****DONE IF NO DIGITS TO RIGHT OF DECIMAL ARE TO BE PLOTTED IF(N.EQ.0) GO TO 100 NCHARS = NCHARS + N GO TO 100 ! ! PLOT A ZERO VALUE ! 90 NCHARS = N + 2 ! 100 TLEN = 6.*HIGH*NCHARS/7. RETURN END ! !*********************************************************************** ! SUBROUTINE LETTER(BCD,NBCD,X1,Y1) ! ! SPECIAL VERSION OF THE STANDARD "SYMBOL" SUBROUTINE ! COMMON/NDCCHR/HIGH,THETA COMMON/NDCWHR/XC,YC CHARACTER(LEN=*) BCD CHARACTER(LEN=1) BCDI INTEGER IX(16),IY(16),IPEN(16) ! ! TRANSFER CHARACTER LOCATION UNLESS TO BE ABUTTED ! IF(X1.LT.998.) XA = X1 IF(Y1.LT.998.) YA = Y1 ! ! INITIALIZE CHARACTER PARAMETERS UNLESS TO BE ABUTTED ! IF(X1.GE.998.0.OR.Y1.GE.998.0) GO TO 10 ANGR = THETA *3.14159/180. CA = COS(ANGR) SA = SIN(ANGR) SIZE = HIGH/7. WD = 6.*SIZE ISCRIP = 0 SOFF = 0. ! ! SET UP BOX LOWER LEFT CORNER FOR CHARACTER ! 10 X0 = 0. Y0 = SOFF ! ! PROCESS EACH CHARACTER IN THE INPUT STRING ! NC = NBCD DO 100 I=1,NC BCDI = BCD(I:I) ! ! TRANSLATE EACH CHARACTER TO INTERNAL NUMERICAL EQUIVALENT ! NSYM = ILCOD(BCDI) IF(NSYM.LT.1) GO TO 100 IF(NSYM.EQ.1) GO TO 50 IF(NSYM.GE.200) GO TO 60 ! ! GET STROKES FOR THE CHARACTER AND PLOT IT ! CALL PENMOV(NSYM,IX,IY,IPEN,MVS) DO 40 K=1,MVS X = X0 + SIZE *IX(K) Y = Y0 + SIZE*IY(K) XP = XA + X*CA - Y*SA YP = YA + X*SA + Y*CA IPV = 3 - IPEN(K) CALL DEPLOT(XP,YP,IPV) 40 CONTINUE ! ! SET UP CORNER OF NEXT CHARACTER ! 50 X0 = X0 + WD GO TO 100 ! ! BACKSPACE ! 60 IF(NSYM.NE.200) GO TO 70 X0 = X0 - WD GO TO 100 ! ! END OF SUBSCRIPT OR BEGINNING OF SUPERSCRIPT ! 70 IF(NSYM.EQ.201) THEN IF(ISCRIP.EQ.1) GO TO 100 IF(ISCRIP.GT.1) GO TO 95 ISCRIP = 1 SOFF = 4.*SIZE SIZE = .75*SIZE Y0 = SOFF ! ! END OF SUPERSCRIPT OR BEGINNING OF SUBSCRIPT ! ELSE IF(ISCRIP.GT.1) GO TO 100 IF(ISCRIP.EQ.1) GO TO 95 ISCRIP = 2 SOFF = -3.*SIZE SIZE = .75*SIZE Y0 = SOFF END IF GO TO 100 ! ! RESTORE NO SUPER OR SUBSCRIPTING ! 95 ISCRIP = 0 SOFF = 0. SIZE = HIGH/7. Y0 = SOFF 100 CONTINUE ! ! SET COORDINATES FOR NEXT CHARACTER IN CASE NEXT CALL IS IN ! ABUT MODE ! XA = X0*CA + XA YA = X0*SA + YA XC = XA YC = YA ! RETURN END ! !*********************************************************************** ! SUBROUTINE EXTENT(BCD,NBCD,TLEN) ! ! ROUTINE TO DETERMINE THE PLOTTING LENGTH OF A STRING ! COMMON/NDCCHR/HIGH,THETA CHARACTER(LEN=*) BCD CHARACTER(LEN=1) BCDI ! ! INITIALIZE PARAMETERS ! X0 = 0. WD = 6.*HIGH/7. ! ! PROCESS EACH CHARACTER IN THE INPUT STRING ! NC = NBCD DO I=1,NC BCDI = BCD(I:I) ! ! TRANSLATE EACH CHARACTER TO INTERNAL NUMERICAL EQUIVALENT ! NSYM = ILCOD(BCDI) IF(NSYM.LE.0) GO TO 100 IF(NSYM.GE.200) GO TO 60 ! ! A PLOTABLE CHARACTER SO ADD ONE WIDTH ! X0 = X0 + WD GO TO 100 ! ! BACKSPACE, SO SUBTRACT ONE WIDTH ! 60 IF(NSYM.NE.200) GO TO 100 X0 = X0 - WD ! ! SET STRING PLOTTING LENGTH ! 100 TLEN = X0 END DO ! RETURN END ! !*********************************************************************** ! FUNCTION ILCOD(BCDI) ! ! FUNCTION TO TRANSLATE ASCII CHARACTER REPRESENTATION INTO ! THE UNIQUE CODE FOR A CHARACTER REQUIRED IN PENMOV ! CHARACTER(LEN=1) BCDI INTEGER ISPC(33) ! ! SPECIAL CHARACTER CODES (ISHIFT=1) ! ! ! - UP ARROW " - BACK ARROW ( - RIGHT BRACKET ! ) - LEFT BRACKET * - TIMES SIGN + - PLUS-MINUS ! , - SINGLE QUOTE - - EPSILON (LC) . - DEGREE ! / - PERCENT 0 - ALPHA (LC) 1 - BETA (LC) ! 2 - GAMMA (LC) 3 - ETA (LC) 4 - NU BAR (LC) ! 5 - MU (LC) 6 - PI (LC) 7 - SIGMA (LC) ! 8 - GAMMA (UC) 9 - THETA (UC) : - COLON ! ; - SEMI COLON < - < = - APPROXIMATE ! > - > ? - DELTA (UC) @ - SIGMA (UC) ! ALL OTHERS BLANK DATA ISPC/1,63,64,5*0,60,62,94,61,8,99,65,6,95,96,100,97,108, & & 101,102,103,105,107,27,28,29,92,31,104,106/,ISHIFT/0/ ! ILCOD = -1 IDC = ICHAR(BCDI) - 31 ! ! $ - SPECIAL CHARACTER TO FOLLOW ! SET FLAG, IF NEXT CHARACTER IS A SPECIAL CHARACTER ! IF(IDC.NE.5) GO TO 10 ISHIFT = MOD(ISHIFT+1,2) ILCOD = 0 GO TO 50 ! ! STANDARD CHARACTER SET INTERPRETATION ! 10 IF(ISHIFT.EQ.1) GO TO 20 ! ! ; - BACKSPACE < - SUPERSCRIPT > - SUBSCRIPT ! ILCOD = IDC IF(IDC.EQ.28) ILCOD = 200 IF(IDC.EQ.29) ILCOD = 201 IF(IDC.EQ.31) ILCOD = 202 GO TO 50 ! ! FIRST ALTERNATE CHARACTER SET ! 20 ISHIFT = 0 IF(ILCOD.GT.33) GO TO 50 !***** SPECIAL CHARACTERS ILCOD = ISPC(IDC) GO TO 50 ! 50 RETURN END ! !*********************************************************************** ! SUBROUTINE PENMOV(INDX,IX,IY,IPEN,N) ! ! ROUTINE TO RETURN VECTOR DEFINITION FOR CHARACTER SELECTED BY ! INDX ! INTEGER IX(16),IY(16),IPEN(16) ! ! ARRAY NBGN CONTAINS THE WORD IN WHICH THE INDX-TH CHARACTER ! DEFINITION STARTS ! ARRAY NXYP CONTAINS THE STROKE DEFINITIONS PACKED THREE TO A ! WORD, EACH STROKE USING 10 BITS. THESE ARE ! 1-4 DELTA X FROM ORIGIN ! 5-8 DELTA Y FROM ORIGIN PLUS 3 ! 9 0 FOR DARK VECTOR, 1 FOR LIGHT VECTOR ! 10 ON IF LAST VECTOR OF DEFINITION ! INTEGER NBGN(109),NXYP(284) ! DATA NBGN/1, 2, 6, 8, 11, 12, 16, 19, 20, 22, 24, 27, 29, 31, & & 32, 34, 35, 38, 40, 43, 48, 50, 53, 57, 58, 64, 68, 72, 76, 77, & & 79, 80, 84, 85, 88, 92, 95, 98,100,102,106,108,110,113,115,116, & &118,120,123,126,130,133,137,139,142,143,145,147,149,151,153,155, & &157,159,161,163,167,171,174,178,181,184,189,192,193,195,197,198, & &202,205,208,212,216,218,221,224,227,228,230,232,234,236,238,239, & &241,245,250,253,254,257,260,263,265,268,270,272,275,279,285/ DATA (NXYP(L),L= 1, 32)/ & & 282, 147015830, 86128744, 107112678, & & 245476352, 243435880, 305135616, 239163748, & & 224493986, 25521152, 349175808, 109090914, & & 174172456, 14897298, 216287447, 281118890, & & 237000846, 295922688, 243436544, 243370070, & & 217055232, 109283542, 82837504, 17074336, & & 153370658, 25455616, 25454752, 154140672, & & 75712662, 86129664, 25455616, 147015830/ DATA (NXYP(L),L= 33, 64)/ & & 86129664, 12889088, 79902998, 304326762, & & 35674191, 105031822, 79903744, 37857514, & & 308578322, 14957568, 37857514, 308578526, & & 98791706, 287520846, 19922944, 109078810, & & 239287296, 16857294, 287598814, 31500587, & & 29587738, 287520846, 18913386, 245668864, & & 12888107, 96495634, 82000146, 295925854, & & 35690602, 245668130, 233832448, 16857294/ DATA (NXYP(L),L= 65, 96)/ & & 287611114, 111187998, 94661632, 147015830, & & 86128792, 232949854, 162529280, 75712662, & & 86128792, 232949854, 162529280, 285239587, & & 29653012, 292552704, 17066019, 147015830, & & 86128792, 170105002, 108003328, 349175808, & & 12617898, 304363548, 300941312, 12626154, & & 308578526, 31682842, 287520783, 285423694, & & 18913386, 245668864, 12626154, 308562126/ DATA (NXYP(L),L= 97,128)/ & & 15728640, 281032746, 312504543, 12626218, & & 29588480, 159672594, 216086546, 39954666, & & 309329920, 12625948, 300196111, 79902860, & & 178364651, 16857230, 220440744, 313524224, & & 12625944, 312570127, 281032747, 12626078, & & 312753152, 12626190, 313524224, 79710246, & & 111388966, 287520847, 12626154, 308578526, & & 32505856, 79710246, 111388966, 287520846/ DATA (NXYP(L),L=129,160)/ & & 222571520, 12626154, 308578526, 31682831, & & 12794130, 295925854, 35690602, 313524224, & & 146974760, 313524224, 41961550, 216287528, & & 284164096, 42088747, 41957526, 283421696, & & 12888104, 284164096, 42105130, 163724288, & & 42248206, 284164096, 243378254, 217055232, & & 12859416, 295862419, 109291726, 82837504, & & 146966618, 228756480, 25327766, 27552768/ DATA (NXYP(L),L=161,192)/ & & 168007850, 107121664, 218249294, 18962646, & & 29522138, 220478464, 12625944, 98793754, & & 287520846, 19922944, 285423694, 18901086, & & 233073664, 285423694, 18901086, 233072936, & & 284164096, 21256474, 232880154, 18954511, & & 79796394, 245668060, 32505856, 285423694, & & 18901086, 233072924, 274925634, 7340032, & & 12625944, 98793754, 284164096, 146963456/ DATA (NXYP(L),L=193,224)/ & & 4262022, 166723584, 12626204, 23224591, & & 176307200, 12613656, 98723982, 159611162, & & 284164096, 12613652, 165902618, 284164096, & & 79710234, 98793754, 287520847, 30744, & & 98793754, 287520846, 19922944, 285423694, & & 18901086, 233072924, 271581184, 12613652, & & 165902619, 12794130, 224483354, 98860032, & & 285423758, 86087708, 300941312, 285423694/ DATA (NXYP(L),L=225,256)/ & & 18905372, 284164096, 29505823, 29440150, & & 216300544, 12875804, 284164096, 29505604, & & 300941312, 29653006, 284164096, 25262294, & & 296747008, 146975744, 21268512, 292552704, & & 297941070, 18896990, 165890318, 351272960, & & 8489126, 241469726, 228681944, 291784910, & & 15728640, 25262234, 81944798, 295906304, & & 349175808, 218249294, 19028058, 165902619/ DATA (NXYP(L),L=257,284)/ & & 29460642, 224610442, 149265408, 4356176, & & 149113118, 218381312, 12679196, 300118223, & & 163797134, 81811550, 368050176, 12859550, & & 15728640, 12626218, 305135616, 306489386, & & 232798478, 288358400, 79837394, 304322726, & & 102778958, 25455616, 29456474, 14829782, & & 299929895, 0, 0, 0/ ! ! FIND EXTENT OF CHARACTER DEFINITION ! NL = NBGN(INDX) NU = NBGN(INDX+1) - 1 N = 0 IF(NU.LT.NL.OR.NL.EQ.0) GO TO 200 ! ! PROCESS EACH WORD OF THE DEFINITION ! DO I=NL,NU ! ! PROCESS EACH STROKE OF THE WORD ! DO 100 J=1,3 N = N + 1 L = 10*(3-J) IVECT = NXYP(I)/2**L ! ! EXTRACT X, Y, AND IPEN FOR THE VECTOR ! IX(N) = MOD(IVECT/64,16) IY(N) = MOD(IVECT/4,16) - 3 IPEN(N) = MOD(IVECT/2,2) IF(MOD(IVECT,2).NE.0) GO TO 200 100 CONTINUE END DO ! 200 RETURN END ! !*********************************************************************** ! SUBROUTINE THITE(HEIGHT) ! ! ROUTINE TO SET TEXT CHARACTER HEIGHT ! COMMON/NDCCHR/HIGH,THETA ! HIGH=HEIGHT RETURN END ! !*********************************************************************** ! SUBROUTINE TANGLE(ANGLE) ! ! ROUTINE TO SET TEXT ANGLE ! COMMON/NDCCHR/HIGH,THETA ! THETA = ANGLE RETURN END ! !*********************************************************************** ! SUBROUTINE WHERE(X,Y) ! ! ROUTINE TO RETURN CURRENT PEN POSITION ! COMMON/NDCWHR/XC,YC ! X = XC Y = YC RETURN END ! !*********************************************************************** ! SUBROUTINE THLINE(ITHICK) ! ! ROUTINE TO SET THICKNESS OF A LINE ! COMMON/NDCGRC/ITPEN,CYTYPD INTEGER CYTYPD ! ITPEN = ITHICK ! RETURN END ! !*********************************************************************** ! SUBROUTINE DRLINE(X1,Y1,X2,Y2) ! ! ROUTINE TO DRAW A LINE ! CALL DEPLOT(X1,Y1,3) CALL DEPLOT(X2,Y2,2) ! RETURN END ! !********************************************************************** ! SUBROUTINE DRAWTO(X2,Y2) ! ! ROUTINE TO DRAW A LINE FROM THE CURRENT POSITION ! CALL DEPLOT(X2,Y2,2) ! RETURN END ! !*********************************************************************** ! SUBROUTINE MOVETO(X2,Y2) ! ! ROUTINE POINT TO MOVE TO A NEW POSITION ! CALL DEPLOT(X2,Y2,3) ! RETURN END ! !*********************************************************************** ! FUNCTION IPOWER(VALUE) ! ! ROUTINE TO RETURN THE EXPONENT OF A NUMBER ! POWER = ALOG10(ABS(VALUE)) + .00001 IPOWER = POWER IF(POWER.LT.0.) IPOWER = IPOWER - 1 RETURN END ! !======================================================================= ! ! DEVICE DRIVER FOR POSTSCRIPT ! WRITTEN BY C.L. DUNFORD ! VERSION 2 DECEMBER 17, 1990 ! !======================================================================= ! !*********************************************************************** ! SUBROUTINE NNDCPS(IMODEL,IOPTN) ! ! SUBROUTINE TO INITIALIZE FOR POSTSCRIPT OUTPUT ! COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE CHARACTER(LEN=4) DNAME CHARACTER(LEN=1) RESPON,PSET CHARACTER(LEN=100) PLTFLE COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE INTEGER OPTION,VERSON ! EXTERNAL QQPOST ! ! SET DEVICE SELECTION PARAMETERS ! DNAME = 'PSCR' MODEL = IMODEL OPTION = IOPTN VERSON = 2 IF(MODEL.NE.1) THEN INMODE = 0 ELSE INMODE = 1 + OPTION ENDIF ! ! CHECK ARGUMENTS ! IF(MODEL.NE.0.OR.OPTION.NE.0) THEN IF(MODEL.EQ.1.AND.(OPTION.EQ.0.OR.OPTION.EQ.1)) GO TO 20 WRITE(6,10) 10 FORMAT(/' UNKNOWN MODEL AND OPTION SELECTED FOR THE ', & & 'POSTSCRIPT INTERFACE') WRITE(6,'(/A)') ' ' STOP ' JOB NOT SUCCESSFULLY COMPLETED' ENDIF ! ! TELL DISPLA NAME OF X,Y,IPEN ROUTINE AND DO DEVICE INITIALIZATION ! 20 CALL PLTTR(QQPOST,5) ! RETURN END ! !*********************************************************************** ! SUBROUTINE QQPOST(X,Y,IPEN) ! ! SUBROUTINE TO PROCESS TYPE OF COMMANDS OF THE SORT USUALLY ! SENT TO PLOT(X,Y,IPEN) ! ! IPEN=+5 TO TERMINATE PLOTTING. ! IPEN=+3 TO MOVE PEN UP TO (X,Y). ! IPEN=+2 TO MOVE PEN DOWN TO (X,Y). ! IPEN=0 TO BEGIN A PLOT ! IPEN=-2 TO INITIATE PLOTTING ! IPEN=-3 TO TERMINATE THE CURRENT PLOT, ADVANCE THE FRAME, AND RESE ! COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE INTEGER OPTION,VERSON COMMON/NDCGRC/ITPEN,CYTYPD INTEGER CYTYPD COMMON/NDCPSC/IFRAME,XBOX,YBOX,THICK,AMITER COMMON/QQRPIT/PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM, & & XRASTR,YRASTR,RDUMMY(15) ! REAL X(2),Y(2) ! ! BRANCH ON OPTION ! SELECT CASE (IPEN) ! ! INITIATE PLOTTING ! CASE (-2) ITPEN = 1 CYTYPD = 0 IFRAME = 0 CALL QQPSIN ! ! OPEN OUTPUT FILE AND INITIALIZE FOR POSTSCRIPT ! IF(INMODE.EQ.0) CALL QQPSCO(' ',0,-1) ! ! START NEW FRAME ! CASE (0) IF(INMODE.GT.0) CALL QQPSCO(' ',0,-1) RASTER = 72. XPRRAS = 0. YPRRAS = 0. THICK = PENTHK*RASTER AMITER = 10. XBOX = X(1)*RASTER YBOX = Y(1)*RASTER IFRAME = IFRAME + 1 CALL QQPSCO(' ',0,3) ! ! DRAW A LINE ! CASE (2,3) XPORAS = X(1)*RASTER YPORAS = Y(1)*RASTER ! ! PEN UP ! IF(IPEN.EQ.3) THEN CALL POSTVC(XPORAS,YPORAS,1) ! ! PEN DOWN ! ELSE IF(IPEN.EQ.2) THEN ! ! SINGLE LINE ! IF(ITPEN.EQ.1) THEN CALL POSTVC(XPORAS,YPORAS,0) ! ! DRAW THICKENED LINE ! ELSE DX = XPORAS - XPRRAS DY = YPORAS - YPRRAS RAD = ATAN2(DY,DX) + 1.570798 COSOFF = THICK*COS(RAD) SINOFF = THICK*SIN(RAD) DTC = FLOAT(ITPEN-1)/2. DTX = DTC*COSOFF DTY = DTC*SINOFF DO NL=1,ITPEN CALL POSTVC(XPRRAS+DTX,YPRRAS+DTY,1) CALL POSTVC(XPORAS+DTX,YPORAS+DTY,0) DTX = DTX - COSOFF DTY = DTY - SINOFF END DO CALL POSTVC(XPORAS,YPORAS,1) END IF END IF ! ! SAVE LAST PEN LOCATION ! XPRRAS = XPORAS YPRRAS = YPORAS ! ! TERMINATE PLOT ! CASE (-3) IF(INMODE.GT.0) CALL POSTVC(0.0,0.0,1) CALL QQPSCO(' ',0,2) ! ! JOB TERMINATION ! CASE (5) CALL QQPSCO(' ',0,1) ! END SELECT ! RETURN END ! !*********************************************************************** ! SUBROUTINE QQPSIN ! ! SUBROUTINE TO LOAD DEVICE INITIALIZATION PARAMETERS ! COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE INTEGER OPTION,VERSON COMMON/QQRPIT/PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM, & & XRASTR,YRASTR,RDUMMY(15) ! ! LINE THICKNESS ON DEVICE ! PENTHK = .008 ! ! DOT DIAMETER ON DEVICE ! VISDOT = .004 ! ! X RESOLUTION ON DEVICE ! XRASTR = .004 ! ! Y RESOLUTION ON DEVICE ! YRASTR = .004 ! ! MAXIMUM X SIZE OF A PAGE ! IF(MODEL.EQ.0) THEN XPLIM = 7.68 ELSE XPLIM = 7.99 ENDIF ! ! MAXIMUM Y SIZE OF A PAGE ! IF(MODEL.EQ.0) THEN YPLIM = 10.24 ELSE YPLIM = 4.8 ENDIF ! ! SET SCALE OPTION ! CALL HWSCAL('DOWN') ! ! SET AXIS ALIGNMENT OPTION ! IF(MODEL.EQ.0) THEN CALL HWROT('AUTO') ELSE CALL HWROT('COMI') ENDIF ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE POSTVC(X,Y,IUP) ! ! ROUTINE TO TRANSLATE AN A SET OF RASTER COORDINATES TO AN ACSII ! CHARACTER STRING FOR POSTSCRIPT AND THEN OUTPUT ! CHARACTER(LEN=10) XNUM,YNUM CHARACTER(LEN=30) CXY CHARACTER(LEN=4) CMOVE(2) DATA CMOVE/'draw','move'/ ! ! GET X STRING ! CALL NCONV(X,XNUM,NX) ! ! GET Y STRING ! CALL NCONV(Y,YNUM,NY) ! ! BUILD STRING ! CXY = XNUM(1:NX)//' '//YNUM(1:NY)//' '//CMOVE(IUP+1) LCXY = NX + NY + 6 ! ! OUTPUT TO DEVICE ! CALL QQPSCO(CXY,LCXY,0) ! RETURN END ! !*********************************************************************** ! SUBROUTINE QQPSCO(IWORD,NC,IOPT) ! ! SUBROUTINE TO OPEN, WRITE TO, END FRAME OR CLOSE POSTSCRIPT FILE ! COMMON/NDCGRP/IHWROT,IHWSCL,XORIG,YORIG,PSCALE,NPLOTS,NVECTS,IUMES COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE CHARACTER(LEN=4) DNAME CHARACTER(LEN=1) RESPON,PSET CHARACTER(LEN=100) PLTFLE COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE INTEGER OPTION,VERSON COMMON/NDCGRC/ITPEN,CYTYPD INTEGER CYTYPD COMMON/NDCPSC/IFRAME,XBOX,YBOX,THICK,AMITER ! CHARACTER(LEN=*) IWORD ! CHARACTER(LEN=100) PSCFLE CHARACTER(LEN=80) LINE CHARACTER(LEN=10) XNUM,YNUM,TNUM,ANUM INTEGER PSCU ! !+++MDC+++ !...VMS !/ EXTERNAL LIB$M_CLI_CTRLY !...ANS, WIN, UNX SAVE PSCU,IC,LINSZ,LINTST !---MDC--- ! ! INITIALIZE PLOTTING OPEN PLOT FILE ! IF(IOPT.LT.0) THEN IF(INMODE.EQ.0) THEN PSCU = 49 LINSIZ = 80 IF(PSET.EQ.'S') THEN PSCFLE = PLTFLE ELSE PSCFLE = ' ' ENDIF !+++MDC+++ !...VMS !/ OPEN(UNIT=PSCU,ACCESS='SEQUENTIAL',STATUS='NEW', & !/ & DEFAULTFILE='GRDATA.PS',CARRIAGECONTROL='LIST', & !/ & FILE=PSCFLE,ERR=900) !...ANS, WIN, UNX OPEN(UNIT=PSCU,ACCESS='SEQUENTIAL',STATUS='UNKNOWN', & & FILE=PSCFLE,ERR=900) !---MDC--- INQUIRE(UNIT=PSCU,NAME=PSCFLE) LOP = INDEX(PSCFLE,' ') - 1 IF(IUMES.NE.0) THEN WRITE(IUMES,*) '[Plot output to '//PSCFLE(:LOP)//']' ENDIF ELSE LINSIZ = 80 !+++MDC+++ !...VMS !/ PSCU = 49 !/ OPEN(UNIT=PSCU,ACCESS='SEQUENTIAL',STATUS='UNKNOWN', & !/ & FILE='TT:',CARRIAGECONTROL='LIST',ERR=900) !/ IF(INMODE.EQ.1) CALL LIB$DISABLE_CTRL(%LOC(LIB$M_CLI_CTRLY !/ CALL CYTRAP(1) !...WIN, UNX PSCU = 49 OPEN(UNIT=PSCU,ACCESS='SEQUENTIAL',STATUS='UNKNOWN', & & FILE='TT:',CARRIAGECONTROL='LIST',ERR=900) !...ANS !/ PSCU = 6 !---MDC--- ENDIF CYTYPD = 0 LINTST = LINSIZ - 1 ! ! INITIALIZE VARIABLES ! 40 WRITE(PSCU,45) 45 FORMAT('%!PS-ADOBE-'/ & & '%%Pages: (atend)'/ & & '%%DocumentFonts:'/ & & '%%EndComments') !*****FOR USE WITH LATEX WRITE(PSCU,50) 50 FORMAT('%When using this file in LATEX, be sure to reformat ', & & 'it with the STREAMLF command.'/ & & '%%BoundingBox: 0 0 0 0'/ & & '%begin(plot)'/ & & '/inch {72 mul} def'/ & & '%modify the next three variables for scaling ', & & 'and positioning when using '/ & & '% with LATEX.'/ & & '/myred 0 def'/ & & '/myxtra 0 inch def'/ & & '/myytra 0 inch def'/ & & '/myrot 0 def'/ & & '1.0 myred sub 1.0 myred sub scale'/ & & 'myxtra 1.0 myred add mul myytra 1.0 myred add ', & & 'mul translate '/ & & 'myrot rotate') WRITE(PSCU,55) 55 FORMAT('/draw {lineto currentpoint stroke newpath moveto} def') WRITE(PSCU,60) 60 FORMAT('/move {newpath moveto} def') WRITE(PSCU,65) 65 FORMAT('/defaults {0 0 0 setrgbcolor setlinewidth setlinecap ',& & 'setlinejoin setmiterlimit'/ & & ' 0 array 0 setdash newpath 0 0 moveto} def') WRITE(PSCU,70) 70 FORMAT('%Delete from here to the EndDelete comment for LATEX.'/& & '/center {/yarea exch def /xarea exch def newpath ', & & 'clippath pathbbox'/ & & ' /ury exch def /urx exch def /lly exch def' & & ' /llx exch def'/ & & ' /xoff urx llx sub xarea sub 2 div llx add def'/ & & ' /yoff ury lly sub yarea sub 2 div lly add def'/ & & ' xoff yoff translate} def') WRITE(PSCU,75) 75 FORMAT('/saveobj save def'/ & & '%EndDelete'/ & & '%%EndProlog') GO TO 1000 ! ! BRANCH ON POSITIVE VALUES OF IOPT ! ELSE IF(IOPT.GT.0) THEN SELECT CASE (IOPT) ! ! BEGINNING OF PAGE ! CASE (3) IF(CYTYPD.NE.0) GO TO 1000 WRITE(PSCU,115) IFRAME,IFRAME 115 FORMAT('%%Page:',2I4/ & & '%Delete from here to the EndDelete comment for LATEX.'/ & & 'saveobj restore'/'/saveobj save def') CALL NCONV(XBOX,XNUM,NX) CALL NCONV(YBOX,YNUM,NY) WRITE(PSCU,120) XNUM(1:NX),YNUM(1:NY) 120 FORMAT(A,' ',A,' center'/ & & '%EndDelete') CALL NCONV(AMITER,ANUM,NA) CALL NCONV(THICK,TNUM,NT) LINE = ANUM(1:NA)//' 0 0 '//TNUM(1:NT)//' defaults ' IC = NA + NT + 15 WRITE(PSCU,125) LINE(1:IC) 125 FORMAT(A) IC = 0 LINE = ' ' ! ! END OF PAGE ! CASE (2) IF(INMODE.EQ.0) THEN IF(IC.NE.1) WRITE(PSCU,125) LINE(1:IC) WRITE(PSCU,160) 160 FORMAT('%end(plot)'/'showpage') ELSE IF(CYTYPD.EQ.0) THEN IF(IC.NE.1) WRITE(PSCU,125) LINE(1:IC) WRITE(PSCU,160) READ(5,165) RESPON 165 FORMAT(A1) ENDIF WRITE(PSCU,190) IFRAME !+++MDC+++ !...VMS !/ CLOSE(UNIT=PSCU) !/ IF(INMODE.EQ.1) THEN !/ CALL LIB$ENABLE_CTRL(%LOC(LIB$M_CLI_CTRLY)) !/ IF(CYTYPD.LT.0) THEN !/ WRITE(6,230) !/ CALL EXIT !/ ENDIF !/ CALL CYTRAP(0) !/ ENDIF !---MDC--- ENDIF CYTYPD = 0 ! ! END OF JOB ! CASE (1) IF(INMODE.EQ.0) THEN WRITE(PSCU,190) IFRAME 190 FORMAT('%%TRAILER'/'%%Pages:',I4) CLOSE(UNIT=PSCU) ENDIF ! END SELECT GO TO 1000 ! ! MOVE EACH CHARACTER INTO THE BUFFER ! ELSE IF(IOPT.EQ.0) THEN !+++MDC+++ !...VMS !/ IF(CYTYPD.EQ.0) THEN !---MDC--- 205 JC = IC + 1 IC = IC + NC IF(IC.GT.LINSIZ) GO TO 220 LINE(JC:IC) = IWORD(1:NC) IF(IC.GE.LINTST) GO TO 220 IC = IC + 1 GO TO 1000 220 WRITE(PSCU,125) LINE(1:JC-1) IC = 0 LINE = ' ' GO TO 205 !+++MDC+++ !...VMS !/ ELSE !/ IF(INMODE.EQ.1.AND.CYTYPD.LT.0) THEN !/ WRITE(PSCU,190) IFRAME !/ CLOSE(UNIT=PSCU) !/ WRITE(6,230) !/ 230 FORMAT(' Program terminated by user.') !/ CALL LIB$ENABLE_CTRL(%LOC(LIB$M_CLI_CTRLY)) !/ CALL EXIT !/ ENDIF !/ IF(INMODE.EQ.2.AND.CYTYPD.GT.0) THEN !/ CYTYPD = 0 !/ ENDIF !/ ENDIF !/ GO TO 1000 !---MDC--- ! END IF 900 WRITE(6,910) 910 FORMAT(5X,'ABORT - UNABLE TO OPEN OUTPUT FILE') WRITE(6,'(/A)') ' ' STOP ' JOB NOT SUCCESSFULLY COMPLETED' ! 1000 RETURN END ! !*********************************************************************** ! SUBROUTINE NCONV(NUM,CNUM,NC) ! ! ROUTINE TO CONVERT A NUMBER TO POSTSCRIPT EQUIVALENT CHARACTER ! STRING ! CHARACTER(LEN=10) CNUM,BUFFER CHARACTER(LEN=1) SCHAR REAL NUM ! CNUM = ' ' NC = 0 WRITE(BUFFER,10,ERR=100) NUM 10 FORMAT(F10.3) ! ! REMOVE ALL BLANKS ! DO 20 I=1,10 SCHAR = BUFFER(I:I) IF(SCHAR.EQ.' ') GO TO 20 NC = NC + 1 CNUM(NC:NC) = SCHAR 20 CONTINUE ! ! REMOVE TRAILING ZEROS ! IF(NC.EQ.0) GO TO 100 NB = NC DO 30 N=NB,1,-1 IF(CNUM(N:N).NE.'0') GO TO 50 NC = NC - 1 30 CONTINUE ! ! REMOVE TRAILING PERIOD ! 50 IF(CNUM(NC:NC).EQ.'.') NC = NC - 1 ! 100 CONTINUE END !======================================================================= ! ! DEVICE DRIVER FOR REGIS MODE GRAPHICS ! ! WRITTEN BY C.L. DUNFORD ! VERSION 1 DECEMBER 17, 1990 ! ! NOTE:: THE ANSI F77 VERSION DOES NOT HANDLE ASYNCHRONOUS INTERRUPTS ! !======================================================================= ! !+++MDC+++ !...VMS !/! !/ SUBROUTINE NNDCRG(IMODEL,IOPTN) !/! !/! SUBROUTINE TO INITIALIZE FOR OUTPUT IN REGIS MODE !/! !/ COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE !/ CHARACTER(LEN=4) DNAME !/ CHARACTER(LEN=1) RESPON,PSET !/ CHARACTER(LEN=100) PLTFLE !/ COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE !/ INTEGER OPTION,VERSON !/! !/ EXTERNAL QQVT !/! !/! OLD ENTRY POINT !/! !/ ENTRY VT240(IMODEL,IOPTN) !/! !/! SET DEVICE SELECTION PARAMETERS !/! !/ DNAME = 'REGS' !/ MODEL = IMODEL !/ OPTION = IOPTN !/ VERSON = 1 !/ INMODE = 1 + OPTION !/! !/! CHECK ARGUMENTS !/! !/ IF(MODEL.NE.0.OR.(OPTION.NE.0.AND.OPTION.NE.1)) THEN !/ WRITE(6,10) !/ 10 FORMAT(/' UNKNOWN MODEL AND OPTION SELECTED FOR THE ', & !/ & 'REGIS INTERFACE') !/ WRITE(6,'(/A)') ' ' !/ STOP ' JOB NOT SUCCESSFULLY COMPLETED' !/ ENDIF !/! !/! TELL DISSPLA NAME OF X,Y,IPEN ROUTINE AND DO DEVICE !/! INITIALIZATION !/! !/ CALL PLTTR(QQVT, 5) !/! !/ RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE QQVT(XX,YY,IPEN) !/! !/! SUBROUTINE TO PROCESS X,Y,IPEN CALLS. !/! !/! IPEN = -2 TO BEGIN ALL PLOTTING. !/! IPEN = 0 TO BEGIN CURRENT FRAME (XPAGE = X, YPAGE = Y). !/! IPEN = 2 TO DRAW TO X, Y. !/! IPEN = 3 TO MOVE TO X, Y. !/! IPEN = -3 TO END CURRENT PLOT AND ADVANCE FRAME. !/! IPEN = 5 TO END ALL PLOTTING. !/! !/ COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE !/ INTEGER OPTION,VERSON !/ COMMON/NDCGRC/ITPEN,CYTYPD !/ INTEGER CYTYPD !/ COMMON/QQRPIT/PLNAME,PLSPRT,PENTHK,VISDOT,XPLIM,YPLIM,XRASTR, & !/ & YRASTR,RDUMMY !/ REAL PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM,XRASTR, & !/ & YRASTR,RDUMMY(15) !/! !/ REAL XX(2),YY(2) !/! !/! COPY THE FORMALS TO LOCALS. !/! !/ X = XX(1) !/ Y = YY(1) !/! !/! BRANCH ON IPEN. !/! !/ SELECT CASE (IPEN) !/! !/! BEGIN ALL PLOTTING. !/! !/ CASE (-2) !/ ITPEN = 1 !/ CYTYPD = 0 !/ CALL QQVTIN !/! !/! BEGIN CURRENT PLOT. !/! !/ CASE (0) !/ CALL QQVT2O(' ',-1) !/ XOLD = 0.0 !/ YOLD = 0.0 !/ XOFF = (XPLIM - X) / 2.0 !/ YOFF = (YPLIM - Y) / 2.0 !/! !/! MOVE OR DRAW TO X, Y. !/! !/ CASE (2,3) !/ X = X + XOFF !/ Y = Y + YOFF !/ IF(IPEN.EQ.3.OR.ITPEN.EQ.1) THEN !/ CALL QQVTPL(X, Y, IPEN) !/ ELSE !/ DX = X - XOLD !/ DY = Y - YOLD !/ RAD = ATAN2(DY, DX) + 1.570798 !/ COSOFF = PENTHK * COS(RAD) !/ SINOFF = PENTHK * SIN(RAD) !/ DTC = FLOAT(ITPEN - 1) / 2.0 !/ DTX = DTC * COSOFF !/ DTY = DTC * SINOFF !/ DO NL = 1, ITPEN !/ CALL QQVTPL(XOLD + DTX, YOLD + DTY, 3) !/ CALL QQVTPL(X + DTX, Y + DTY, 2) !/ DTX = DTX - COSOFF !/ DTY = DTY - SINOFF !/ END DO !/ CALL QQVTPL(X, Y, 3) !/ ENDIF !/ XOLD = X !/ YOLD = Y !/! !/! END CURRENT PLOT. !/! !/ CASE (-3) !/ 50 CALL QQVTPL(0.,0.,3) !/ CALL QQVT2O(' ',1) !/! !/ END SELECT !/! !/ 100 RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE QQVTIN !/! !/! ROUTINE TO SET DEVICE DEPENDENT PARAMETERS FOR REGIS !/! !/ COMMON/QQRPIT/PLNAME(2),PLSPRT(2),PENTHK,VISDOT,XPLIM,YPLIM, & !/ & XRASTR,YRASTR,RDUMMY(15) !/! !/! LINE THICKNESS ON DEVICE !/! !/ PENTHK = .01 !/! !/! DOT DIAMETER ON DEVICE !/! !/ VISDOT = .01 !/! !/! X RESOLUTION ON DEVICE !/! !/ XRASTR = .01 !/! !/! Y RESOLUTION ON DEVICE !/! !/ YRASTR = .01 !/! !/! MAXIMUM X SIZE OF A PAGE !/! !/ XPLIM = 7.99 !/! !/! MAXIMUM Y SIZE OF A PAGE !/! !/ YPLIM = 4.79 !/! !/! SET SCALE OPTION !/! !/ CALL HWSCAL('DOWN') !/! !/! SET AXIS ALIGNMENT OPTION !/! !/ CALL HWROT('COMI') !/! !/ RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE QQVTPL(X,Y,IPEN) !/! !/! SUBROUTINE TO EITHER MOVE TO (X, Y) IF IPEN = 3 !/! OR DRAW TO (X, Y) IF IPEN = 2. !/! !/ CHARACTER(LEN=1) FUNCT !/ CHARACTER(LEN=10) IWORD !/! !/ IF(IPEN.EQ.2) THEN !/ FUNCT = 'V' !/ ELSE !/ FUNCT = 'P' !/ ENDIF !/! !/! INTEGERIZE X AND Y. !/! !/ JX = X * 100 + 0.5 !/ JY = 479 - INT(Y * 100 + 0.5) !/! !/! LOAD COMMAND SEQUENCE FOR MOVE OR DRAW. !/! !/ WRITE(IWORD,10) FUNCT,'[',JX,',',JY,']' !/ 10 FORMAT(2A1,I3,A1,I3,A1) !/ CALL QQVT2O(IWORD,0) !/! !/ RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE QQVT2O(IWORD,IOPT) !/! !/! SUBROUTINE TO OPEN, WRITE TO OR END FRAME OR CLOSE LN03 OUTPUT !/! FILE !/! !/ COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE !/ CHARACTER(LEN=4) DNAME !/ CHARACTER(LEN=1) RESPON,PSET !/ CHARACTER(LEN=100) PLTFLE !/ COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE !/ INTEGER OPTION,VERSON !/ COMMON/NDCGRC/ITPEN,CYTYPD !/ INTEGER CYTYPD !/! !/ CHARACTER(LEN=*) IWORD !/! !/ CHARACTER(LEN=132) LINE !/ CHARACTER(LEN=1) ESC !/ EXTERNAL LIB$M_CLI_CTRLY !/! !/ IF(IOPT) 10,100,150 !/! !/! OPEN PLOT FILE !/! !/ 10 IVTU = 47 !/ OPEN(UNIT=IVTU,FILE='TT:',STATUS='UNKNOWN',ERR=900) !/! !/! INITIALIZE CONTROL Y AND C HANDLING !/ IF(INMODE.EQ.1) CALL LIB$DISABLE_CTRL(%LOC(LIB$M_CLI_CTRLY)) !/ CALL CYTRAP(1) !/ CYTYPD = 0 !/! !/! OUTPUT DEVICE INITIALIZATION STRING !/! !/ ESC = CHAR(27) !/ WRITE(IVTU,*) ESC,'[!p',ESC,'P1pS(I0,E)W(I2)' !/! !/! INITIALIZE CONTROL VARIABLES !/! !/ IC = 0 !/ LINTST = 130 !/ GO TO 1000 !/! !/! OUTPUT PEN MOVE INSTRUCTION !/! !/ 100 CONTINUE !/ IF(CYTYPD.EQ.0) THEN !/ JC = IC + 1 !/ IC = IC + LEN(IWORD) !/ IF(IC.LE.LINTST) THEN !/ LINE(JC:IC) = IWORD !/ ELSE !/ WRITE(IVTU,*) LINE(1:JC-1) !/ IC = IC - JC + 1 !/ LINE(1:IC) = IWORD !/ ENDIF !/ ELSE !/ IF(INMODE.EQ.1.AND.CYTYPD.LT.0) THEN !/ WRITE(IVTU,*) ESC,'P1p',ESC,'\',ESC,'[H',ESC,'[J' !/ CLOSE(UNIT=IVTU) !/ WRITE(6,110) !/ 110 FORMAT(' Program terminated by user.') !/ CALL LIB$ENABLE_CTRL(%LOC(LIB$M_CLI_CTRLY)) !/ CALL EXIT !/ ENDIF !/ IF(INMODE.EQ.2.AND.CYTYPD.GT.0) THEN !/ CYTYPD = 0 !/ WRITE(IVTU,*) ESC,'P1p' !/ ENDIF !/ ENDIF !/ GO TO 1000 !/! !/! END OF FRAME !/! !/ 150 IF(CYTYPD.EQ.0) THEN !/ IF(IC.GT.0) WRITE(IVTU,*) LINE(1:IC) !/ READ(5,165) RESPON !/ 165 FORMAT(1A) !/ ENDIF !/ IF(CYTYPD.NE.0) THEN !/ WRITE(IVTU,*) ESC,'P1p' !/ ENDIF !/ WRITE(IVTU,*) ESC,'\',ESC,'[H',ESC,'[J' !/ WRITE(IVTU,*) !/ CLOSE (UNIT=IVTU) !/ IF(INMODE.EQ.1) THEN !/ CALL LIB$ENABLE_CTRL(%LOC(LIB$M_CLI_CTRLY)) !/ IF(CYTYPD.LT.0) THEN !/ WRITE(6,110) !/ CALL EXIT !/ ENDIF !/ CALL CYTRAP(0) !/ ENDIF !/ CYTYPD = 0 !/ GO TO 1000 !/! !/ 900 WRITE(6,910) !/ 910 FORMAT(5X,'ABORT - UNABLE TO OPEN OUTPUT FILE') !/ WRITE(6,'(/A)') ' ' !/ STOP ' JOB NOT SUCCESSFULLY COMPLETED' !/! !/ 1000 RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE CYTRAP(IPATH) !/! !/! CONTROLS AST TRAPPING !/! !/! IPATH = 0, NO TRAPPING !/! IPATH = 1, CALL CY_TROL !/! !/ COMMON/TRAPIN/LARGY,LARGC,IAST,EMODE,TTCHAN,TCDUM,CTRP,CON !/ LOGICAL CTRP,CON !/ INTEGER*2 TTCHAN,TCDUM !/ INTEGER EMODE !/! !/ PARAMETER (JPI$_MODE=802) !/ INTEGER SYS$ASSIGN,STATUS,SYS$QIOW !/ EXTERNAL IO$_SETMODE,IO$M_CTRLYAST,IO$M_CTRLCAST !/ EXTERNAL CY_TROL !/! !/ DATA TTCHAN/0/ !/! !/! ASSIGN THE TERMINAL AND OBTAIN THE CHANNEL NUMBER, IF UNASSIGNED !/! !/ IF(TTCHAN.EQ.0) THEN !/ CALL LIB$GETJPI(JPI$_MODE,,,EMODE) !/ IF(EMODE.EQ.2) GO TO 100 !/ STATUS = SYS$ASSIGN('SYS$INPUT',TTCHAN,,) !/ LARGC = %LOC(IO$_SETMODE) .OR. %LOC(IO$M_CTRLCAST) !/ LARGY = %LOC(IO$_SETMODE) .OR. %LOC(IO$M_CTRLYAST) !/ ENDIF !/ IF(EMODE.EQ.2) GO TO 100 !/! !/! CANCEL ALL PREVIOUS SETTINGS !/! !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGC),,,,%VAL(0),,,,,) !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGY),,,,%VAL(0),,,,,) !/! !/! SET THE NEW AST'S !/! !/ IF(IPATH.EQ.1) THEN !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGC),,,,CY_TROL,1,,,,) !/ ICT = 2 !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGY),,,, & !/ & CY_TROL,-1,,,,) !/ IYT = 2 !/ ELSE !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGC),,,,%VAL(-1),,,,,) !/ ICT = 0 !/ STATUS = SYS$QIOW(,%VAL(TTCHAN),%VAL(LARGY),,,,%VAL(-1),,,,,) !/ IYT = 0 !/ ENDIF !/! !/ 100 RETURN !/ END !---MDC--- ! !*********************************************************************** ! !+++MDC+++ !...VMS !/ SUBROUTINE CY_TROL(I) !/! !/! ROUTINE TO BE CALLED ASYNCHRONOUSLY WHEN A ^C OR ^Y IS TYPED. !/! !/ COMMON/NDCGRC/ITPEN,CYTYPD !/ INTEGER CYTYPD !/! !/! A ^Y IS FLAGGED, A ^C ONLY IF THERE HAS BEEN NO ^Y !/! !/ IF(I.EQ.-1) THEN !/ CYTYPD = -1 !/ ELSE !/ IF(CYTYPD.EQ.0) CYTYPD = 1 !/ ENDIF !/! !/! RESET THE TRAPS !/! !/ CALL CYTRAP(1) !/! !/ RETURN !/ END !---MDC--- !======================================================================= ! ! AUXILIARY ROUTINES COMMON TO ALL GRAPHICS DEVICE DRIVERS ! WRITTEN BY C.L. DUNFORD ! VERSION 1 AUGUST 20, 1987 ! MODIFIED FOR 11.0 OCTOBER 20, 1988 ! REVISED JANUARY 18, 1989 ! REVISED JUNE 13, 1989 ! REVISED DECEMBER 7, 1990 ! !======================================================================= ! !*********************************************************************** ! SUBROUTINE SETNAM(FNAME) ! ! ROUTINE TO PASS PLOT FILE NAME TO NNDC INTERFACE PACKAGE ! COMMON/NDCGRA/DNAME,RESPON,PSET,NAME CHARACTER(LEN=4) DNAME CHARACTER(LEN=1) RESPON,PSET CHARACTER(LEN=100) NAME ! CHARACTER(LEN=*) FNAME ! NAME = FNAME PSET = 'S' ! RETURN END ! !*********************************************************************** ! SUBROUTINE GETRSP(RCHAR) ! ! ROUTINE TO PASS THE CHARACTER ENTERED WHEN MOVING TO THE NEXT ! FRAME IN INTERACTIVE MODE TO A USER PROGRAM ! COMMON/NDCGRA/DNAME,RESPON,PSET,PLTFLE CHARACTER(LEN=4) DNAME CHARACTER(LEN=1) RESPON,PSET CHARACTER(LEN=100) PLTFLE COMMON/NDCGRB/MODEL,OPTION,VERSON,INMODE INTEGER OPTION,VERSON ! CHARACTER(LEN=*) RCHAR ! IF(INMODE.EQ.1) THEN RCHAR = RESPON ELSE RCHAR = ' ' ENDIF ! RETURN END ! !*********************************************************************** ! SUBROUTINE THPEN(ITHICK) ! ! ROUTINE TO SET THICKNESS OF A LINE ! COMMON/NDCGRC/ITPEN,CYTYPD INTEGER CYTYPD ! ITPEN = MAX0(ITHICK,1) ! RETURN END