module ftopsidnt ! Identity of f90tops utility ! ____________________________________________________________________ character (len=*), parameter :: zsccs = & "@(#)ftopsidnt.f90 1.6 1.6 10/24/98 Michel Olagnon" character (len=*), parameter :: zvers = & "@(#)ftopsidnt.f90 V-1.1 10/24/98 Michel Olagnon" character (len=*), parameter :: zusg = & "( usage: f90tops < f90file > PostScript_file )" character (len=*), parameter :: zhlp = '( & &"Fortran 90 utility to pretty-print free source form code into"/& &"a PostScript file. The previously existing indentation is used,"/& &"NO indentation is performed by f90tops."/& &"_____________________________________________________________________"/& &"All rights to this code waived, so that it may be freely distributed"/& &"as public domain software subject to the condition that these 5 lines"/& &"are verbatim reproduced. Originally written by Michel Olagnon, from"/& &"Ifremer, France, who would be pleased to receive your comments and"/& &"corrections. M. Olagnon (Michel.Olagnon@ifremer.fr)"/& &"_____________________________________________________________________"/& &" version 1.1 of 24 Oct 1998"/& &" Print standard input stream, containing source of several fortran90"/& &" program units into a PostScript listing file. Comments are shaded,"/& &" lines are numbered for each subprogram, and indentation is"/& &" emphasized by shaded bars in the margin."/& &"_____________________________________________________________________"/& &"Note: If you do not like code to start in column 7, remember that,"/& &" had Diophantes left a 6 characters margin, then mathematicians"/& &" might have spared much efforts on A**N = B**N + C**N ..."/& &" My margin is wide to let you put your corrections there."/& &"____________________________________________________________________")' ! end module ftopsidnt module splitprms ! Parameters for f90split utility ! ____________________________________________________________________ character (len=26), parameter :: zlwc="abcdefghijklmnopqrstuvwxyz" character (len=26), parameter :: zupc="ABCDEFGHIJKLMNOPQRSTUVWXYZ" character (len=10), parameter :: zdgt="1234567890" character (len=1), parameter :: ztab=char(9) integer, parameter :: lend = 3 character (len=lend), parameter :: zend = "END" integer, parameter :: lctn = 8 character (len=lctn), parameter :: zctn = "CONTAINS" integer, parameter :: lntf = 9 character (len=lntf), parameter :: zntf = "INTERFACE" integer, parameter :: lsub = 10 character (len=lsub), parameter :: zsub = "SUBROUTINE" integer, parameter :: lpgm = 7 character (len=lpgm), parameter :: zpgm = "PROGRAM" integer, parameter :: lmdl = 6 character (len=lmdl), parameter :: zmdl = "MODULE" integer, parameter :: lfun = 8 character (len=lfun), parameter :: zfun = "FUNCTION" integer, parameter :: lbdt = 9 character (len=lbdt), parameter :: zbdt = "BLOCKDATA" integer, parameter :: lbdt1 = 5 character (len=lbdt1), parameter :: zbdt1 = "BLOCK" integer, parameter :: lbdt2 = 4 character (len=lbdt2), parameter :: zbdt2 = "DATA" integer, parameter :: luse = 3 character (len=luse), parameter :: zuse = "USE" integer, parameter :: linc = 7 character (len=linc), parameter :: zinc = "INCLUDE" ! character (len=*), parameter :: zbasp = "main0000" character (len=*), parameter :: zbasb = "bdta0000" character (len=*), parameter :: zbasm = "modl0000" character (len=*), parameter :: zbasd = "dupl0000" character (len=*), parameter :: zbask = "dpds0000" character (len=*), parameter :: zfmtn = "(i4.4)" integer, parameter :: ifmts = 5 ! start pos. in names integer, parameter :: ifmte = 8 ! end pos. in names integer, parameter :: nnamm = 9999 ! number max in names integer, parameter :: klwc = -1 ! case processing: to lower integer, parameter :: kupc = 1 ! case processing: to upper integer, parameter :: klve = 0 ! case processing: leave as is integer, parameter :: kpgm = 0 ! code for main program integer, parameter :: kbdt = 1 ! code for block data integer, parameter :: ksub = 2 ! code for subroutine integer, parameter :: kfun = 3 ! code for function integer, parameter :: kmdl = 4 ! code for module integer, parameter :: kdup = 5 ! code for duplicate integer, parameter :: kdpd = 6 ! code for dependencies integer, parameter :: kend = -1 ! code for end-of-input integer, parameter :: ktabn = 0 ! assume no TABs integer, parameter :: ktabi = 1 ! accept TABs, no expand integer, parameter :: ktabe = 2 ! expand TABs integer, parameter :: nplam = 3 ! # of plans to expand TABs integer, parameter :: luerr = 0 ! logical unit for stderr integer, parameter :: lutmp = 2 ! logical unit for temp. file integer, parameter :: lufil = 3 ! logical unit for final file integer, parameter :: luinp = 5 ! logical unit for stdin integer, parameter :: ludpd = 7 ! logical unit for depend file integer, parameter :: lnamm = 31 ! max. variable name length integer, parameter :: lfilm = 64 ! max. file name length integer, parameter :: ncntm = 39 ! max. # cont. lines integer, parameter :: linem = 132 ! max. line length integer, parameter :: lsttm = (linem-1)*ncntm+linem ! max. sttmt. length integer, parameter :: ndepm = 100 ! max use/include deps ! The following declaration is technically non-standard in Fortran90: ! (the "max" function is not required to be accepted in a parameter ! statement) to fix this, I added a contained routine, called at the ! beginning of the main program. ! integer, parameter, dimension (linem, nplam) :: nxttab = & ! reshape ( & ! (/ max( (/ (6+3*((i-6+3)/3), i= 1,linem), & ! (6+2*((i-6+2)/2), i= 1,linem) /), & ! (/ (6, i= 1, 2*linem) /) ), & ! (/ (i, i= 1,linem) /) /),& ! (/ linem, nplam /) ) integer, dimension (linem, nplam) :: nxttab = & reshape ( & (/ (/ (6+3*((i-6+3)/3), i= 1,linem) /), & (/ (6+2*((i-6+2)/2), i= 1,linem) /), & (/ (i, i= 1,linem) /) /), & (/ linem, nplam /) ) contains subroutine maxnxt nxttab(:,1:2) = max(6,nxttab(:,1:2)) end subroutine maxnxt end module splitprms module splitdefs ! Default settings for f90split utility use splitprms ! ____________________________________________________________________ character (len=*), parameter :: zsuff = ".f90" character (len=*), parameter :: zsufk = ".mk" character (len=*), parameter :: zsufm = ".mod" character (len=*), parameter :: zsufo = ".o" integer :: ktab = ktabe integer :: kcas = klve ! code for case processing integer :: kmkd = 1 ! code for making dependencies end module splitdefs module splitcurs use splitprms ! Current status variables in f90split utility ! ____________________________________________________________________ integer, save :: nlini = 0 ! Lines input integer, save :: nlins = 0 ! in current sub-unit integer, save :: iplac = 1 ! plan for TAB expansion integer, save :: mlins = 0 ! max line length integer, save :: ndep = 0 ! number of use/includes deps integer, save :: iflina = 0 ! advance line is multiple integer, save :: llina = -1 ! length of advance stored line character (len=linem) :: zlina ! line in advance character (len=lfilm), dimension (ndepm) :: zdept ! current dependencies end module splitcurs module ftopsprms ! Parameters for f90ftops utility ! ____________________________________________________________________ use splitprms integer, parameter :: jyhom = 750 ! home point ordinate ! use 750 for A4, 680 for B4 integer, parameter :: jxhom = 40 ! home point abscissa integer, parameter :: jxwdt = 520 ! horizontal width integer, parameter :: llins = 100 ! length of a "short" line integer, parameter :: llinl = linem ! length of a normal line integer, parameter :: jfntl = 9 ! large font integer, parameter :: nlnpl = (jyhom - 40) / (jfntl + 2) ! number of lines / page integer, parameter :: jfnts = 6 ! small font integer, parameter :: nlnps = (jyhom - 40) / (jfnts + 2) ! number of lines / page integer, parameter :: nndtm = 12 ! max indent level character (len=1), parameter :: zbksl = achar (92) ! Backslash end module ftopsprms module ftopsdefs ! Default settings for f90ftops utility use ftopsprms ! ____________________________________________________________________ integer :: ktab = ktabe end module ftopsdefs module ftopscurs ! Current status variables in f90ftops utility ! ____________________________________________________________________ use splitcurs use ftopsprms integer, save, dimension (nndtm) :: jndtt ! indent levels integer, save :: npagt=0 ! total # pages end module ftopscurs program f90tops ! Print standard input stream, containing source of several fortran90 ! program units into a PostScript listing file. Comments are shaded, ! lines are numbered for each subprogram, and indentation is ! emphasized by shaded bars in the margin. ! ____________________________________________________________________ use ftopsidnt use ftopsdefs use ftopscurs ! ____________________________________________________________________ ! character (len=lnamm) :: znam ! write (luerr, "(a)") "This is f90ftops: " // zvers write (luerr, "(a)") zusg body: do ! ! Open temporary output file ! open (lutmp, status='scratch', iostat=kerr) if (kerr /= 0) then write (luerr,*) "Unable to open scratch file" exit body endif ! do nlins = 0 mlins = 0 if (ktab == ktabe) iplac = 1 ! ! Find type and name of unit ! call fndfst (kunt, znam, kerr) if (kerr /= 0) then ! ! Write Postscript trailer ! if (nlini /= 0) call wrttrl (npagt) exit body endif ! ! Find end of current program unit ! if (kunt /= kend) then call fndend (kerr) endif if (kerr /= 0) then write (luerr,*) trim (znam), " : Missing END statement" endif rewind lutmp ! ! Translate scratch file to PostScript ! call wrtfil (kunt, znam, kerr) if (kerr /= 0) then exit body endif ! ! Loop to next program unit ! if (kunt == kend) then exit endif rewind lutmp enddo enddo body close (lutmp) end program f90tops subroutine fndfst (kunt, znam, kerr) ! Read input file, copying it to the scratch file, until the first ! non-comment statement is found. ! Analyse this statement, and decide of the type and name of the ! program unit that starts there. use splitprms use splitcurs integer, intent (out) :: kunt ! type of program unit character (len=*), intent (out) :: znam ! name chosen integer, intent (out) :: kerr ! error code ! ____________________________________________________________________ character (len=lsttm) :: zstt ! call nxtstt (zstt, ksta) if (ksta == 0) then call nlzfst (zstt, kunt, znam) elseif (ksta < 0) then if (nlins > 0) then kunt = kend else kunt = kpgm endif kerr = -1 else kunt = kpgm znam = ' ' kerr = ksta endif end subroutine fndfst subroutine fndend (kerr) ! Read input file, copying it to the scratch file, until an ! END statement is found. use splitdefs integer, intent (out) :: kerr ! error code ! ____________________________________________________________________ character (len=lsttm) :: zstt character (len=lnamm) :: znam integer, save :: jlvl = 0 integer, save :: jntf = 0 ! ifnew = 0 do ! ! Get next statement ! call nxtstt (zstt, ksta) if (ksta /= 0) then kerr = 1 exit endif ! ! Look for END of sub-unit or of INTERFACE ! call nlzlst (zstt, klst) select case (klst) case (-1)! problem kerr = 1 exit case (0) ! not end of anything continue case (1) ! end of sub-unit if (jlvl <= 0 .and. jntf == 0) then kerr = 0 exit endif if (jlvl > 0) jlvl = jlvl - 1 ifnew = 1 cycle case (2) ! end of interface if (jntf <= 0) then write (luerr, *) "END INTERFACE out of place" else jntf = jntf - 1 endif ifnew = 0 cycle end select ! ! Look for INTERFACE statement ! call fndntf (zstt, ifntf) if (ifntf /= 0) then jntf = jntf + 1 ifnew = 1 cycle endif ! ! Look for CONTAINS statement ! call fndctn (zstt, ifctn) if (ifctn /= 0) then ifnew = 1 cycle endif ! ! Look for start of new unit ! if (ifnew /= 0) then call nlzfst (zstt, kunt, znam) if (kunt == ksub .or. kunt == kfun) then jlvl = jlvl + 1 ifnew = 0 cycle endif endif enddo end subroutine fndend subroutine nxtstt (zstt, ksta) ! Get (possibly multiple) non-comment statement and extract ! single statement out of it use splitcurs character (len=lsttm), intent (out) :: zstt integer, intent (out) :: ksta ! status code ! ____________________________________________________________________ character (len=1) :: zdlm character (len=lsttm), save :: zmul integer, save :: istt = 0 integer, save :: istts integer, save :: lmul ! ksta = 0 body: do if (istt == 0) then ! ! Get a (possibly multiple) non-comment statement ! call reastt (zmul, lmul, kget) ! if (kget /= 0) then ksta = kget istt = 0 exit body else istt = 1 endif endif ! ! Look for character context ! ifchc1 = 0 iloo = istt lstt = lmul do ! ! Outside of character context, truncate at ; if any ! if (ifchc1 == 0) then ichc0 = scan (zmul (iloo:lstt), "'"//'"') if (ichc0 == 0) then ismc = index (zmul (iloo:lstt), ';') else ismc = index (zmul (iloo:ichc0), ';') endif if (ismc > 0) then lstt = iloo + ismc - 2 exit elseif (ichc0 > 0) then ifchc1 = 1 iloo = iloo + ichc0 zdlm = zmul (iloo-1:iloo-1) else exit endif else ! ! Within character context, look for its termination ! ichc1 = scan (zmul (iloo:lstt), zdlm) if (ichc1 == 0) then exit else ifchc1 = 0 iloo = iloo + ichc1 endif endif enddo ! ! Copy current statement into zstt ! if (istts > 0) then zstt = repeat (" ", istts) // zmul (istt:lstt) else zstt = zmul (istt:lstt) endif if (istt == 1 .and. lstt == lmul) then iflina = 0 else iflina = 1 endif if (istts == 0 .and. lstt < lmul) then istts = verify (zmul (1:lmul), ' ') - 1 elseif (lstt == lmul) then istts = 0 endif if (lstt+1 < lmul) then istt = lstt + verify (zmul (lstt+2:lmul), ' ') + 1 else istt = 0 endif if (len_trim (zstt) > 0) then exit body endif enddo body end subroutine nxtstt subroutine reastt (zmul, lstt, ksta) ! Read input file, copying it to the scratch file, until a ! (possibly multiple) non-comment statement is found. use splitdefs use splitcurs character (len=lsttm), intent (out) :: zmul integer, intent (out) :: lstt ! istt. length integer, intent (out) :: ksta ! status code ! ____________________________________________________________________ character (len=linem) :: zlin character (len=1) :: zdlm ! lstt = 0 ifchc0 = 0 ifcnt0 = 0 do ! ! Something to write ? ! Write advance line to scratch file ! if (llina > 0) then write (lutmp, "(a)", iostat=kwri) zlina (1:llina) if (kwri /= 0) then write (luerr,*) "Problem writing scratch file" ksta = 2 exit endif elseif (llina == 0) then write (lutmp, "()", iostat=kwri) if (kwri /= 0) then write (luerr,*) "Problem writing scratch file" ksta = 2 exit endif endif ! ! Read a line ! read (luinp, "(a)", iostat=krea) zlin ! select case (krea) case (1:) ksta = 1 llina = -1 write (luerr,*) "Problem reading input" exit case (:-1) ksta = -1 llina = -1 exit case (0) ksta = 0 nlini = nlini + 1 nlins = nlins + 1 llin = len_trim (zlin) llina = llin if (llin <= 0) cycle zlina (1:llina) = zlin (1:llin) ! ! process TABs ! select case (ktab) case (ktabi) call rmvtab (zlin, llin) mlins = max (mlins, llin) case (ktabn) mlins = max (mlins, llin) case (ktabe) call chktab (zlin, llin) call rmvtab (zlin, llin) endselect ! ! Recognize and skip comments ! ifst = verify (zlin (1:llin), ' ') if (ifst == 0) cycle if (zlin (ifst:ifst) == '!') cycle ! ! Recognize and skip pre-processing commands ! if (zlin (ifst:ifst) == '$') cycle if (zlin (ifst:ifst) == '#') cycle ! ! Do not explore trailing comments if any ! ! Look for character context ! ifchc1 = ifchc0 iloo = ifst lxpl = llin do ! ! Outside of character context, truncate at ! if any ! if (ifchc1 == 0) then ichc0 = scan (zlin (iloo:llin), "'"//'"') if (ichc0 == 0) then icmt = index (zlin (iloo:llin), '!') else icmt = index (zlin (iloo:ichc0), '!') endif if (icmt > 0) then ltmp = iloo + icmt - 2 lxpl = len_trim (zlin (1:ltmp)) exit elseif (ichc0 > 0) then ifchc1 = 1 iloo = iloo + ichc0 zdlm = zlin (iloo-1:iloo-1) else exit endif else ! ! Within character context, look for its termination ! ichc1 = scan (zlin (iloo:llin), zdlm) if (ichc1 == 0) then exit else ifchc1 = 0 iloo = iloo + ichc1 endif endif enddo ! ! Look for continuation mark ! if (zlin (lxpl:lxpl) == '&') then ifcnt1 = 1 llin = len_trim (zlin (1:lxpl-1)) else ifcnt1 = 0 endif ! ! Copy current statement fragment into zmul ! ! Look for continued mark ! if (zlin (ifst:ifst) == '&') then ifst = ifst + verify (zlin (ifst+1:llin), ' ') if (ifchc0 == 0) then lstt = lstt + 1 zmul (lstt:lstt) = ' ' endif endif ! ! Copy ! if (ifst > 1) then zmul (lstt+1:lstt+ifst-1) = " " lstt = lstt + ifst - 1 endif lfrg = llin - ifst + 1 zmul (lstt+1:lstt+lfrg) = zlin (ifst:llin) lstt = lstt + lfrg if (ifcnt1 == 0) exit end select ! ! Loop until end of statement ! ifcnt0 = ifcnt1 ifchc0 = ifchc1 enddo end subroutine reastt subroutine nlzfst (zstt, kunt, znam) ! Analyse a statement, and decide of the type (and name) of the ! program unit that starts there. use splitcurs character (len=lsttm), intent (in) :: zstt ! the statement integer, intent (out) :: kunt ! type of program unit character (len=*), intent (out) :: znam ! name chosen ! ____________________________________________________________________ character (len=lsttm) :: zsttw, zsttw1 logical :: ifwrk ! body: do ! ! Raise to upper case (No label to be removed) ! zsttw = adjustl (zstt) call raicas (zsttw) ! ! Look for PROGRAM ! lstt = len_trim (zsttw) ipgm = index (zsttw (1:lstt), zpgm) if (ipgm == 1) then kunt = kpgm ikwdf = lpgm else ! ! Look for MODULE ! imdl = index (zsttw (1:lstt), zmdl) if (imdl == 1) then kunt = kmdl ikwdf = lmdl else ! ! Look for FUNCTION ! ifun = index (zsttw (1:lstt), zfun) if (ifun <= 1) then ifwrk = (ifun == 1) else ifwrk = (zsttw (ifun-1:ifun-1) == ' ') endif if (ifwrk) then kunt = kfun ikwdf = lfun + ifun - 1 else ! ! Look for SUBROUTINE ! isub = index (zsttw (1:lstt), zsub) if (isub <= 1) then ifwrk = (isub == 1) else ifwrk = (zsttw (isub-1:isub-1) == ' ') endif if (ifwrk) then kunt = ksub ikwdf = lsub + isub - 1 else ! ! Look for BLOCK DATA ! ibdt1 = index (zsttw (1:lstt), zbdt1) if (ibdt1 == 1) then ikwdf = lbdt1 & + verify (zsttw (lbdt1+1:lstt), ' ') & - 1 if (ikwdf >= lbdt1) then ibdt2 = index (zsttw (ikwdf+1:lstt), zbdt2) if (ibdt2 == 1) then kunt = kbdt ikwdf = ikwdf + lbdt2 else kunt = kpgm znam = ' ' exit body endif else kunt = kpgm znam = ' ' exit body endif else kunt = kpgm znam = ' ' exit body endif endif endif endif endif ! ! Find name ! inams = ikwdf + verify (zsttw (ikwdf+1:lstt), ' ') if (inams < ikwdf+2) then if (kunt /= kbdt) kunt = kpgm znam = ' ' exit body endif iname = inams & + verify (zsttw (inams+1:lstt+1), zupc//zdgt//"_") & - 1 if (iname < inams) then if (kunt /= kbdt) kunt = kpgm znam = ' ' exit body endif zsttw1 = adjustl (zstt) znam = zsttw1 (inams:iname) exit body enddo body kwri = 0 if (iflina /= 0 .and. llina < 0) then write (lutmp, "(a)", iostat=kwri) trim (zstt) elseif (llina >= 0) then if (iflina == 0) then write (lutmp, "(a)", iostat=kwri) zlina (1:llina) else write (lutmp, "(a)", iostat=kwri) trim (zstt) endif llina = -1 endif if (kwri /= 0) then write (luerr,*) "Problem writing scratch file" endif end subroutine nlzfst subroutine nlzlst (zstt, klst) ! Analyse a statement, and decide if the current ! program unit ends there. use splitcurs character (len=lsttm), intent (in) :: zstt ! The statement integer, intent (out) :: klst ! result ! ____________________________________________________________________ character (len=lsttm) :: zsttw ! body: do zsttw = adjustl (zstt) ! ! Remove label and raise to upper case ! call rmvlbl (zsttw) call raicas (zsttw) ! ! Look for first token, to be END ! itokf = verify (zsttw, zupc) - 1 if (itokf < lend) then klst = 0 exit body endif if (zsttw (1:lend) /= zend) then klst = 0 exit body endif ! ! Nothing after END ! lstt = len_trim (zsttw) if (lstt == lend) then klst = 1 exit body endif ! ! Look for [space] unit name ! itoks = lend + verify (zsttw (lend+1:lstt), ' ') itoke = itoks + index (zsttw (itoks+1:lstt+1), ' ') - 1 if (itoke < itoks+2) then klst = 0 exit body endif if ( (zsttw (itoks:itoke) == zpgm) & .or.(zsttw (itoks:itoke) == zsub) & .or.(zsttw (itoks:itoke) == zfun) & .or.(zsttw (itoks:itoke) == zbdt) & ! Be laxist .or.(zsttw (itoks:itoke) == zmdl) ) then klst = 1 exit body elseif (zsttw (itoks:itoke) == zntf) then klst = 2 exit body elseif (zsttw (itoks:itoke) == zbdt1) then itoks = itoke + verify (zsttw (itoke+1:lstt), ' ') if (itoks < itoke+2) then klst = 0 exit body endif itoke = itoks + index (zsttw (itoks+1:lstt+1), ' ') - 1 if (itoke < itoks+2) then klst = 0 exit body endif if (zsttw (itoks:itoke) == zbdt2) then klst = 1 exit body else klst = 0 exit body endif else klst = 0 exit body endif enddo body kwri = 0 if (iflina /= 0 .and. llina < 0) then write (lutmp, "(a)", iostat=kwri) trim (zstt) elseif (llina >= 0) then if (iflina == 0) then write (lutmp, "(a)", iostat=kwri) zlina (1:llina) else write (lutmp, "(a)", iostat=kwri) trim (zstt) endif llina = -1 endif if (kwri /= 0) then write (luerr,*) "Problem writing scratch file" klst = -1 endif end subroutine nlzlst subroutine fndctn (zstt, ifctn) use splitprms ! Look for CONTAINS statement character (len=lsttm), intent (in) :: zstt ! The statement integer, intent (out) :: ifctn ! ____________________________________________________________________ ! character (len=lsttm) :: zsttw ! body: do zsttw = adjustl (zstt) ! ! Remove label and raise to upper case ! call rmvlbl (zsttw) call raicas (zsttw) ! ! Look for first token, to be CONTAINS ! itokf = verify (zsttw, zupc) - 1 if (itokf /= lctn) then ifctn = 0 exit body endif if (zsttw (1:lctn) /= zctn) then ifctn = 0 exit body endif ! ! Nothing after CONTAINS ! lstt = len_trim (zsttw) if (lstt == lctn .and. zsttw (1:lctn) == zctn) then ifctn = 1 exit body else ifctn = 0 exit body endif enddo body end subroutine fndctn subroutine fndntf (zstt, ifntf) use splitprms ! Look for INTERFACE statement character (len=lsttm), intent (in) :: zstt ! The statement integer, intent (out) :: ifntf ! ____________________________________________________________________ ! character (len=lsttm) :: zsttw ! body: do zsttw = adjustl (zstt) ! ! Remove label and raise to upper case ! call rmvlbl (zsttw) call raicas (zsttw) ! ! Look for first token, to be INTERFACE ! itokf = verify (zsttw, zupc) - 1 if (itokf /= lntf) then ifntf = 0 exit body endif if (zsttw (1:lntf) /= zntf) then ifntf = 0 exit body endif ! ! Nothing after INTERFACE ! lstt = len_trim (zsttw) if (lstt == lntf .and. zsttw (1:lntf) == zntf) then ifntf = 1 exit body elseif (lstt > lntf .and. zsttw (1:lntf) == zntf) then if (zsttw (lntf+1:lntf+1) == ' ') then ifntf = 1 exit body else ifntf = 0 exit body endif else ifntf = 0 exit body endif enddo body end subroutine fndntf subroutine raicas (zstr) ! Raise a string to upper case use splitprms character (len=*), intent (inout) :: zstr ! The string logical :: toggle character(len=1) :: togglechar ! ____________________________________________________________________ ! ! Modified to not do upper case to embedded strings (pgg 21.11.94) toggle = .TRUE. lstr = len_trim (zstr) do istr = 1, lstr if (toggle) then if(zstr (istr:istr) == '"' .or. zstr (istr:istr) == "'") then toggle = .not. toggle togglechar = zstr (istr:istr) end if irnk = index (zlwc, zstr (istr:istr)) if (irnk > 0) then zstr (istr:istr) = zupc (irnk:irnk) endif else if(zstr (istr:istr) == togglechar) toggle = .not. toggle endif enddo end subroutine raicas subroutine lwrcas (zstr) ! Lower a string to lower case use splitprms character (len=*), intent (inout) :: zstr ! The string ! ____________________________________________________________________ ! lstr = len_trim (zstr) do istr = 1, lstr irnk = index (zupc, zstr (istr:istr)) if (irnk > 0) then zstr (istr:istr) = zlwc (irnk:irnk) endif enddo end subroutine lwrcas subroutine rmvlbl (zstt) ! Remove statement label (Note: Label /= Construct name) use splitprms character (len=lsttm), intent (inout) :: zstt ! The statement ! ____________________________________________________________________ ! if (index (zdgt, zstt (1:1)) > 0) then istt = verify (zstt, zdgt//' ') zstt = zstt (istt:lsttm) endif end subroutine rmvlbl subroutine rmvtab (zstr, lstr) ! Remove TABs and replace with spaces use splitprms character (len=lstr), intent (inout) :: zstr ! The string integer, intent (inout) :: lstr ! its trimmed length ! ____________________________________________________________________ ! lsrc = lstr do ! ! Search backwards so that trailing TABs eliminated first ! lsrc = index (zstr (1:lsrc), ztab, back=.true.) if (lsrc == 0) then exit endif zstr (lsrc:lsrc) = ' ' lsrc = lsrc - 1 enddo lstr = len_trim (zstr) end subroutine rmvtab subroutine chktab (zstr, lstr) ! Verify and possibly update current TAB expansion plan use splitdefs use splitcurs character (len=*), intent (inout) :: zstr ! The string integer, intent (inout) :: lstr ! its trimmed length ! ____________________________________________________________________ ! lexp = lstr ! ! Quick return when possible ! body: do if (iplac == nplam) exit body if (index (zstr (1:lstr), ztab) == 0) exit body if (verify (zstr (1:lstr), ztab//' ') == 0) then lexp = 0 lstr = 0 exit body endif ! ! Loop on expansion plans ! do istr = 1 lexp = 0 call expand ! ! Check if line fits with current plan ! if (lexp > linem) then iplac = iplac + 1 if (iplac < nplam) cycle lexp = lstr endif exit body enddo enddo body mlins = max (lexp, mlins) contains subroutine expand ! ! Expand each TAB on to next tab mark ! do if (lstr >= istr) then iwrk = index (zstr (istr:lstr), ztab) else exit endif if (iwrk /= 0) then lexp = lexp + iwrk - 1 istr = istr + iwrk ! ! Expand TAB on to next tab mark ! iexp = lexp + 1 lfil = min (iexp, linem) lexp = nxttab (lfil, iplac) ! ! Fill-up with spaces ! else exit endif enddo lexp = lexp + lstr - istr + 1 end subroutine expand end subroutine chktab subroutine xpdtab (zstr, lstr) ! Expand line using current TAB expansion plan use splitdefs use splitcurs character (len=lstr), intent (inout) :: zstr ! The line integer, intent (inout) :: lstr ! its trimmed length ! ____________________________________________________________________ ! character (len=linem) :: zlinw ! work string ! ! Quick return when possible ! if (iplac == nplam) then call rmvtab (zstr, lstr) return endif iwrk = index (zstr (1:lstr), ztab) if (iwrk == 0) return if (verify (zstr (1:lstr), ztab//' ') == 0) then lstr = 0 return endif ! istr = 1 lexp = 0 zlinw = zstr ! ! Removing TABs ! do if (iwrk /= 0) then lexp = lexp + iwrk - 1 istr = istr + iwrk ! ! Expand TAB on to next tab mark ! iexp = lexp + 1 lfil = min (iexp, linem) lexp = nxttab (lfil, iplac) ! ! Fill-up with spaces ! if (iexp <= lexp) then zlinw (iexp:lexp) = repeat (" ", lexp - iexp + 1) endif zlinw (lexp+1:linem) = zstr (istr:lstr) if (lstr >= istr) then iwrk = index (zstr (istr:lstr), ztab) else iwrk = 0 endif else exit endif enddo ! lstr = len_trim (zlinw) zstr (1:lstr) = zlinw (1:lstr) ! end subroutine xpdtab subroutine wrtfil (kunt, znam, kerr) ! Translate scratch file to PostScript use ftopsdefs use ftopscurs integer, intent (in) :: kunt ! unit type character (len=lnamm), intent (in) :: znam ! unit name integer, intent (out) :: kerr ! error code ! ____________________________________________________________________ integer, save :: ifdeb = 1 character (len=linem) :: zlin character (len=8) :: zdat character (len=10) :: ztim character (len=lnamm) :: zunt ! kerr = 0 ! ! Write PostScript header ! if (ifdeb == 1) then call wrthdr ifdeb = 0 endif ipag = 0 ilin = 0 ! ! Setup Page header info ! call date_and_time (date=zdat, time=ztim) select case (kunt) case default zunt = " " case (kpgm) zunt = zpgm case (kbdt) zunt = zbdt1 // " " // zbdt2 case (ksub) zunt = zsub case (kfun) zunt = zfun case (kmdl) zunt = zmdl end select if (mlins > llins) then jfnt = jfnts nlinp = nlnps else jfnt = jfntl nlinp = nlnpl endif npags = (nlins + nlinp - 1) / nlinp npagt = npagt + npags ! ! Write Page header ! ipag = ipag + 1 call wrtpgh (zunt, znam, zdat, ztim, ipag, npags, jfnt) ilinp = 0 ! body: do do read (lutmp, "(a)", iostat=krea) zlin select case (krea) case (1:) write (luerr,*) "Problem reading scratch file" kerr = 1 exit body case (:-1) exit case (0) ! if (ilinp >= nlinp) then ! Turn page call wrtpgt ipag = ipag + 1 call wrtpgh (zunt, znam, zdat, ztim, ipag, npags, jfnt) ilinp = 0 endif ! ilinp = ilinp + 1 ilin = ilin + 1 llin = len_trim (zlin) if (llin == 0) then zlin = " " llin = 1 endif if (ktab == ktabe) then call xpdtab (zlin, llin) endif ! call wrtlin (ilinp, jfnt, ilin, zlin (1:llin)) end select enddo call wrtpgt kerr = 0 exit body enddo body end subroutine wrtfil subroutine wrtlin (ilinp, jfnt, ilin, zlin) ! Write line use ftopscurs integer, intent (in) :: ilinp, jfnt, ilin character (len=*), intent (in) :: zlin ! ____________________________________________________________________ character (len=3), parameter :: zfmt = "(a)" character (len=64) :: zwrk, zwrk1, zwrk2 character (len=1), save :: zdlm integer, save :: ifchc0 = 0 integer, save :: ifcnt0 = 0 ! llin = max (len_trim (zlin), 1) ! ! Write line number ! if (jfnt == jfnts) then jypos = jyhom - (ilinp - 1) * jfnt llinc = llinl else jypos = jyhom - (ilinp - 1) * (jfnt + 2) llinc = llins endif write (zwrk1, "(i4)") jypos write (zwrk2, "(i6)") ilin zwrk = "24 " // trim (zwrk1) // " moveto (" // zwrk2 (1:6) // & ") show" write (*, zfmt) trim (zwrk) ! ! Find comments ! icmt = 0 do ifst = verify (zlin (1:llin), ' ') if (ifst == 0) then ! ! Do not shade blank lines ! return endif if (zlin (ifst:ifst) == '!') then icmt = 1 exit endif ! ! Trailing comments if any ! ! Look for character context ! iloo = ifst do ! ! Outside of character context, a ! is a comment ! if (ifchc0 == 0) then ichc0 = scan (zlin (iloo:llin), "'"//'"') if (ichc0 == 0) then icmt = index (zlin (iloo:llin), '!') else icmt = index (zlin (iloo:ichc0), '!') endif if (icmt > 0) then icmt = iloo + icmt - 1 exit elseif (ichc0 > 0) then ifchc0 = 1 iloo = iloo + ichc0 zdlm = zlin (iloo-1:iloo-1) else exit endif else ! ! Within character context, look for its termination ! ichc1 = scan (zlin (iloo:llin), zdlm) if (ichc1 == 0) then exit else ifchc0 = 0 iloo = iloo + ichc1 endif endif enddo exit enddo if (icmt > 0) then call shade (icmt - 1) endif if (icmt > ifst .or. icmt == 0) then if (ifcnt0 == 0) then call getlvl endif if (zlin (llin:llin) == '&') then ifcnt0 = 1 else ifcnt0 = 0 endif call shdndt endif ! ! Write line over shades ! zwrk = "72 " // trim (zwrk1) // " moveto" write (*, zfmt) trim (zwrk) call wrtflt (zlin, llin) return ! contains subroutine shade (ipos) ! Shade comments integer, intent (in) :: ipos ! ____________________________________________________________________ ! character (len=*), parameter :: zfmt1 = & "('W ', i4, ' mul 72 add ', i4, ' ', a)" ! if (jfnt == jfntl) then jypos1 = jypos - 3 jypos2 = jypos + 9 else jypos1 = jypos - 1 jypos2 = jypos + 5 endif ! write (*, zfmt) "newpath" write (*, zfmt1) ipos, jypos1, "moveto" write (*, zfmt1) llinc, jypos1, "lineto" write (*, zfmt1) llinc, jypos2, "lineto" write (*, zfmt1) ipos, jypos2, "lineto" write (*, zfmt) "closepath .96 setgray fill 0 setgray" ! end subroutine shade subroutine getlvl ! Find indentation level ! ____________________________________________________________________ ! ideb = verify (zlin (1:llin), ' ') ! ! Skip label ! if (index (zdgt, zlin (ideb:ideb)) > 0) then ideb = verify (zlin (ideb:llin), zdgt//' ') + ideb - 1 endif ! ! Skip bloc name ! iblk = index (zlin (ideb:llin), ':') if (iblk > 0) then if ((iblk /= index (zlin (ideb:llin), "::")) .and. & (verify (zlin (ideb:ideb+iblk-2), zdgt//zlwc//zupc) == 0)) & then ideb = iblk + 1 + ideb - 1 ideb = verify (zlin (ideb:llin), ' ') + ideb - 1 endif endif ! jdeb = ideb - 1 if (jdeb == 0) then jndtt (1) = 0 else do indt = 1, nndtm - 1 if (jdeb == jndtt (indt)) then jndtt (indt+1) = 0 exit endif if (jdeb > (jndtt (indt) + 1)) then if (jndtt (indt) == 0) then jndtt (indt) = jdeb jndtt (indt+1) = 0 exit endif endif if (jdeb < jndtt (indt)) then jndtt (indt) = 0 endif enddo endif end subroutine getlvl subroutine shdndt ! Shade indentation ! ____________________________________________________________________ ! character (len=*), parameter :: zfmt1 = & "('W ', i4, ' mul 72 add ', i4, ' ', a)" character (len=*), parameter :: zfmt2 = & "('closepath ', f3.1, ' setgray fill 0 setgray')" ! if (jndtt (1) /= 0) then if (jfnt == jfntl) then jypos1 = jypos - 3 jypos2 = jypos + 9 else jypos1 = jypos - 1 jypos2 = jypos + 5 endif nndt = 1 do indt = 2, nndtm - 1 if (jndtt (indt) == 0) then exit else nndt = nndt + 1 endif enddo ifin = 0; kgrs = nndtm - 2 - nndt xgrs = max (real (kgrs) / 10.0, 0.0) do indt = 1, nndt ideb = ifin ifin = ifin + 1 write (*, zfmt) "newpath" write (*, zfmt1) ideb, jypos1, "moveto" write (*, zfmt1) ifin, jypos1, "lineto" write (*, zfmt1) ifin, jypos2, "lineto" write (*, zfmt1) ideb, jypos2, "lineto" write (*, zfmt2) xgrs xgrs = xgrs + 0.1 enddo endif end subroutine shdndt end subroutine wrtlin subroutine wrtpgh (zunt, znam, zdat, ztim, ipag, npags, jfnt) use ftopsprms ! Write Page header character (len=*), intent (in) :: zunt ! unit type character (len=*), intent (in) :: znam ! unit name character (len=8), intent (in) :: zdat ! date character (len=10), intent (in) :: ztim ! time integer, intent (in) :: ipag ! page nr integer, intent (in) :: npags ! nr of pages integer, intent (in) :: jfnt ! font size ! ____________________________________________________________________ character (len=*), parameter :: zfmt = "(a)" character (len=*), parameter :: zfmt1 = "(2(i3,1x),a)" character (len=64) :: zwrk, zwrk1, zwrk2 ! write (*, zfmt) "newpath" write (*, zfmt1) jxhom, jyhom + 70, "moveto" write (*, zfmt1) jxhom, jyhom + 20, "lineto" write (*, zfmt1) jxhom + jxwdt, jyhom + 20, "lineto" write (*, zfmt1) jxhom + jxwdt, jyhom + 70, "lineto" write (*, zfmt) "closepath 2 setlinewidth stroke" write (*, zfmt) "newpath" write (*, zfmt1) jxhom + 410, jyhom + 70, "moveto" write (*, zfmt1) jxhom + 410, jyhom + 20, "lineto" write (*, zfmt) "closepath .5 setlinewidth stroke" write (*, zfmt) "newpath" write (*, zfmt1) jxhom, jyhom + 40, "moveto" write (*, zfmt1) jxhom + 410, jyhom + 40, "lineto" write (*, zfmt) "closepath .5 setlinewidth stroke" write (*, zfmt) "/Helvetica-Bold findfont 12 scalefont setfont" write (*, zfmt1) jxhom + 20, jyhom + 50, "moveto" zwrk = "(" // trim (zunt) // " " // trim (znam) // ") show" write (*, zfmt) trim (zwrk) write (*, zfmt) "/Helvetica-Bold findfont 10 scalefont setfont" write (*, zfmt1) jxhom + 430, jyhom + 40, "moveto" write (zwrk1, "(i9)") ipag write (zwrk2, "(i9)") npags zwrk = "(page " // trim (adjustl (zwrk1)) // " / " // & trim (adjustl (zwrk2)) // ") show" write (*, zfmt) trim (zwrk) write (*, zfmt1) jxhom + 20, jyhom + 25, "moveto" zwrk = "(" // zdat (1:4) // "/" // zdat (5:6) // "/" // & zdat (7:8) // " " // ztim (1:2) // ":" // & ztim (3:4) // ") show" write (*, zfmt) trim (zwrk) write (zwrk1, "(i9)") jfnt zwrk = "/Courier-Bold-A findfont " // trim (adjustl (zwrk1)) //& " scalefont setfont" write (*, zfmt) trim (zwrk) write (*, zfmt) "/W {(c) stringwidth pop} bind def" end subroutine wrtpgh subroutine wrtpgt ! Write page trailer ! ____________________________________________________________________ character (len=3), parameter :: zfmt = "(a)" ! write (*, zfmt)"showpage" write (*, zfmt)"%%End Page" ! end subroutine wrtpgt subroutine wrthdr use ftopsprms ! Write PostScript header ! ____________________________________________________________________ character (len=*), parameter :: zfmt = "(a)" character (len=*), parameter :: zfmt1 = "(a, 4(1x,i3))" ! write (*, zfmt)"%!PS-ADOBE" write (*, zfmt)"%%Creator: f90tops" write (*, zfmt)"%%Pages: (atend)" write (*, zfmt)"%%PageOrder: Ascend" write (*, zfmt1)"%%BoundingBox:", 0, 0, jxhom+jxwdt+20, jyhom+75 write (*, zfmt)"%%EndComments" write (*, zfmt)"/reencsmalldict 12 dict def" write (*, zfmt)"/ReEncodeSmall" write (*, zfmt)" {reencsmalldict begin" write (*, zfmt)" /newcodesandnames exch def" write (*, zfmt)" /newfontname exch def" write (*, zfmt)" /basefontname exch def" write (*, zfmt)" /basefontdict basefontname findfont def" write (*, zfmt)" /newfont basefontdict maxlength dict def" write (*, zfmt)" basefontdict" write (*, zfmt)" { exch dup /FID ne" write (*, zfmt)" {dup /Encoding eq" write (*, zfmt)" {exch dup length array copy" write (*, zfmt)" newfont 3 1 roll put }" write (*, zfmt)" {exch newfont 3 1 roll put }" write (*, zfmt)" ifelse" write (*, zfmt)" }" write (*, zfmt)" {pop pop}" write (*, zfmt)" ifelse" write (*, zfmt)" } forall" write (*, zfmt)" newfont /FontName newfontname put" write (*, zfmt)" newcodesandnames aload pop" write (*, zfmt)" newcodesandnames length 2 idiv" write (*, zfmt)" {newfont /Encoding get 3 1 roll put}" write (*, zfmt)" repeat" write (*, zfmt)" newfontname newfont definefont pop" write (*, zfmt)" end" write (*, zfmt)" } def" write (*, zfmt)"/accentvec [" write (*, zfmt)"8#254 /logicalnot" write (*, zfmt)"8#257 /macron" write (*, zfmt)"8#260 /ring" write (*, zfmt)"8#341 /aacute" write (*, zfmt)"8#342 /acircumflex" write (*, zfmt)"8#344 /adieresis" write (*, zfmt)"8#340 /agrave" write (*, zfmt)"8#345 /aring" write (*, zfmt)"8#343 /atilde" write (*, zfmt)"8#346 /ae" write (*, zfmt)"8#347 /ccedilla" write (*, zfmt)"8#351 /eacute" write (*, zfmt)"8#352 /ecircumflex" write (*, zfmt)"8#353 /edieresis" write (*, zfmt)"8#350 /egrave" write (*, zfmt)"8#355 /iacute" write (*, zfmt)"8#356 /icircumflex" write (*, zfmt)"8#357 /idieresis" write (*, zfmt)"8#354 /igrave" write (*, zfmt)"8#361 /ntilde" write (*, zfmt)"8#363 /oacute" write (*, zfmt)"8#364 /ocircumflex" write (*, zfmt)"8#366 /odieresis" write (*, zfmt)"8#362 /ograve" write (*, zfmt)"8#365 /otilde" write (*, zfmt)"8#370 /oslash" write (*, zfmt)"8#372 /uacute" write (*, zfmt)"8#373 /ucircumflex" write (*, zfmt)"8#374 /udieresis" write (*, zfmt)"8#371 /ugrave" write (*, zfmt)"8#377 /ydieresis" write (*, zfmt)"8#301 /Aacute" write (*, zfmt)"8#302 /Acircumflex" write (*, zfmt)"8#304 /Adieresis" write (*, zfmt)"8#300 /Agrave" write (*, zfmt)"8#305 /Aring" write (*, zfmt)"8#303 /Atilde" write (*, zfmt)"8#306 /AE" write (*, zfmt)"8#307 /Ccedilla" write (*, zfmt)"8#311 /Eacute" write (*, zfmt)"8#312 /Ecircumflex" write (*, zfmt)"8#313 /Edieresis" write (*, zfmt)"8#310 /Egrave" write (*, zfmt)"8#315 /Iacute" write (*, zfmt)"8#316 /Icircumflex" write (*, zfmt)"8#317 /Idieresis" write (*, zfmt)"8#314 /Igrave" write (*, zfmt)"8#321 /Ntilde" write (*, zfmt)"8#323 /Oacute" write (*, zfmt)"8#324 /Ocircumflex" write (*, zfmt)"8#326 /Odieresis" write (*, zfmt)"8#322 /Ograve" write (*, zfmt)"8#325 /Otilde" write (*, zfmt)"8#330 /Oslash" write (*, zfmt)"8#332 /Uacute" write (*, zfmt)"8#333 /Ucircumflex" write (*, zfmt)"8#334 /Udieresis" write (*, zfmt)"8#331 /Ugrave" write (*, zfmt)"8#335 /Ydieresis" write (*, zfmt)"8#251 /copyright" write (*, zfmt)"8#256 /registered" write (*, zfmt)"8#337 /germandbls" write (*, zfmt)" ] def" write (*, zfmt)"/Times-Roman /Times-Roman-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Times-Italic /Times-Italic-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Times-Bold /Times-Bold-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Times-BoldItalic /Times-BoldItalic-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Helvetica /Helvetica-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Helvetica-Bold /Helvetica-Bold-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Helvetica-Oblique /Helvetica-Oblique-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Helvetica-BoldOblique /Helvetica-BoldOblique-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Courier /Courier-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Courier-Bold /Courier-Bold-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Courier-Oblique /Courier-Oblique-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"/Courier-BoldOblique /Courier-BoldOblique-A accentvec" write (*, zfmt)"ReEncodeSmall" write (*, zfmt)"%%EndProlog" ! end subroutine wrthdr subroutine wrttrl (npagt) ! Write general trailer ! ____________________________________________________________________ character (len=3), parameter :: zfmt = "(a)" ! write (*, zfmt)"%%Trailer" write (*, "(a, i6)") "%%Pages: ", npagt write (*, zfmt)"%%EOF" ! end subroutine wrttrl subroutine wrtflt (zlin, llin) ! Write filtered string use ftopsprms character (len=*), intent (in) :: zlin integer, intent (in) :: llin ! ____________________________________________________________________ character (len=*), parameter :: zfmt = "('(',a,') show')" character (len=*), parameter :: zspc = zbksl // "()" character (len=2*linem) :: zwrk ! if (scan (zlin (1:llin), zspc) == 0) then write (*, zfmt) zlin (1:llin) else iwrk = 0 do ilin = 1, llin if (index (zspc, zlin (ilin:ilin)) /= 0) then iwrk = iwrk + 1 zwrk (iwrk:iwrk) = zbksl endif iwrk = iwrk + 1 zwrk (iwrk:iwrk) = zlin (ilin:ilin) enddo write (*, zfmt) zwrk (1:iwrk) endif end subroutine wrtflt