Program Comtrans C C Code to convert comment fields in ENSDF to a form which allows C superscripts, subscripts, Greek, bold, and italic characters. C Version 1.0 Written by R. Kinsey Feb. 8, 1995. Uses the Edit routine C written by C. Dunford and maintained by R. Kinsey. C Version 2.0 Sep. 19, 1995. C Version 3.0 June 17, 1998. Column footnotes were not capitailized. The C comments data set did not terminate properly if the last section was C a funding acknowledgement. The comments dataset had extra blanks in C the comments section if the continuation cards began with them. C Contact: C Robert R. Kinsey C Bldg 197D C NNDC, Brookhaven Natl Lab C P.O. Box 5000 C Upton, NY 11973-5000 C email: kinsey1@bnl.gov C phone: (516) 282-5096 C fax: (516) 282-2806 C Functions Integer Break, Lenstr, Fldid, Index, Indexf C Commons Integer ioin, iout Common/iounit/ioin, iout C Local Variables CHARACTER*15 VERS, VERSDATE Character*50 filin, filout Character*80 card, lstcrd Character*256 output, extra Integer olen, ibreak, ifld, itype, ibgn, ierr, ind, nobrk, + i, ibal Logical data C DATA VERSDATE/'June 17, 1998 '/ DATA VERS/'Version 3.0'/ Write(*,4) VERS,VERSDATE 4 FORMAT(//18X,'EXECUTION OF THE COMMENTS TRANSLATION PROGRAM' + /34X,A/32X,'of ',A//) Write(*,*) 'Input file:' Read(5,fmt='(A)') filin ioin=21 Open(UNIT=ioin,ACCESS='SEQUENTIAL',FILE=filin,STATUS='OLD') Write(*,*) 'Output file:' Read(5,fmt='(A)') filout iout=22 Open(UNIT=iout,ACCESS='SEQUENTIAL',FILE=filout,STATUS='NEW', + CARRIAGECONTROL='LIST') Call Opendic C extra=' ' data=.false. 10 Read(ioin,fmt='(A)',END=1000) card C Test for the beginning of the data set. If(card(6:9).eq.' ') then Write(*,*) card C data is a flag to indicate when the first data card is read. data=.false. If(card(10:16).eq.'COMMENT') then C Then COMMENT data set has its own subroutine. Call CommDS(card) Go to 10 Endif Endif If(card(7:7).eq.'C'.or.card(7:7).eq.'T'.or.card(7:7).eq.'U'.or. + card(7:7).eq.'c'.or.card(7:7).eq.'t'.or.card(7:7).eq.'u') then Call Locase(card(7:7)) C If itype is 4 then capitalize the first word (5 , do not). itype=4 If(card(6:6).ne.' '.and.card(6:6).ne.'1') itype=6 ibgn=10 If(card(8:8).ne.' '.and.itype.eq.4) then ibgn=20 If(Index(card,'$').ge.10) ibgn=Index(card,'$')+1 C If card is a table comment and not a footnote, but has a flag then C it is not capitalized. Editors choice. C Data comments aren't capitalized either if they have a flag. If(card(10:ibgn-2).ne.' ') then itype=5 C Footnotes on columns and data. Capitalized. ifld=Fldid(card(10:Break(card,10,'$ (,')-1)) If(.not.data.and.ifld.ge.1) itype=4 C The following If takes care of the format error when a data C comment begins in column 10 with no SYM or $ delimiter. If(card(ibgn-1:ibgn-1).ne.'$'.and.data.and.ifld.lt.1)then If(Indexf(card,10,' ').le.19) then C This could be the old format. If(card(Indexf(card,10,' '):19).eq.' ') then C It is. Else C It isn't. itype=4 ibgn=10 Endif Else C No $ and no blank between 10 and 19. Strange. itype=4 ibgn=10 Endif Endif Endif C Make no changes to LABEL cards or BAND cards. If(Index(card,'LABEL=').GT.0.or.card(10:13).eq.'BAND') then card(7:7)=Char(Ichar(card(7:7))-32) output=card(ibgn:80) C For a BAND card, the text on the first line may effect editing. C Do the edit but don't use it. If(Index(card,'BAND').gt.0) Call Edit(4,card(ibgn:80), + output,ierr) If(extra.ne.' ') Go to 50 Go to 100 Endif Endif C A negative itype preserves the spaces in editing. The publication C program uses fixed character spacing for 't' comments. If(card(7:7).eq.'t') itype=-itype Call Edit(itype,card(ibgn:80),output,ierr) If(ierr.ne.0) Write(*,*) 'Error translating card ',card 50 Continue If(extra.ne.' '.and.(itype.eq.4.or.itype.eq.5)) then Do While(extra.ne.' '.and.Lenstr(extra).gt.0) ind=Lenstr(extra)+1 ibreak=0 C Lines can not be broken within curly brackets. Do While(ind.gt.71.or.extra(ind:ind).ne.' '.or. + ibreak.ne.0) If(extra(ind:ind).eq.'{') ibreak=ibreak+1 If(extra(ind:ind).eq.'}') ibreak=ibreak-1 ind=ind-1 Enddo lstcrd(10:)=extra(1:ind) C If an extra continuation card is needed it will have 'x' in C column 6 just because I like it and I can't use !, @, #, C or +. lstcrd(6:6)='x' write(iout,fmt='(A)') lstcrd Call Delstr(extra,1,ind) Enddo Else If(extra.ne.' '.and.itype.eq.6) then If(Lenstr(extra).gt.100) then ind=Lenstr(extra)+1 ibreak=0 Do While(ind.gt.81-ibgn.or.extra(ind:ind).ne.' '.or. + ibreak.ne.0) If(extra(ind:ind).eq.'{') ibreak=ibreak+1 If(extra(ind:ind).eq.'}') ibreak=ibreak-1 ind=ind-1 Enddo lstcrd(10:)=extra(1:ind) lstcrd(6:6)='x' Write(iout,fmt='(A)') lstcrd Call Delstr(extra,1,ind) Endif Call Addstr(output,1,extra(1:Lenstr(extra)+1)) extra=' ' Endif olen = Lenstr(output) If(olen+ibgn-1.gt.80) then ind=olen ibreak=0 C Remove No Break constructions (i.e. { ...}). If required for the C publication then the evaluator will have to put them in but for C now they take up room and make the text harder to read. nobrk=Index(output,'{ ') Do While(nobrk.ne.0) i=nobrk+2 ibal=1 Do While(ibal.ne.0.and.i.le.ind) If(output(i:i).eq.'{') ibal=ibal+1 If(output(i:i).eq.'}') ibal=ibal-1 i=i+1 Enddo If(i-1.le.ind) then Call Delstr(output,i-1,1) Call Delstr(output,nobrk,2) nobrk=Index(output,'{ ') Else nobrk=0 Endif Enddo C Done removing nonbreak constructions from output Do While(ind.gt.81-ibgn.or.output(ind:ind).ne.' '.or. + ibreak.ne.0) If(output(ind:ind).eq.'{') ibreak=ibreak+1 If(output(ind:ind).eq.'}') ibreak=ibreak-1 ind=ind-1 Enddo If(ind.le.0) then ind=81-ibgn Endif extra=output(ind+1:) output(ind+1:)=' ' Endif card(ibgn:)=output Else C Card is not to be translated. Just write it out. If(extra.ne.' ') then lstcrd(10:)=extra lstcrd(6:6)='x' write(iout,fmt='(A)') lstcrd extra=' ' Endif C Data comments not footnotes follow the first data card. Don't capitaliz If(card(6:7).eq.' '.and.Break(card,8,'LGBEA').eq.8) data=.true. Endif 100 Continue Write(iout,fmt='(A)') card lstcrd=card Go to 10 C 1000 Close(unit=iout) Stop End Subroutine CommDS(card) Character*(*) card C Functions Integer Index, Indexf, Lenstr C Commons Integer ioin, iout Common/iounit/ioin, iout C Local Variables Integer i, iend, ierr, lng, loc, loc1, loc2, + locate, locf, nabb, itype, nspc, numsym Logical doedt, table, newln, paragf C String arrays for string manipulation Character*250 str, output, edtstr, str3 Character*10 sym, col129 Character*5 abbrev(10),abbre2(10) C C Correct translation of organizational and countries abbreviations Data abbrev/'Usa','Eg&g','Uk','Gmbh',6*' '/ Data abbre2/'USA','EG&G','UK','GmbH',6*' '/ Data nabb/4/ C C C Processing COMMENT data set locate = 0 output=' ' edtstr=' ' Go to 104 100 CONTINUE Read(ioin,fmt='(A)',END=1000) card If(card(1:10).eq.' ') go to 1000 104 str=card(1:80) C DSID CARD? If(str(6:9).eq.' ') then Write(iout,fmt='(A)') card GO TO 100 Endif doedt=.true. If(str(7:7).eq.'c'.or.str(7:7).eq.'t') doedt=.false. table = ((str(7:7).EQ.'t').or.(str(7:7).EQ.'T')) C Is this the start of a new section? If(str(6:6).ne.' '.and.str(6:6).ne.'1') then C Continuation card of some kind. If(locate.eq.6) then Call Delstr(str,1,9) If(.not.table) Call Lbsup(str) C INST continuations Go to 610 Endif C All other continuations Go to 820 Endif C Blank lines are not allowed. If(str(10:).eq.' ') Go to 100 C Yes. Character position 6 is a blank or a '1'. C Does this card have a sym field? iend=0 If(Index(str,'$').gt.0) then c This is the easiest form to recognize. - sym$ iend=index(str,'$') Else if(str(19:19).eq.' ') then C This is still a possiblity for a sym field iend=19 Endif If(iend.gt.0) then sym=str(10:iend-1) Call Sqzstr(sym,' ') Call Chksym(sym,numsym) If(numsym.gt.0) Go to 150 Endif C This is not sym field form. It may be the old format. C Ignore any evaluators title card. Use programs default. If(Index(str,'TITLE:') .ne. 0) then Call Repstr(str,'TITLE:','TITL$') Write(iout,fmt='(A)') str(1:80) Go to 100 Endif If(Index(str,'ABSTRACT:') .ne. 0) then Call Delstr(str,1,9) loc = Index(str,'ABSTRACT:') Call Delstr(str,1,loc+9) Call Lbsup(str) Go to 310 Endif If(Index(str,'ACKNOW') .ne. 0) then Call Delstr(str,1,9) loc = Index(str,'ACKNOW') iend=Indexf(str,loc,':') If(iend.gt.0) Call Delstr(str,loc,iend-loc+1) Call Lbsup(str) Go to 410 Endif If(Index(str,'CUTOFF DATE:') .ne. 0) then loc = index(str,'CUTOFF DATE:') + 11 Call Delstr(str,1,loc) Call Lbsup(str) Go to 510 Endif If(Index(str,'INSTITUTION') .ne. 0) then loc=Index(str,':') Call Delstr(str,1,loc) Call Lbsup(str) Go to 610 Endif If(Index(str,'EVALUATOR') .ne. 0) then loc = Index(str,':') Call Delstr(str,1,loc) Call Lbsup(str) Go to 910 Endif If(Index(str,'*') .ne. 0) then loc = Index(str,'*') Call Delstr(str,1,loc) Call Lbsup(str) Go to 710 Endif locate=8 Call Delstr(str,1,9) If(.not.table) Call Lbsup(str) Go to 810 C C Do sym field 150 Continue Call Delstr(str,1,iend) Call Lbsup(str) C 'AUTH,TITL,ABST,ACKN,CUT ,INST,FUND,COMM,PERM,CIT ' Go to( 910, 210, 310, 410, 510, 610, 710, 810, 950,1010),numsym C Title 210 Continue C Do nothing to this. Ignored in publication at this time. output=card(1:9)//'TITL$'//str Write(iout,fmt='(A)') output(1:Lenstr(output)) output=' ' Go to 100 C ABSTRACT processing 310 Continue Call Fincom(col129,output) col129=card(1:9) locate = 3 edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(4,str,edtstr,ierr) Endif Endif output=edtstr Call Addstr(output,1,'ABST$') If(table) Call Fincom(col129,output) Go to 815 C ACKNOWLEDGMENT processing 410 Continue Call Fincom(col129,output) col129=card(1:9) locate = 4 edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' CALL EDIT(4,STR,edtstr,IERR) Endif Endif output=edtstr Call Addstr(output,1,'ACKN$') GO TO 815 C CUTOFF DATE processing 510 Continue Call Fincom(col129,output) col129=card(1:9) locate = 5 edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' CALL EDIT(4,STR,edtstr,IERR) Endif Endif output=edtstr Call Addstr(output,1,'CUT$') GO TO 815 C INSTITUTE processing 610 Continue Call Fincom(col129,output) col129=card(1:9) locate = 6 output=str str3=' ' C EDIT output by word (as seperated by blank characters) loc1 = 1 locf = Lenstr(output) 670 loc2 = Indexf(output,loc1,' ') If(loc2.gt.locf) loc2=0 lng = loc2 - loc1 If(loc2.eq.0) lng = locf - loc1 + 1 edtstr=output(loc1:loc1+lng-1) C Capitalize all words ... Call Edit(4,edtstr,str,ierr) C ... except the following. (Should really just lower case str.) If(Indexf(output,loc1,'AND ').eq.loc1)Call Edit(5,edtstr,str,ierr) If(Indexf(output,loc1,'OF ').eq.loc1)Call Edit(5,edtstr,str,ierr) If(Indexf(output,loc1,'THE ').eq.loc1)Call Edit(5,edtstr,str,ierr) If(Indexf(output,loc1,'FOR ').eq.loc1)Call Edit(5,edtstr,str,ierr) If(Indexf(output,loc1,'ON ').eq.loc1)Call Edit(5,edtstr,str,ierr) If(Indexf(output,loc1,'VOOR ').eq.loc1)Call Edit(5,edtstr,str, + ierr) C This logic assumes that the size of the edited string does not change. C We could handle that by deleting the string and then inserting the C new string and recalculatine loc1. C Add this word to the new string and put the blank back in. str3(Lenstr(str3)+2:)=STR If(loc2.eq.0) Go to 690 loc1 = loc2 + 1 Go to 670 690 Continue output=str3 C Special editing for abbreviations commonly used in addresses. Do 695 i=1,nabb edtstr=abbrev(i) If(lenstr(edtstr).eq.0) Go to 696 lng = Lenstr(edtstr) loc = Index(output,edtstr(1:lng)) If(loc.eq.0) Go to 695 edtstr=abbre2(i) lng = lenstr(edtstr) output(loc:loc+lng-1)=edtstr(1:lng) Go to 696 695 Continue 696 Continue Call Lbsup(output) If(col129(6:6).eq.' '.or.col129(6:6).eq.'1') then Call Addstr(output,1,'INST$') Else col129(6:6)='#' Call Addstr(output,1,' ') Endif col129(7:7)='c' Call Writcom(col129,output) GO TO 100 C Funding acknowledgment 710 Continue Call Fincom(col129,output) col129=card(1:9) locate = 7 edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(4,str,edtstr,ierr) Endif Endif str=' ' Call Lbsup(edtstr) output='FUND$'//edtstr(1:Lenstr(edtstr)) C Continuation cards for the Funding all handled here. 730 Continue itype = 6 lng=Lenstr(output) If(output(lng:lng).EQ.'.') itype = 4 Read(ioin,fmt='(A)',end=731) card If(card(1:10).eq.' ') Go to 731 str=card If(str(6:6).eq.' '.and.str(6:6).ne.'1') Go to 731 doedt=.true. If(str(7:7).eq.'c'.or.str(7:7).eq.'t') doedt=.false. table = ((str(7:7).eq.'T').or.(str(7:7).eq.'t')) Call Delstr(str,1,9) Call Lbsup(str) edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-itype,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(itype,str,edtstr,ierr) Endif Endif nspc=1 if(output(lng:lng).eq.'.') nspc=2 output(lng+1+nspc:)=edtstr Go to 730 C Finish output of funding acknowledgment. (Maximum fo 250 characters) 731 Continue C Handled as one long string so that the following substitutions can C be made. (Means that all the continuation cards will have 'x' in C column 6.) loc2 = Index(output,'|ms department of energy') If(loc2.ne. 0) then Call Delstr(output,loc2,24) Call Addstr(output,loc2,'US Department of Energy') Else loc2 = Index(output,'u.s. Department of energy') If(loc2 .ne. 0) then Call Delstr(output,loc2,25) Call Addstr(output,loc2,'US Department of Energy') Endif Endif lng=Lenstr(output) Do While(output.ne.' ') Call Writcom(col129,output) Call Lbsup(output) Enddo If(card(1:10).eq.' ') Go to 1000 Go to 104 C LOCATE=0 NO PREVIOUS COMMENT RECORD C LOCATE=1 UNASSIGNED C LOCATE=2 TITLE COMMENT RECORD PRECEDING C LOCATE=3 ABSTRACT COMMENT RECORD PRECEDING C LOCATE=4 ACKNOLEDGEMENT COMMENT RECORD PRECEDING C LOCATE=5 CUTOFF COMMENT RECORD PRECEDING C LOCATE=6 INSTITUTE COMMENT RECORD PRECEDING C LOCATE=7 FUNDING ACKNOWLEDGEMENT COMMENT RECORD PRECEDING C LOCATE=8 EVALUATORS COMMENT RECORD PRECEDING C LOCATE=9 EVALUATORS C COMMENT processing 810 Continue Call Fincom(col129,output) col129=card(1:9) locate = 8 edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' CALL EDIT(4,STR,edtstr,IERR) Endif Endif output=edtstr Call Addstr(output,1,'COMM$') itype = 5 lng=Lenstr(output) If(output(lng:lng).eq.'.') itype = 4 815 Continue Read(ioin,fmt='(A)',end=1000) card If(card(1:10).eq.' ') Go to 1000 str=card(1:80) If(str(6:6).eq.' '.or.str(6:6).eq.'1') Go to 104 820 Continue newln=.false. paragf=.false. If(str(6:6).eq.'#'.or.str(6:6).eq.'!') newln=.true. If(str(6:6).eq.'@') paragf=.true. doedt=.true. If(str(7:7).eq.'c'.OR.STR(7:7).eq.'t') doedt=.false. table = ((str(7:7).eq.'T').or.(str(7:7).eq.'t')) If(table.and.str(6:6).ne.'+') newln=.true. If(newln.or.paragf) then Call Fincom(col129,output) col129=card(1:9) itype=4 Else If(Lenstr(output).gt.0) then nspc=1 itype=6 If(output(Lenstr(output):Lenstr(output)).eq.'.') then nspc=2 itype=4 Endif Else itype=6 nspc=0 Endif Call Delstr(str,1,9) edtstr=str If(doedt) then If(table) then Call Edit(-itype,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(itype,str,edtstr,ierr) Endif Endif If(table.or.newln) then If(output.ne.' ') Call Fincom(col129,output) col129=card(1:9) Call Locase(col129(7:7)) If(edtstr.ne.' ') then Call Fincom(col129,edtstr) Else card=col129 Write(iout,fmt='(A)') card Endif Else lng=Lenstr(output) If(lng.gt.0) then Call Lbsup(edtstr) output(lng+1+nspc:)=edtstr Else output=edtstr Endif lng=Lenstr(output) If(lng.gt.71) then Call Writcom(col129,output) col129=card(1:9) Call Locase(col129(7:7)) If(paragf) col129(6:6)='x' Endif Endif Go to 815 C EVALUATORS processing 910 Continue Call Fincom(col129,output) col129=card(1:9) locate = 9 output=str If(Lenstr(output) .ne. 0) Go to 930 Read(ioin,fmt='(A)',end=920) card If(card(1:10).eq.' ') Go to 920 If(card(6:6).eq.' ') Go to 920 col129=card(1:9) output=card(10:) If(Lenstr(output).eq.0) Go to 920 Go to 930 920 Continue Write(*,*) ' ERROR ----- EVALUATOR NOT FOUND' output=' ' Go to 100 930 Continue Call Addstr(output,1,'AUTH$') col129(7:7)='c' card=col129(1:9)//output(1:71) Write(iout,fmt='(A)') card output=' ' Go to 100 950 Continue C PERM(.) card. Used for author footnotes. locate = 9 col129=card(1:9) edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-4,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(4,str,edtstr,ierr) Endif Endif output=sym(1:Lenstr(sym))//'$'//edtstr(1:Lenstr(edtstr)) 960 Continue itype = 6 Read(ioin,fmt='(A)',end=961) card If(card(1:10).eq.' ') then card=' ' Go to 961 Endif If(str(6:6).eq.' '.or.str(6:6).eq.'1') Go to 961 col129=card(1:9) str=card(1:80) doedt=.true. If(str(7:7).eq.'c'.or.str(7:7).eq.'t') doedt=.false. table = ((str(7:7).eq.'T').or.(str(7:7).eq.'t')) Call Delstr(str,1,9) Call Lbsup(str) edtstr=str If(doedt) then If(table) then col129(7:7)='t' Call Edit(-itype,str,edtstr,ierr) Else col129(7:7)='c' Call Edit(itype,str,edtstr,ierr) Endif Endif nspc=1 lng=Lenstr(output) If(output(lng:lng).eq.'.') nspc=2 output(lng+1+nspc:)=edtstr If(Lenstr(output).gt.71) Call Writcom(col129,output) Go to 960 C Finish output. 961 Continue Call Fincom(col129,output) Go to 104 C Citation 1010 Continue Call Fincom(col129,output) C Do nothing to this. Ignored in publication at this time. output=card(1:9)//'CIT$'//str Write(iout,fmt='(A)') output(1:Lenstr(output)) output=' ' col129=card(1:9) Go to 100 1000 Continue Call Fincom(col129,output) 1100 Continue C Write End of dataset card Write(iout,fmt='(80X)') Return End Subroutine Writcom(col129,outstr) Character*(*) col129, outstr Integer Lenstr Integer ioin, iout Common/iounit/ioin, iout Integer ind, ibreak Character*80 card card=col129 ind=Lenstr(outstr)+1 If(ind.gt.0) then ibreak=0 Do While(ind.gt.71.or.outstr(ind:ind).ne.' '.or. + ibreak.ne.0) If(outstr(ind:ind).eq.'{') ibreak=ibreak+1 If(outstr(ind:ind).eq.'}') ibreak=ibreak-1 ind=ind-1 Enddo If(ind.eq.1) ind=Min0(71,Lenstr(outstr)+1) card(10:)=outstr(1:ind) Call Delstr(outstr,1,ind) If(card(7:7).ne.'t') then col129(6:6)='x' Call Lbsup(outstr) Else C If this is a line in a table which is now greater than 71 C characters, make the next line an add on. "+" col129(6:6)='+' Endif Else card(10:)=' ' outstr=' ' Endif Write(iout,fmt='(A)') card Return End Subroutine Fincom(col129,outstr) Character*(*) col129, outstr Integer Lenstr Integer ioin, iout Common/iounit/ioin, iout Integer ind, ibreak Character*80 card card=col129 Do While(outstr.ne.' '.and.Lenstr(outstr).gt.0) ind=Lenstr(outstr)+1 ibreak=0 Do While(ind.gt.71.or.outstr(ind:ind).ne.' '.or. + ibreak.ne.0) If(outstr(ind:ind).eq.'{') ibreak=ibreak+1 If(outstr(ind:ind).eq.'}') ibreak=ibreak-1 ind=ind-1 If(ind.le.1) Go to 100 Enddo 100 Continue If(ind.le.1) ind=Min0(71,Lenstr(outstr)+1) ind=Lenstr(outstr(1:ind))+1 card(10:)=outstr(1:ind) Write(iout,fmt='(A)') card Call Delstr(outstr,1,ind) If(card(7:7).ne.'t') then card(6:6)='x' Call Lbsup(outstr) Else card(6:6)='+' If(outstr.ne.' ') Call Addstr(outstr,1,'\') Endif Enddo If(card(7:7).ne.'t') then col129(6:6)='x' Else col129(6:6)='+' Endif Return End SUBROUTINE CHKSYM(SYM,NUMSYM) CHARACTER*(*) SYM INTEGER NUMSYM INTEGER I CHARACTER*3 LGLSYM(10) DATA LGLSYM/'AUT','TIT','ABS','ACK','CUT','INS','FUN','COM','PER', *'CIT'/ NUMSYM=0 DO 10 I=1,10 IF(SYM(1:3).EQ.LGLSYM(I)) GO TO 20 10 CONTINUE RETURN 20 CONTINUE NUMSYM=I RETURN END Subroutine Opendic C CHARACTER*(*) WHEREDIC PARAMETER (WHEREDIC='[]') CHARACTER*255 FILENAME INTEGER LENSTR EXTERNAL LENSTR C INTEGER IOS C C SUBROUTINE TO OPEN DICTIONARY FILES USED BY THE EDIT ROUTINE C Reactions Dictionary FILENAME=WHEREDIC//'NSDDIC.1' OPEN(UNIT=41,FILE=FILENAME(1:LENSTR(FILENAME)),STATUS='OLD', *READONLY,ORGANIZATION='INDEXED',ACCESS='KEYED', *RECL=52,FORM='FORMATTED', *KEY=(3:22:CHARACTER), *IOSTAT=IOS,ERR=999) C Nuclides Dictionary FILENAME=WHEREDIC//'NSDDIC.2' OPEN(UNIT=42,FILE=FILENAME(1:LENSTR(FILENAME)),STATUS='OLD', *READONLY,ORGANIZATION='INDEXED',ACCESS='KEYED', *RECL=52,FORM='FORMATTED', *KEY=(3:22:CHARACTER), *IOSTAT=IOS,ERR=999) C Translations Dictionary FILENAME=WHEREDIC//'NSDDIC.3' OPEN(UNIT=43,FILE=FILENAME(1:LENSTR(FILENAME)),STATUS='OLD', *READONLY,ORGANIZATION='INDEXED',ACCESS='KEYED', *RECL=52,FORM='FORMATTED', *KEY=(3:22:CHARACTER), *IOSTAT=IOS,ERR=999) Return 999 CONTINUE Write(*,*) 'ERROR OPENING THE KEYED OUTPUT FILE (', 2 FILENAME(1:LENSTR(FILENAME)),'. IOSTAT=',IOS Return END SUBROUTINE EDIT(ITYPE,INP,OUTPUT,IERR) CHARACTER*(*) INP,OUTPUT Integer itype, ierr C SUBROUTINE TO CONVERT AN ALL UPPER CASE TEXT STRING TO UPPER AND C LOWER CASE WITH GREEK AND OTHER SPECIAL SYMBOLS. C ITYPE - 1, A DATA SET ID C 2, A STRING OF KEY NUMBERS C 3, A DATA CONTINUATION CARD C 4, GENERAL COMMENT WITH FIRST WORD CAPITALIZED C 5, GENERAL COMMENT, FIRST WORD NOT CAPITALIZED C 6, A COMMENT CONTINUATION C 7, A SPECIAL TEXT STRING C INPUT - THE ALL UPPER CASE TEXT STRING C OUTPUT - THE CONVERTED TEXT STRING C IERR - ERROR FLAG SET TO 1 IF ERROR DETECTED C INTEGER INDEXF, LENSTR, fldnum, Typstr EXTERNAL INDEXF, LENSTR C Commons Character*40 fldcod(8) Integer icrd Common/unfdata/fldcod, icrd C CHARACTER*100 INPUT,INTSTR,INTMST CHARACTER*40 WTEXT CHARACTER*30 NTEXT,RTEXT CHARACTER*20 NCODE,RCODE,WCODE CHARACTER*1 ICHARC,ICHARN,IDELAD,ILCHA,IDELDP INTEGER FINDC INTEGER I, IBEG, IBEG1, IBGN, ICAP, ICAPN, ICHA, IDEL, IDELIM, *IDELMP, IERRC, ifld, IGAM, IGT, ILEN, ILP, ILT, INEXT,iprev, *IRPAR, ISEC, IU1, IU2, JTYPE, KTYPE, L, icom, *LNB, lng, LNMST, LNOUT, LNSTR, NC, NCP, NCS, NEND, NIC, NN, *NONBLK, NS Integer LIB C C INITIALIZE ERROR FLAG C IERR = 0 INPUT=INP LNOUT=0 OUTPUT=' ' C C TRIM LENGTH OF INPUT TEXT STRING AND SET LENGTH VARIABLES C ILEN = LENSTR(INPUT) IF(ILEN.EQ.0) GO TO 1000 C C BRANCH ON TYPE OF TEXT STRING C KTYPE = IABS(ITYPE) GO TO (100,10,310,300,310,320,650),KTYPE C C PROCESS A STRING OF KEYNUMBERS C 10 IBEG = 1 C C EXTRACT NEXT 6 CHARACTERS FROM INPUT STRING C 15 NIC = IBEG + 5 IF(NIC.GT.ILEN) GO TO 900 INTSTR=INPUT(IBEG:NIC) C C SEE IF A VALID KEY NUMBER C CALL KEYREC(INTSTR,IERR) IF(IERR.GT.0) GO TO 900 C C CONVERT FOURTH CHARACTER TO LOWER CASE AND PUT IN OUTPUT STRING C INTSTR(4:4)=CHAR(ICHAR(INTSTR(4:4))+32) OUTPUT(LNOUT+1:)=INTSTR(:6) LNOUT=LNOUT+6 C C SEE IF MORE STRING TO BE PROCESSED C ICHARC = INPUT(NIC+1:NIC+1) IF(ICHARC.EQ.' ') GO TO 1000 IF(ICHARC.NE.',') GO TO 900 C C APPEND A COMMA TO OUTPUT STRING AND PROCESS ANOTHER KEYNUMBER C OUTPUT(LNOUT+1:)=',' LNOUT=LNOUT+1 IBEG = NIC + 2 GO TO 15 C C PROCESSING A DATA SET ID C 100 IBEG = 1 C First character of DSID will be capitalized ICAPN = 2 ICHARC = INPUT(1:1) 101 Continue C C LOOK FOR AN OPEN PAREN DELIMITING THE NUCLIDE CODE C For reaction data sets we need to find any commas outside the parenthesis C just in case there is a natural target with a translation in DIC#3. C crk IDEL = FINDC('(',INPUT,IBEG+2,4) idel=Findc('(',input,ibeg,6) IF(IDEL.EQ.0) GO TO 130 icom=Indexf(input,ibeg,',') JTYPE = 2 GO TO 140 C C LOOK FOR A BLANK DELIMITING THE NUCLIDE CODE C 130 IDEL = FINDC(' ',INPUT,IBEG+2,4) IF(IDEL.EQ.0) GO TO 330 JTYPE = 1 GO TO 140 C C EXTRACT NUCLIDE CODE FROM INPUT STRING C 140 NC = IDEL - IBEG C When there is a multiple reaction for one target, there is no nuclide for C the second reaction and ibeg=idel. If(ibeg.eq.idel) Go to 150 NIC = IDEL - 1 INTSTR=INPUT(IBEG:NIC) C C PACK NUCLIDE CODE STRING AND LOOK UP THE CODE C NCODE=INTSTR(1:20) C FIND ISOTOPE RECORD. C GET ISOTOPE. READ(UNIT=42,FMT='(1X,I1,A20,A30)',KEY=NCODE,ERR=330) * LIB,NCODE,NTEXT UNLOCK 42 INTMST=NTEXT LNMST=LENSTR(INTMST) OUTPUT(LNOUT+1:)=INTMST LNOUT=LNOUT+LNMST IBEG = IDEL C C PROCESS REST OF STRING AS A GENERAL COMMENT IF A DECAY DATA SET C (JTYPE=1) C IF(JTYPE.EQ.1) GO TO 330 C C LOOK FOR A REACTION CODE C 150 Continue IRPAR = FINDC(')',INPUT,IBEG,256) C*****ERROR IF A RIGHT PAREN NOT FOUND IF(IRPAR.NE.0) GO TO 270 GO TO 900 C C EXTRACT REACTION CODE C 270 CONTINUE INTSTR=INPUT(IBEG:IRPAR) LNSTR=LENSTR(INTSTR) NC=LNSTR NIC = IRPAR C C LOOK FOR A REACTION WITH OUTGOING GAMMAS IN ADDITION TO OTHER C PARTICLES C IGAM = 0 IF(INTSTR(NC-1:NC-1).NE.'G'.OR.INTSTR(NC-2:NC-2).EQ.',') *GO TO 275 C C OUTGOING GAMMAS FOUND SO REMOVE GAMMA CODE AS DICTIONARIES HAVE C REACTIONS WITHOUT OPTIONAL GAMMA CODE C IGAM = 1 INTSTR(NC-1:NC-1) = ')' LNSTR=LNSTR-1 INTSTR=INTSTR(1:LNSTR) C C PACK REACTION CODE STRING AND LOOK IT UP IN THE DICTIONARY C 275 CONTINUE RCODE=INTSTR(1:20) C FIND REACTION RECORD. C GET REACTION. READ(UNIT=41,FMT='(1X,I1,A20,A30)',KEY=RCODE,ERR=900) * LIB,RCODE,RTEXT UNLOCK 41 INTMST=RTEXT LNMST=LENSTR(INTMST) IF(IGAM.EQ.0) GO TO 290 CALL DELSTR(INTMST,LNMST,1) CALL ADDSTR(INTMST,LNMST,'|g)') LNMST=LNMST+2 C C APPEND EXPANSION TO OUTPUT STRING C 290 OUTPUT(LNOUT+1:)=INTMST LNOUT=LNOUT+LNMST C C TREAT REST OF STRING LIKE A GENERAL COMMENT if the next char is not a ",". C 291 Continue IBEG = NIC + 1 ICHARC = INPUT(IBEG:IBEG) If(icharc.eq.',') then output(lnout+1:)=icharc lnout=lnout+1 ibeg=ibeg+1 Do While(input(ibeg:ibeg).eq.' ') output(lnout+1:)=' ' lnout=lnout+1 ibeg=ibeg+1 Enddo C Beginning character must be a nonblank or it won't find the nuclide. icharc=input(ibeg:ibeg) Go to 101 Endif GO TO 330 C C ENTRY POINT FOR PROCESSING A GENERAL COMMENT WITH FIRST WORD TO BE C CAPITALIZED C 300 ICAPN = 2 GO TO 320 C C ENTRY POINT FOR PROCESSING A GENERAL COMMENT WITH THE FIRST WORD C NOT CAPITALIZED C 310 ICAPN = 1 C C ENTRY POINT FOR PROCESSING A GENERAL COMMENT CONTINUATION C 320 IBEG = 1 330 IDELIM = 0 C C COPY TO OUTPUT STRING, ANY BLANKS IN THE INPUT STRING WHICH C PRECEDE THE NEXT LOGICAL WORD C 350 IF(IBEG.GT.ILEN) GO TO 950 DO 355 NN=IBEG,ILEN IF(INPUT(NN:NN).NE.' ') GO TO 360 LNOUT = LNOUT + 1 355 CONTINUE GO TO 950 360 CONTINUE IBEG = NN C C SET PROCESSING CONTROL VARIABLES FOR NEXT LOGICAL WORD C ICAP = ICAPN ICAPN = 1 If(icap.eq.1000) Go to 380 C C PROCESS WORD BEGINNING WITH AN INTEGER C IBEG1 = IBEG IF(INPUT(IBEG:IBEG).EQ.'.') IBEG1 = IBEG + 1 IF(INPUT(IBEG1:IBEG1).LT.'0'.OR.INPUT(IBEG1:IBEG1).GT.'9') *GO TO 380 CALL NUMANL(INPUT,IBEG,NC,INTSTR,IDELIM) C IDELIM CAN NOT BE 1. 0 MEANS THE NEXT CHARACTER IS A BLANK LNSTR=LENSTR(INTSTR) If(idelim.eq.17) then intstr(lnstr:)=' ' lnstr=lnstr-1 nc=nc-1 Endif C IS IT A NILSSON? IF(IDELIM.NE.7.OR.INTSTR(NC:NC).NE.']') GO TO 374 L=LENSTR(OUTPUT)-2 IF(OUTPUT(L:L).NE.'|') GO TO 374 IF(OUTPUT(L+2:L+2).NE.' ') GO TO 374 CALL ADDSTR(OUTPUT,L,'{ ') LNOUT=LNOUT+1 CALL ADDSTR(INTSTR,LNSTR+1,'}') LNSTR=LNSTR+1 374 CONTINUE C C CODE TO HANDLE A LIST OF A'S PROCEEDING AN ELEMENT C IF(INTSTR(1:1).NE.'{'.OR.INTSTR(2:2).NE.'+'.OR.INTSTR(3:3).LT.'0' *.OR.INTSTR(3:3).GT.'9') GO TO 379 NEND = LNOUT DO 375 I=NEND,1,-1 IF(OUTPUT(I:I).GE.'0'.AND.OUTPUT(I:I).LE.'9') GO TO 375 IF(OUTPUT(I:I).EQ.',') GO TO 375 GO TO 376 375 CONTINUE I = 0 376 CONTINUE IF(I.GE.LNOUT-1) GO TO 379 CALL ADDSTR(OUTPUT,I+1,'{+') LNOUT=LNOUT+2 CALL DELSTR(INTSTR,1,2) LNSTR=LNSTR-2 379 CONTINUE C END OF CODE TO HANDLE LIST OF A'S C OUTPUT(LNOUT+1:)=INTSTR LNOUT=LNOUT+LNSTR ICHARN = INPUT(IBEG+NC:IBEG+NC) C idelim of 3 is a "." and icapn causes next word to be capitalized. IF(IDELIM.EQ.3) ICAPN = 2 GO TO 625 C C EXTRACT NEXT LOGICAL WORD FROM THE INPUT STRING C 380 CONTINUE CALL WORD(INPUT,IBEG,1,INTSTR,IDELIM) LNSTR = LENSTR(INTSTR) IF(IDELIM.LE.1) LNSTR=LNSTR+1 NC = LNSTR NCP = 0 IGAM = 0 C C EXTRACT CHARACTER FOLLOWING THE DELIMITER C 390 INEXT = IBEG + NC ICHARN = INPUT(INEXT:INEXT) IDELAD = '`' IF(INTSTR(1:1).NE.'(') GO TO 400 IF(INEXT.LE.ILEN+1) GO TO 400 NC = 1 INTSTR='(' LNSTR=1 IDELIM=0 GO TO 600 C C BRANCH ON TYPE OF DELIMITER FOUND C C ' ',',','.',';',':','(',')','-','=','+','>','<','/' C '?',''','$','^','[',']','{','}' 400 GO TO (460,450,410,450,440,450,450,450,450,435,450,450,430, 1 450,450,460,445,450,450,450,450),IDELIM C C PERIOD DELIMITER C 410 CONTINUE IF(ICHARN.EQ.' ') GO TO 420 C C IF NEXT CHARACTER IS NOT A BLANK THEN PERIOD IS NOT A DELIMITER C IF(ICHARN.EQ.'(') GO TO 450 CALL WORD(INPUT,INEXT,1,INTMST,IDELIM) INTSTR(LNSTR+1:)=INTMST LNSTR = LENSTR(INTSTR) IF(IDELIM.LE.1) LNSTR=LNSTR+1 NC = LNSTR GO TO 390 C C REAL DELIMITER SO SET FLAG TO CAPITALIZE NEXT LOGICAL WORD. C 420 ICAPN = 2 GO TO 450 C C SLASH DELIMITER C 430 IF(ICHARN.EQ.'T') GO TO 450 GO TO 440 C C "+" DELIMITER C 435 IF(ICHARN.EQ.'/') GO TO 450 C C LOOK FOR THE CHAR-DELIM-CHAR PATTERN C 440 IF(LNSTR.NE.2.AND.LNSTR.NE.3) GO TO 450 CALL LDL(INPUT,IBEG,IDELIM,NCS) IF(NCS.EQ.0) GO TO 450 NC = NCS INTSTR=INPUT(IBEG:IBEG+NC-1) GO TO 600 C "^" delimiter. Do nothing up to the next delimiter, output as is. 445 Continue C If preceded by "|", then this is the up arrow and not a delimiter. iprev = IBEG + NC - 2 If(INPUT(iprev:iprev).eq.'|') then CALL WORD(INPUT,ibeg+nc,1,INTMST,IDELIM) INTSTR(LNSTR+1:)=INTMST LNSTR = LENSTR(INTSTR) IF(IDELIM.LE.1) LNSTR=LNSTR+1 NC = LNSTR GO TO 390 Endif icapn=1000 LNSTR=LENSTR(INTSTR) If(lnstr.gt.1) then C This handles the case where a "^" is encountered again and INTSTR has C not yet been output. intmst=intstr Go to 476 Endif IBEG = IBEG + NC GO TO 350 C Go to 640 C C SET UP TO LOOK UP WORD INCLUDING DELIMITER C 450 IF(LNSTR.LE.1) GO TO 600 If(icap.eq.1000) Go to 600 ISEC = 0 INTMST=INTSTR(1:LNSTR) LNMST=LNSTR GO TO 470 C C SET UP TO LOOK UP WORD WITH DELIMITER REMOVED C 460 CONTINUE IF(LNSTR.LT.1) GO TO 600 If(icap.eq.1000) Go to 600 ISEC = 1 INTMST=INTSTR(1:LNSTR) LNMST=LNSTR IDELAD = INTMST(LNMST:LNMST) INTMST(LNMST:LNMST) = ' ' LNMST=LNMST-1 WCODE=INTMST(1:20) Go to 471 C C LOOK UP IN WORD DICTIONARY C 470 CONTINUE WCODE=INTMST(1:20) 471 Continue If(itype.eq.3) then lng=Lenstr(wcode) ifld=Fldnum(wcode(1:lng),icrd) If(ifld.gt.0) then wtext=fldcod(ifld) Go to 475 Endif Endif C FIND WORD RECORD. C GET WORD. READ(UNIT=43,FMT='(1X,I1,A20,A30)',KEY=WCODE,ERR=500) * LIB,WCODE,WTEXT UNLOCK 43 475 CONTINUE C GET WORD. IF(WTEXT(1:5).NE.'.....') GO TO 490 IF(ISEC.EQ.1.AND.IDELIM.NE.1) GO TO 485 C C Another word or special delimiter is needed. Save length and delimiter C for first word only. C C IF THE NEXT CHARACTER IS '(' THEN DON'T ADD WORD BUT CHECK SPECIAL IF(INPUT(INEXT:INEXT).EQ.'(') GO TO 485 C HOWEVER, IF THIS IS THE END OF THE LINE WE MUST STOP IF(IDELIM.EQ.0) GO TO 500 IF(NCP.NE.0) GO TO 480 NCP = NC IDELDP = IDELAD IDELMP = IDELIM C C GET NEXT WORD AND ADD IT TO THE TEST STRING C 480 CONTINUE CALL WORD(INPUT,INEXT,1,INTMST,IDELIM) LNMST=LENSTR(INTMST) NONBLK=LNMST IF(IDELIM.LE.1) LNMST=LNMST+1 IF(IDELIM.LE.1) IDELAD = ' ' ISEC = 0 INTSTR(LNSTR+1:)=INTMST LNSTR=LNSTR+LNMST INTMST=INTSTR(1:LNSTR) LNMST=LNSTR NC = LNSTR INEXT = IBEG + NC ICHARN = INPUT(INEXT:INEXT) IF(NONBLK.EQ.0) GO TO 485 C C LOOK UP NEW TEST STRING C WCODE=INTMST(1:20) C FIND WORD RECORD. C GET WORD. READ(UNIT=43,FMT='(1X,I1,A20,A30)',KEY=WCODE,ERR=476) * LIB,WCODE,WTEXT UNLOCK 43 GO TO 475 476 CONTINUE C C COULD NOT FIND THE STRING SO TRY WITHOUT THE DELIMITER C IF(IDELIM.LE.1) GO TO 485 ISEC = 1 IDELAD = INTMST(LNSTR:LNSTR) INTMST(LNSTR:LNSTR) = ' ' WCODE=INTMST(1:20) C FIND WORD RECORD. C GET WORD. READ(UNIT=43,FMT='(1X,I1,A20,A30)',KEY=WCODE,ERR=485) * LIB,WCODE,WTEXT UNLOCK 43 GO TO 475 485 CONTINUE C C TRY WITH SPECIAL DELIMITER CORRESPONDING TO A BLANK C INTMST(LNSTR:LNSTR)='_' WCODE=INTMST(1:20) C FIND WORD RECORD. C GET WORD. READ(UNIT=43,FMT='(1X,I1,A20,A30)',KEY=WCODE,ERR=486) * LIB,WCODE,WTEXT UNLOCK 43 C RESTORE THE BLANK INTMST(LNSTR:LNSTR)=' ' GO TO 475 486 CONTINUE INTMST(LNSTR:LNSTR)=' ' LNSTR=LNSTR-1 GO TO 500 C C IF A PERIOD DELIMITER RESET NEXT WORD CAPITAL CONTROL C 490 IF(IDELIM.NE.3) GO TO 495 IF(NCP.NE.0) ICAPN = 2 IF(ISEC.EQ.0) ICAPN = 1 C C CONVERT EXPANSION TO A STRING C 495 CONTINUE WRITE(INTMST,FMT='(A29)') WTEXT LNMST=LENSTR(INTMST) IF(WCODE.EQ.'MULT '.AND.ICAP.EQ.2) INTMST(1:1)='M' C C LOOK FOR LEAD IN TO A CONFIGURATION MIXING STRING C IF(WCODE.NE.'CONF='.OR.ICHARN.NE.'(') GO TO 498 IF(ICAP.EQ.2) INTMST(1:1)='C' OUTPUT(LNOUT+1:)=INTMST LNOUT=LNOUT+LNMST IBEG = IBEG + NC NC = 0 CALL CONFIG(INPUT,IBEG,NC,INTSTR,IERRC) IF(IERRC.NE.0) GO TO 350 IDELIM = 0 GO TO 615 C C A BACKSLASH SIGNALS THAT A FOLLOWING BLANK SHOULD BE REMOVED C 498 LNMST=LENSTR(INTMST) ILCHA = INTMST(LNMST:LNMST) IF(ILCHA.NE.'\') GO TO 550 INTMST(LNMST:)=' ' LNMST=LNMST-1 IDELIM = 0 GO TO 550 C C MATCH NOT FOUND SO SET UP NEXT TRY IF REQUIRED C 500 IF(NCP.EQ.0) GO TO 505 ISEC = 0 IDELAD = IDELDP IDELIM = IDELMP NC = NCP LNSTR = NC NCP = 0 INTMST=INTSTR(1:LNSTR) LNMST=LNSTR IF(IDELIM.EQ.1) GO TO 485 C C SEE IF A TRY WITHOUT THE DELIMITER REQUIRED C 505 IF(ISEC.EQ.1.OR.IDELIM.LE.1) GO TO 510 IF(IDELIM.EQ.7.AND.INTSTR(1:1).EQ.'(') GO TO 520 GO TO 460 C C SEE IF AN ELEMENT C 510 IF(LNMST.GT.2) GO TO 515 NCODE=INTMST(1:20) C FIND ISOTOPE RECORD. C GET ISOTOPE. READ(UNIT=42,FMT='(1X,I1,A20,A30)',KEY=NCODE,ERR=515) * LIB,NCODE,NTEXT UNLOCK 42 INTMST=NTEXT IF(LENSTR(INTMST).EQ.1) GO TO 570 CALL STRLC(INTMST,2,1) GO TO 570 C C NOT SPECIAL WORD OR SYMBOL SO LOWER CASE IT WITH A LEADING C UPPER CASE IF REQUIRED 515 CONTINUE C IF DSID CAPITALIZE ALL WORDS FOLLOWING A BLANK IF(KTYPE.NE.1) GO TO 516 IF(LNOUT.LT.1) GO TO 516 IF(OUTPUT(LNOUT:LNOUT).EQ.' ') ICAP= 2 516 CONTINUE If(icap.le.2.and.Typstr(intmst(1:1)).eq.2) then NS = NC + 1 - ICAP CALL STRLC(INTMST,ICAP,NS) Endif GO TO 570 C C POSSIBLE REACTION C C*****LOOK FOR A REACTION WITH OUTGOING GAMMAS IN ADDITION TO OTHER C***** PARTICLES 520 LNMST = LENSTR(INTMST) IF(INTMST(LNMST-1:LNMST-1).NE.'G'.OR.INTMST(LNMST-2:LNMST-2).EQ. *',') GO TO 530 C C OUTGOING GAMMAS FOUND SO REMOVE GAMMA CODE AS DICTIONARIES HAVE C REACTIONS WITHOUT OPTIONAL GAMMA CODE AND PACK IT C IGAM = 1 LNMST = LNMST - 1 INTMST(LNMST:) = ')' INTMST=INTMST(1:LNMST) C C LOOK UP IN THE REACTION DICTIONARY C 530 CONTINUE RCODE=INTMST(1:20) C FIND REACTION RECORD. C GET REACTION. READ(UNIT=41,FMT='(1X,I1,A20,A30)',KEY=RCODE,ERR=540) * LIB,RCODE,RTEXT UNLOCK 41 INTMST=RTEXT LNMST=LENSTR(INTMST) GO TO 550 C C NO SO SET UP TO PROCESS EACH COMPONENT WITHIN THE PARENTHESES C 540 CONTINUE NC = 1 INTSTR=INTSTR(1:1) LNSTR=1 GO TO 600 C C CONVERT EXPANSION OF WORD TO A TRIMMED STRING C 550 CONTINUE C C APPEND GAMMA IF NECESSARY C IF(IGAM.EQ.0) GO TO 570 INTMST(LNMST:)='|g)' LNMST=LENSTR(INTMST) C C RESTORE DELIMITER TO STRING IF REQUIRED C 570 CONTINUE IF(IDELAD.EQ.'`'.or.idelad.eq.'^') GO TO 590 IF(IDELIM.EQ.0) GO TO 590 C C RESTORATION REQUIRED EXCEPT FOR OPEN PAREN C IF(IDELIM.EQ.6) GO TO 585 LNMST = LENSTR(INTMST) + 1 INTMST(LNMST:) = IDELAD GO TO 590 C C OPEN PAREN DELIMITER SHOULD BE REMOVED IN ALL CASES C 585 NC = NC - 1 C C COPY STRING TO FINAL WORD STRING C 590 INTSTR=INTMST LNSTR=LNMST C C ATTACH CONVERTED STRING TO THE OUTPUT STRING C 600 IF(INTSTR(1:1).NE.'\') GO TO 615 CALL DELSTR(INTSTR,1,1) IF(OUTPUT(LNOUT:LNOUT).EQ.' ') LNOUT=LNOUT-1 615 OUTPUT(LNOUT+1:)=INTSTR LNSTR=LENSTR(INTSTR) IF(IDELIM.EQ.1) LNSTR=LNSTR+1 LNOUT =LNOUT+LNSTR C C A BLANK MUST FOLLOW A ";" OR "$". ONE MUST FOLLOW A ":" ON DSID C 625 IF(ITYPE.LT.0) GO TO 640 C ' ' ',' '.' ';' ':' '(' ')' '-' '=' '+' '>' '<' '/' C '?' ''' '$' '^' '[' ']' '{' '}' IF(IDELIM.EQ.16) GO TO 630 !'$' IF(IDELIM.EQ.4) GO TO 630 !';' IF(IDELIM.EQ.5.AND.ITYPE.EQ.1) GO TO 630 !':' and a DSID GO TO 640 630 IF(ICHARN.EQ.' ') GO TO 640 LNOUT=LNOUT+1 C C SET TO PROCESS NEXT WORD C 640 CONTINUE IBEG = IBEG + NC IF(ITYPE.NE.3.OR.(IBEG.le.ILEN.AND.IDELIM.NE.16)) GO TO 645 C ITYPE=3 is an Unformatted data record. C FIND THE END. THE LAST CHARACTER IS ALWAYS A BLANK C FIND BEGINNING OF THIS ENTRY, NEXT TO LAST CHARTACTER MAY BE A $, C SO IGNORE IT (i.e. start at lnb-1 and look backward) LNB=LENSTR(OUTPUT) DO 641 I=LNB-1,1,-1 IF(OUTPUT(I:I).EQ.'$') GO TO 642 641 CONTINUE I = 0 642 CONTINUE IBGN = I + 1 ILT = INDEXF(OUTPUT,IBGN,'<') IGT = INDEXF(OUTPUT,IBGN,'>') IF(ILT.EQ.0.OR.IGT.EQ.0) GO TO 645 LNOUT=LNB+1 IU1 = IGT IF(OUTPUT(IU1-1:IU1-1).EQ.'|') IU1 = IU1 - 1 C IU1 is the first character of ">" or "|>" in output string. IF(ILT.GT.IGT) then C Form is x>ab and should become bb (refnum) ILP = INDEXF(OUTPUT,MAX0(ILT,IGT)+1,'(') IF(ILP.GT.0.AND.ILP.LT.IU2) IU2 = ILP-1 Endif C IU2 is the first character of "<" or "|<" or the end of the string plus on OUTPUT(IGT:IGT)='<' INTSTR=OUTPUT(IU1:IGT) LNSTR=LENSTR(INTSTR) INTMST=OUTPUT(IGT+1:IU2-1) LNMST=LENSTR(INTMST) CALL DELSTR(OUTPUT,IU1,IU2-IU1) LNOUT=LNOUT-(IU2-IU1) CALL ADDSTR(OUTPUT,IBGN,INTSTR(:LNSTR)) LNOUT=LNOUT+LNSTR CALL ADDSTR(OUTPUT,IBGN,INTMST(:LNMST)) LNOUT=LNOUT+LNMST 645 CONTINUE GO TO 350 C C A SPECIAL TEXT STRING C 650 CONTINUE WCODE=INPUT(1:20) C FIND WORD RECORD. C GET WORD. READ(UNIT=43,FMT='(1X,I1,A20,A30)',KEY=WCODE,ERR=900) * LIB,WCODE,WTEXT UNLOCK 43 OUTPUT=WTEXT LNOUT=LENSTR(OUTPUT) IF(INDEX(OUTPUT,'config').EQ.1) OUTPUT(1:1)='C' OUTPUT(LNOUT+1:)=':' LNOUT=LNOUT+1 GO TO 950 C C ERROR EXIT SO SET FLAG AND COPY INPUT TO OUTPUT STRING C 900 IERR = 1 OUTPUT=' ' OUTPUT=INPUT//'**EDIT ERROR**' C C TRIM OUTPUT STRING BEFORE RETURNING C 950 LNOUT=LENSTR(OUTPUT) CALL CONCHR(OUTPUT) IF(ITYPE.GT.0) CALL SUPBLK(OUTPUT) IF(KTYPE.eq.1) then ICHA = INDEX(OUTPUT,'decay') IF(ICHA.NE.0) OUTPUT(ICHA:ICHA) = 'D' Endif 1000 RETURN END SUBROUTINE NUMANL(INPUT,IBEG,NC,INTSTR,IDELIM) C C ROUTINE TO PROCESS A STRING WHOSE FIRST CHARACTER IS AN INTEGER C CHARACTER*(*) INPUT,INTSTR Integer ibeg, nc, idelim C C Functions INTEGER IVLSTR, LENSTR EXTERNAL IVLSTR, LENSTR C INTEGER IADZ, IE, II, IKEEP, ILEN, IMAX, IMINUS, *INEXT, INTMP, IP, IPCNT, IPER, IPOS, J, JDELIM, *JERR, JLO, LNMST, LNSTR, MOVD, N, *NFRAC, NL, NMBLK, NONBLK, NUNITS Integer LIB Logical META CHARACTER*100 INTMST CHARACTER*1 NCHAR,IDELC,NSIGN,ICHART CHARACTER*5 UNIT,UNITS(30),CUNITS(30)*6 CHARACTER*10 ZEROS CHARACTER*30 NTEXT,NCODE*20 DATA NUNITS/27/,UNITS/'S','M','H','D','Y','MS','US','MEV','KEV', 1 'EV','NS','PS','FS','MIN','MB','KOE','UG','MG','FM','MILLI', * 'CM','CM**2','CM2','FM**2','SR','B','AS',' ',' ',' '/ DATA CUNITS/'s','min','h','d','y','ms','|ms','MeV','keV', 1 'eV','ns','ps','fs','min','mb','kOe','|mg','mg','fm','m', * 'cm','cm{+2}','cm{+2}','fm{+2}','sr','b','as',' ',' ',' '/ DATA ZEROS/'0000000000'/ C FIND END OF NUMBER C IADZ = 0 IPER = 0 ILEN=LENSTR(INPUT)+1 NC=0 IDELIM=1 IF(IBEG.GT.ILEN) GO TO 1000 C Check for a number (including a possible decimal point). N is the location C of the first nonnumeric character to be found. DO 25 N=IBEG,ILEN NCHAR = INPUT(N:N) IF(NCHAR .LT. '0' .OR. NCHAR .GT. '9')THEN IF(NCHAR.NE.'.') GO TO 50 C The following test makes sure that a decimal number does not C include a puncuation period but only a decimal point. IF(IPER.EQ.1) GO TO 50 IPER = 1 ENDIF 25 CONTINUE C C GET REST OF WORD CONTAINING NUMBER C 50 NC = N - IBEG INTSTR=INPUT(IBEG:N-1) LNSTR=LENSTR(INTSTR) C The string INTSTR now contains the number (including a possible decimal) C upto but not including the break character. CALL WORD(INPUT,IBEG+NC,0,INTMST,IDELIM) LNMST=LENSTR(INTMST) IF(IDELIM.EQ.1) LNMST=LNMST+1 NC = NC + LNMST INTSTR(LNSTR+1:)=INTMST(1:LNMST) LNSTR=NC IF(LNMST.EQ.1) THEN C Must still check to see if this is a five-integer code C when there is a period delimiter TWB 881020 IF(LNSTR .EQ. 6 2 .OR. (LNSTR .EQ. 7 .AND. INTSTR(6:6) .EQ. '.'))THEN C C SEE IF A 5 INTEGER NUCLIDE CODE C C Not finding the code when trailed by a non-blank TWB 881020 NCODE=INTSTR(1:5) C FIND ISOTOPE RECORD. C GET ISOTOPE. READ(UNIT=42,FMT='(1X,I1,A20,A30)',KEY=NCODE,ERR=300) * LIB,NCODE,NTEXT UNLOCK 42 IDELC = INTSTR(6:6) C Must now put the sixth character back in since it may C not be a blank TWB 881021 INTSTR=NTEXT//INTSTR(6:6) C Length counter for string not modified correctly TWB 880615 LNSTR=LENSTR(INTSTR) C Done, cleanup and return. GO TO 800 ELSE C Look for uncertainty, units, or units-uncertainty. GO TO 300 ENDIF ENDIF C C SEE IF A NUMBER TERMINATED BY A PERCENT SIGN C IF(INTMST(1:1).EQ.'%') THEN C If % followed by anything other than a valid delimiter, then remove the C LNMST characters added to INTSTR and lower case all but the C first character and the delimiter. IF(LNMST.GT.2) GO TO 600 C Look for uncertainty, units, or units-uncertainty. GO TO 300 ENDIF C C IF REST OF WORD DOES NOT BEGIN WITH A LETTER THEN TREAT AS C AN ORDINARY WORD C C If the new 'word' does not begin with a letter then remove the LNMST C characters added to INTSTR and lower case all but the C first character and the delimiter. IF(INTMST(1:1).LT.'A'.OR.INTMST(1:1).GT.'Z') GO TO 600 C C SEE IF IT COULD BE A NUCLIDE CODE OR A KEYNUMBER C C CODE COULDN'T HANDLE AAAmZZ BECAUSE NCODE IS ONLY 5 CHARACTERS, SO LET US C TAKE OUT THE m. META=.FALSE. IMAX = 7 IF(IPER.EQ.1.OR.LNSTR.GT.IMAX) GO TO 200 IF(INTMST(1:1).NE.'M') GO TO 111 IF(INTMST(2:2).EQ.'D'.OR. * (INTMST(2:2).EQ.'G'.AND.(INTMST(3:3).NE.'A'.AND. * INTMST(3:3).NE.'D'.AND.INTMST(3:3).NE.'E')).OR. * INTMST(2:2).EQ.'N'.OR. * INTMST(2:2).EQ.'O') GO TO 111 META=.TRUE. CALL DELSTR(INTSTR,NC-LNMST+1,1) 111 CONTINUE IF(LNSTR.EQ.IMAX.AND.(.NOT.META)) GO TO 150 C C LOOK FOR A NUCLIDE CODE C NL = LNSTR-1 NCODE=INTSTR(1:NL) C FIND ISOTOPE RECORD. C GET ISOTOPE. READ(UNIT=42,FMT='(1X,I1,A20,A30)',KEY=NCODE,ERR=140) * LIB,NCODE,NTEXT UNLOCK 42 C C IS A VALID NUCLIDE CODE C INTSTR=NTEXT IF(META) CALL ADDSTR(INTSTR,INDEX(INTSTR,'}'),'m') LNSTR=LENSTR(INTSTR) INTSTR(LNSTR+1:) = INTMST(LNMST:LNMST) LNSTR=LNSTR+1 C Done, cleanup and return. GO TO 800 C C SEE IF A KEY NUMBER C 140 CONTINUE IF(META) CALL ADDSTR(INTSTR,NC-LNMST+1,'M') IF(LNSTR.NE.IMAX) GO TO 200 150 CALL KEYREC(INTSTR,JERR) C If not a keynumber then remove the LNMST characters added to C INTSTR and lower case all but the first character and the delimiter. IF(JERR.NE.0) GO TO 600 C A six character keynumber has been located. Make 4th character lower case. CALL STRLC(INTSTR,4,1) C Done, cleanup and return. GO TO 800 C C SEE IF NUMBER IN EXPONENTIAL NOTATION OR A NUMBER WITH A PARTICLE C TRAILER C 200 CONTINUE C If more than a single character, followed by a delimiter then C remove the LNMST characters added to INTSTR and lower case all but the C first character and the delimiter. IF(LNMST.GT.2) GO TO 600 IF(INTMST(1:1).NE.'E') GO TO 250 C C LOOK FOR EXPONENTIAL FORM C C If a number is followed by an 'E' and a delimiter then that delimiter C must be a '+' or a '-' to be a number in exponential form, remove the C LNMST characters added to INTSTR and lower case all but the C first character and the delimiter if this is not the case. IF(INTMST(2:2).NE.'+'.AND.INTMST(2:2).NE.'-') GO TO 600 INTMP=LENSTR(INTMST) CALL WORD(INPUT,IBEG+NC,0,INTMST,JDELIM) LNMST=LENSTR(INTMST) IF(JDELIM.EQ.0) GO TO 590 IPCNT = INDEX(INTMST,'%') IF(IPCNT.EQ.0) GO TO 201 CALL DELSTR(INTMST,IPCNT,1) LNMST=LNMST-1 NC = NC + 1 201 CONTINUE LNMST = LENSTR(INTMST) IF(JDELIM.EQ.1) LNMST=LNMST+1 IF(LNMST.GT.3) GO TO 590 C C CHECK FOR ONE OR TWO DIGITS C IF(INTMST(1:1).LT.'0'.OR.INTMST(1:1).GT.'9') GO TO 590 IF(LNMST.EQ.2) GO TO 220 IF(INTMST(2:2).LT.'0'.OR.INTMST(2:2).GT.'9') GO TO 590 C C IS NUMBER IN EXPONENTIAL FORM C 220 NC = NC + LNMST IDELIM = JDELIM C INTSTR ENDS WITH EITHER 'E+' OR 'E-' AT THIS POINT NSIGN = INTSTR(LNSTR:LNSTR) IF(NSIGN.EQ.'+') NSIGN=' ' LNSTR=LNSTR-2 INTSTR(LNSTR+1:)='|*10{+'//NSIGN C REMOVE LEADING ZERO IF(INTMST(1:1).EQ.'0') CALL DELSTR(INTMST,1,1) C ADD THE NUMERIC VALUE FROM INTMST INTSTR(LENSTR(INTSTR)+1:)=INTMST IPOS=LENSTR(INTSTR) IF(IDELIM.EQ.1) IPOS=IPOS+1 IF(IPCNT.GT.0) CALL ADDSTR(INTSTR,IPOS,'%') C TERMINATE EXPONENT FORM WITH '}' CALL ADDSTR(INTSTR,IPOS,'}') LNSTR=LENSTR(INTSTR) IF(IDELIM.EQ.1) LNSTR=LNSTR+1 C SHALL WE CONVERT THIS TO FLOATING POINT C DON'T MOVE FOR NEGATIVE EXPONENT IF(NSIGN.EQ.'-') GO TO 230 IP = INDEX(INTSTR,'.') IE = INDEX(INTSTR,'|') - 1 NFRAC = IE - IP IF(IP.EQ.0) NFRAC = 0 MOVD = IVLSTR(INTMST) IF(MOVD.GT.NFRAC+1) GO TO 230 C OKAY, DO IT IADZ = MOVD - NFRAC IF(IADZ.LT.0) IADZ = 0 CALL DELSTR(INTSTR,IE+1,LNSTR-IE) IF(IP.GT.0) CALL DELSTR(INTSTR,IP,1) IF(NFRAC.GT.MOVD) CALL ADDSTR(INTSTR,IP+MOVD,'.') INTMST='0000000000' IF(MOVD.GT.NFRAC) *CALL ADDSTR(INTSTR,LENSTR(INTSTR)+1,INTMST(:IADZ)) IF(IPCNT.GT.0) CALL ADDSTR(INTSTR,LENSTR(INTSTR)+1,'%') LNSTR=LENSTR(INTSTR)+1 230 CONTINUE C If delimiter is a blank then look for uncertainty, units, or units-uncerta IF(IDELIM.EQ.1) GO TO 300 C Done, cleanup and return. GO TO 800 C C LOOK FOR A NUMBER TERMINATED BY AN "A", "B" OR "G" C 250 CONTINUE C If the number is not followed by an 'A', 'B', or 'G' then remove C the LNMST characters added to INTSTR and lower case all but the C first character and the delimiter. IF(INTMST(1:1).NE.'A'.AND.INTMST(1:2).NE.'B '.AND.INTMST(1:1).NE. 1'G') GO TO 600 IPOS = LNSTR - 1 CALL STRLC(INTSTR,IPOS,1) CALL ADDSTR(INTSTR,IPOS,'|') LNSTR=LENSTR(INTSTR) C Done, cleanup and return. GO TO 800 C C LOOK FOR REST OF NUMBER PER EXTENDED DEFINITION C 300 CONTINUE C If the number (including some special characters at the end) is C followed by anything but a blank then it can't be followed by units or C uncertainty. C If not a blank then go check for Nilsson band format. IF(IDELIM.NE.1) GO TO 500 C ALLOW AT MOST TWO BLANKS BETWEEN A VALUE AND ITS UNCERTAINTY NMBLK =1 305 CONTINUE CALL WORD(INPUT,IBEG+NC,0,INTMST,JDELIM) LNMST=LENSTR(INTMST) IF(JDELIM.EQ.1) LNMST=LNMST+1 C If no more input characters (JDELIM=0) then we are done, C cleanup and return. IF(JDELIM.EQ.0) GO TO 800 IF(JDELIM.EQ.1.AND.INTMST(1:1).EQ.' ') THEN LNSTR=LNSTR+1 NC = NC + 1 NMBLK = NMBLK + 1 IF(NMBLK.GT.2) GO TO 310 GO TO 305 ENDIF 310 IKEEP = 0 C If the first character in the 'word' is a number, then it may be C an uncertainty. IF(INTMST(1:1).GE.'0'.AND.INTMST(1:1).LE.'9') GO TO 350 C If the first character in the 'word' is a '+', then it may be C the beginning of an asymmetric uncertainty. IF(INTMST(1:1).EQ.'+') GO TO 360 C C SEE IF NUMBER FOLLOWED BY A RECOGNIZABLE UNIT C NL = LNMST-1 C If the 'word' length minus the delimiter is less than 1 or greater C than 5 it can't be a legal unit so we are done; cleanup and return. IF(NL.LT.1.OR.NL.GT.5) GO TO 800 C UNIT CANNOT BE B- OR B+ C If number followed by B- or B+ then we are done, cleanup and return. IF(INTMST(1:LNMST).EQ.'B-'.OR.INTMST(1:LNMST).EQ.'B+') GO TO 800 UNIT=INTMST(1:NL) DO 320 N=1,NUNITS IF(UNIT.EQ.UNITS(N)) GO TO 330 320 CONTINUE C Done, cleanup and return. GO TO 800 C C VALID UNIT SO GET CONVERSION AND ADD IT TO OUTPUT STRING C 330 NC = NC + LNMST IDELIM = JDELIM IKEEP = 1 IDELC = INTMST(LNMST:LNMST) INTMST=CUNITS(N) INTSTR(LNSTR+1:)=INTMST LNSTR=LENSTR(INTSTR) C IS THE DELIMITER A '-', if so go look for other units but lose '-'. ????? IF(IDELIM.EQ.8) GO TO 305 LNSTR=LNSTR+1 INTSTR(LNSTR:) = IDELC C IS THE DELIMITER A '/', if so go look for other units. IF(IDELIM.EQ.13) GO TO 305 C If units not followed by a blank then there is no uncertainty following C and we are done, just make sure units are not seperated from value by line C breaks. IF(IDELIM.NE.1) GO TO 450 C C SEE IF AN UNCERTAINTY C C ALLOW AT MOST TWO BLANKS BETWEEN A VALUE AND ITS UNCERTAINTY NMBLK =1 !WE ALREADY HAVE ONE BLANK IN INTSTR SINCE IDELIM=1 TO GE HERE 341 CONTINUE CALL WORD(INPUT,IBEG+NC,0,INTMST,JDELIM) LNMST=LENSTR(INTMST) IF(JDELIM.EQ.1) LNMST=LNMST+1 C If no more characters then we are done, just make sure units are C not seperated from value by line breaks. IF(JDELIM.EQ.0) GO TO 450 IF(JDELIM.EQ.1.AND.INTMST(1:1).EQ.' ') THEN LNSTR=LNSTR+1 NC = NC + 1 NMBLK = NMBLK + 1 C If more than two blanks following units then we are done, just make C sure units are not seperated from value by line breaks. IF(NMBLK.GT.2) GO TO 450 GO TO 341 ENDIF C If the first character in the 'word' is a number, then it may be C an uncertainty. IF(INTMST(1:1).GE.'0'.AND.INTMST(1:1).LE.'9') GO TO 350 C If the first character in the 'word' is a '+', then it may be C the beginning of an asymmetric uncertainty. IF(INTMST(1:1).EQ.'+') GO TO 360 C Make sure units aren't seperated from value by line breaks. GO TO 450 C LOOK FOR A SYMMETRIC UNCERTAINTY 350 CONTINUE C HAVE FOUND A CHARACTER STRING FOLLOWING A NUMBER WHICH BEGINS WITH A # C NOTE: LNMST IS THE LOCATION IN INTMST WHERE THE DELIMITER IS LOCATED. NL = LNMST-1 DO 355 N=1,NL NCHAR=INTMST(N:N) C IF ALL THE CHARACTER AREN'T NUMERIC THEN THIS IS NOT A SYMMETRIC UNC IF(N.EQ.NL.AND.(NCHAR.LT.'A'.OR.NCHAR.GT.'Z')) THEN IF(NCHAR.LT.'0'.AND.NCHAR.GT.'9') LNMST=NL GO TO 355 ENDIF IF(INTMST(N:N).LT.'0'.OR.INTMST(N:N).GT.'9') GO TO 450 355 CONTINUE IF(IADZ.GT.0) THEN CALL ADDSTR(INTMST,LNMST,ZEROS(:IADZ)) ENDIF NC=NC+LNMST IDELIM=JDELIM C GO AND ITALISIZE THE UNCERTAINTY GO TO 410 C C LOOK FOR AN ASYMMETRIC UNCERTAINTY C 360 CONTINUE C FIRST CHARACTER IS '+', IT COULD BE AN ASYMMETRIC UNCERTAINTY IMINUS = 0 LNMST = 1 C INTMST ALREADY HAS A '+' AS THE FIRST CHARACTER, COUNT IT AND BEGIN C CHECKING THE NEXT CHARACTERS IN THE INPUT JLO = IBEG + NC + 1 DO 380 J=JLO,ILEN NCHAR = INPUT(J:J) IF(NCHAR.GE.'0'.AND.NCHAR.LE.'9'.OR.NCHAR.EQ.'-') THEN LNMST=LNMST+1 INTMST(LNMST:LNMST)= NCHAR IF(NCHAR.EQ.'-') IMINUS=IMINUS+1 ELSE C IF WE HAVEN'T ENCOUNTERED A '-' BY THIS TIME IT'S NOT AN ASYM UNC IF(IMINUS.NE.1) GO TO 450 C ADD TERMINATING CHARACTER TO INTMST LNMST=LNMST+1 INTMST(LNMST:LNMST)= NCHAR JDELIM=3 !ASSUME A PERIOD IF(NCHAR.EQ.' ') JDELIM=1 C Add zeros to asymmetric uncertainty if necessary TWB 881118 IF(IADZ .GT. 0 .AND. INTMST(1:1) .EQ. '+' 2 .AND. INDEX(INTMST,'-') .GT. 0)THEN CALL ADDSTR(INTMST,INDEX(INTMST,'-')-1,ZEROS(1:IADZ)) CALL ADDSTR(INTMST,LENSTR(INTMST)+1,ZEROS(1:IADZ)) ENDIF NC=NC+LNMST IDELIM=JDELIM GO TO 410 ENDIF 380 CONTINUE GO TO 450 C UNCERTAINTY TO BE ITALICISED C 410 IKEEP = 1 CALL ADDSTR(INTMST,1,'{I') INTSTR(LNSTR+1:)=INTMST LNSTR=LENSTR(INTSTR) NCHAR=INTSTR(LNSTR:LNSTR) IF(NCHAR.GE.'0'.AND.NCHAR.LE.'9') LNSTR=LNSTR+1 CALL ADDSTR(INTSTR,LNSTR,'}') LNSTR=LNSTR+1 C C IF STRING CANNOT BE BROKEN, PUT IN SPECIAL CONTROL C C If we don't need to protect string from being broken the we are done; C cleanup and return. 450 IF(IKEEP.EQ.0) GO TO 800 CALL ADDSTR(INTSTR,1,'{ ') LNSTR=LNSTR+2 IF(IDELIM.NE.1) CALL ADDSTR(INTSTR,LNSTR,'}') IF(IDELIM.EQ.1) CALL ADDSTR(INTSTR,LENSTR(INTSTR)+1,'}') LNSTR=LNSTR+1 C Done, cleanup and return. GO TO 800 C C LOOK FOR NILSSON BAND FORMAT C 500 CONTINUE C If not a Nilsson band then we are done, cleanup and return. If any of the C following tests fail it is not a Nilsson band number. IF(IDELIM.NE.13.OR.LNSTR.GT.3) GO TO 800 INEXT = IBEG + NC IF(INPUT(INEXT+5:INEXT+5).NE.')') GO TO 800 IF(INPUT(INEXT:INEXT).NE.'2') GO TO 800 IF(INPUT(INEXT+1:INEXT+1).NE.'(') GO TO 800 DO 525 II=2,4 ICHART = INPUT(INEXT+II:INEXT+II) IF(ICHART.LT.'0'.OR.ICHART.GT.'9') GO TO 800 525 CONTINUE C C NILSSON BAND FORMAT FOUND C NC = NC + 6 INTSTR=INPUT(IBEG:NC+IBEG-1) INTSTR(NC:NC) = ']' INTSTR(NC-4:NC-4) = '[' LNSTR=LENSTR(INTSTR) IDELIM = 7 GO TO 1000 C C LOWER CASE THE STRING C 590 LNMST=INTMP 600 LNSTR = LNSTR-LNMST NC = NC - LNMST CALL STRLC(INTSTR,2,LNSTR-1) IDELIM = 0 GO TO 1000 C C STRIP OFF ANY TRAILING "(" C 800 IF(IDELIM.NE.6) GO TO 1000 NC = NC - 1 LNSTR= LNSTR-1 C C DONE C 1000 CONTINUE INTMST=INPUT(IBEG:IBEG+NC-1) NC=LENSTR(INTMST) INTSTR(LNSTR+1:)=' ' NONBLK=LENSTR(INTSTR) C WE NOW HAVE A NEW DELIMITER CALL WORD(INTSTR(NONBLK:NONBLK),1,0,INTMST,IDELIM) IF(IDELIM.EQ.1) IDELIM=0 C TYPE *, IBEG,NC,NONBLK,LNSTR,IDELIM C TYPE *,'NUMANL OUT!',INPUT(IBEG:IBEG+NC),'=',INTSTR(:NONBLK),'!', C *IDELIM RETURN END SUBROUTINE SUPBLK(OUTPUT) C C ROUTINE TO SUPPRESS UNNECESSARY BLANKS C CHARACTER*(*) OUTPUT C INTEGER INDEXF,LENSTR EXTERNAL INDEXF,LENSTR C CHARACTER*1 ICHARP,ICHARN,ICHARA CHARACTER*9 NBLKS INTEGER I, IPRE, J, JB, JC1, JC2, JP1, JP2, LOC, N, NDO C DATA JB/9/,NBLKS/',.;:?><=|'/ DATA JC1/5/,JC2/8/,JP1/5/,JP2/8/ C C PROCESS EACH CHARACTER IN THE STRING C IPRE = 0 NDO=LENSTR(OUTPUT) DO 200 N=1,NDO ICHARA = OUTPUT(N:N) C C KEEP CHARACTER IF NOT A BLANK C IF(ICHARA.NE.' ') GO TO 150 C C KILL ALL LEADING BLANKS C IF(IPRE.EQ.0) GO TO 200 C C GET PREVIOUS AND NEXT CHARACTER AND SEE IF EITHER IS A BLANK C ICHARN = OUTPUT(N+1:N+1) IF(N.EQ.NDO) ICHARN = ' ' ICHARP = OUTPUT(IPRE:IPRE) IF(ICHARN.EQ.' '.OR.ICHARP.EQ.' ') GO TO 200 C C SEE IF NEXT CHARACTER PERMITS A BLANK BEFORE IT C DO 20 J=1,JB IF(ICHARN.EQ.NBLKS(J:J)) GO TO 30 20 CONTINUE GO TO 100 C C IF A SHIFT CHARACTER CHECK THE NEXT ONE C 30 IF(J.NE.JB) GO TO 50 ICHARN = OUTPUT(N+2:N+2) DO 40 J=JC1,JC2 IF(ICHARN.EQ.NBLKS(J:J)) GO TO 50 40 CONTINUE C809 IF(ICHARN.EQ.'+') GO TO 50 GO TO 100 C C DONT PERMIT TWO DELIMITERS NOT SEPARATED BY A BLANK C 50 DO 60 J=1,JP2 IF(ICHARP.EQ.NBLKS(J:J)) GO TO 150 60 CONTINUE IF(ICHARP.EQ.'{') GO TO 150 C C IF NEXT CHARACTER IS PUNCTUATION, REMOVE BLANK ICHARN = OUTPUT(N+1:N+1) DO 65 J=1,JP1 IF(ICHARN.EQ.NBLKS(J:J)) GO TO 200 65 CONTINUE C C IF PRECEDING WORD IS ALL LOWER CASE OUTPUT BLANK DO 70 I=IPRE,1,-1 IF(OUTPUT(I:I).EQ.' ') GO TO 80 IF(OUTPUT(I:I).LT.'a'.OR.OUTPUT(I:I).GT.'z') GO TO 71 GO TO 70 71 CONTINUE C CHECK THAT THIS IS NOT THE FIRST WORD OF A SENTENCE (WORD OF MORE THAN C ONE LETTER) IF(I-2.LE.0) GO TO 200 IF(OUTPUT(I-2:I-2).EQ.'.'.AND.I.LT.IPRE) GO TO 80 GO TO 200 70 CONTINUE I = 0 C CHECK FOR SPECIAL WORDS WHICH ARE NOT TO BE FOLLOWED BY A BLANK 80 CONTINUE LOC = I+1 IF(LOC.GT.IPRE) GO TO 150 IF(LOC.EQ.IPRE.AND.OUTPUT(LOC:LOC).EQ.'a') GO TO 200 IF(INDEXF(OUTPUT,LOC,'resolution').EQ.LOC) GO TO 200 IF(INDEXF(OUTPUT,LOC,'branching').EQ.LOC) GO TO 200 GO TO 150 C C SEE IF PRIOR CHARACTER PERMITS A FOLLOWING BLANK C 100 DO 110 J=JP1,JP2 IF(ICHARP.EQ.NBLKS(J:J)) GO TO 120 110 CONTINUE GO TO 150 C C CHECK FOR ALTERNATE "?" C 120 IF(J.NE.JP1) GO TO 200 IF(IPRE.LT.2) GO TO 150 IF(OUTPUT(IPRE-1:IPRE-1).EQ.'|') GO TO 200 C C SAVE THE CHARACTER C 150 IPRE = IPRE + 1 IF(IPRE.EQ.N) GO TO 200 OUTPUT(IPRE:IPRE) = OUTPUT(N:N) 200 CONTINUE C C RESET STRING LENGTH AND RETURN C OUTPUT=OUTPUT(1:IPRE) C RETURN END SUBROUTINE CONCHR(INPUT) CHARACTER*(*) INPUT C C ROUTINE TO CONVERT SPECIAL DELIMITERS C INTEGER LENSTR EXTERNAL LENSTR C CHARACTER*1 INCHAR,IPCHAR INTEGER N C C PROCESS EACH CHARACTER C IF(INPUT(1:1).EQ.'$') INPUT(1:1) = ';' IF(LENSTR(INPUT).LE.1) GO TO 1000 DO 200 N=2,LENSTR(INPUT) C C GET CURRENT AND PREVIOUS CHARACTER C INCHAR = INPUT(N:N) IPCHAR = INPUT(N-1:N-1) C C LOOK FOR THE DOLLAR SIGN C IF(INCHAR.NE.'$') GO TO 20 INPUT(N:N) = ';' GO TO 200 C C LOOK FOR ">=" OR "<=" C 20 IF(INCHAR.NE.'=') GO TO 30 IF(IPCHAR.EQ.'>'.OR.IPCHAR.EQ.'<') GO TO 50 GO TO 200 C C LOOK FOR "+-" C 30 IF(INCHAR.NE.'-') GO TO 100 IF(IPCHAR.NE.'+') GO TO 200 IF(N.LT.3) GO TO 50 IF(INPUT(N-2:N-2).EQ.'{') GO TO 200 C C SET ALTERNATE CHARACTER SET DEFINITION C 50 INPUT(N:N) = IPCHAR INPUT(N-1:N-1) = '|' GO TO 200 C 100 CONTINUE C LOOK FOR "<>" IF(INCHAR.NE.'>') GO TO 200 IF(IPCHAR.NE.'<') GO TO 200 INPUT(N-1:N-1)='|' INPUT(N:N)='=' 200 CONTINUE 1000 RETURN END SUBROUTINE WORD(STR,LOC,IPATH,OBJ,IDEL) CHARACTER*(*) STR,OBJ INTEGER LOC,IPATH,IDEL C C SUBROUTINE TO EXTRACT THE NEXT LOGICAL WORD STARTING AT C CHARACTER POSITION LOC OF STRING "STR". THE WORD IS STORED C IN THE STRING "OBJ" AND THE INDEX OF THE DELIMITER IN "IDEL" C INTEGER LENSTR EXTERNAL LENSTR INTEGER I, IBEG, IDELS, ILEN, ILPAR, IP, N CHARACTER*1 ICHARC,DELS*21 c Note: can't use * as break character yet. too built into dictionaries. c The second blank in list was to be *. DATA IDELS/21/,DELS/' ,.;:()-=+>