CCCCC THE FOLLOWING LINE WAS AUGMENTED JULY 1992 CCCCC SUBROUTINE EDABOR SUBROUTINE EDABOR(STOPSW) C C PURPOSE--ABORT THE EDITING SESSION. C IGNORE ALL CHANGES MADE DURING THE EDITING SESSION. C LEAVE THE ORIGINAL FILE AS IT WAS UPON ENTRY BY THE EDITOR. C NOTE--NO ARGUMENTS ARE EXPECTED. C SYNTAX--AB C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED--JULY 1992 ADD STOP SWITCH (STOPSW) C C--------------------------------------------------------------------- C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1992 CHARACTER*4 STOPSW C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDAB' ISUBN2='OR ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ABOR')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDABOR') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDABOR') 51 FORMAT('*****AT THE BEGINNING OF EDABOR--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ****************************** C ** STEP 1-- ** C ** WRITE OUT A MESSAGE ** C ****************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ABOR') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,1205) CALL EDWRST('EDABOR') 1205 FORMAT('THIS IS AN ABORT FROM THE EDITOR') WRITE(ICOUT,1206) CALL EDWRST('EDABOR') 1206 FORMAT('(THE FILE HAS BEEN LEFT UNCHANGED)') WRITE(ICOUT,1207)IORINA CALL EDWRST('EDABOR') 1207 FORMAT('FILE = ',A80) WRITE(ICOUT,1208)NUMLOR CALL EDWRST('EDABOR') 1208 FORMAT('NUMBER OF LINES = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDABOR') C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ABOR')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDABOR') WRITE(ICOUT,9011) CALL EDWRST('EDABOR') 9011 FORMAT('*****AT THE END OF EDABOR--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C IF(ICOM.EQ.'ABR'.OR.ICOM.EQ.'ABRR')RETURN CCCCC THE FOLLOWING LINE WAS FIXED JULY 1992 CCCCC IF(ICOM.NE.'ABR'.AND.ICOM.NE.'ABRR')STOP IF(ICOM.NE.'ABR'.AND.ICOM.NE.'ABRR')STOPSW='YES' END SUBROUTINE EDACPR C C PURPOSE--ACTIVATE THE PRINTER C (FOR THE IBM-PC PRINTER, C SEND DOWN A CONTROL LOWER CASE P C = ASCII DLE = CHAR(16) ) C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDAC' ISUBN2='PR ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ACPR')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDACPR') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDACPR') 51 FORMAT('***** AT THE BEGINNING OF EDACPR--') 90 CONTINUE C NCOUT=1 ICOUT(1:1)=IDLEC ILOUT=(-1) CALL EDWRST('EDACPR') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDACPR') WRITE(ICOUT,9011) CALL EDWRST('EDACPR') 9011 FORMAT('***** AT THE END OF EDACPR--') 9090 CONTINUE C RETURN END SUBROUTINE EDADD C C PURPOSE--ADD (= INSERT) A TEXT BLOCK FROM FILE C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED --APRIL 1993. FORMAT CHANGED FROM 80 TO 130 C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1993 CCCCC CHARACTER*80 IREC CHARACTER*240 IREC CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDAD' ISUBN2='D ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDADD ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDADD ') 51 FORMAT('***** AT THE BEGINNING OF EDADD--') WRITE(ICOUT,52)ICURLN,NUMLIN CALL EDWRST('EDADD ') 52 FORMAT('ICURLN,NUMLIN = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE BLOCK IS TO BE COPIED FROM ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE CCCCC ISTAT='UNKNOWN' ISTAT='OLD' GOTO1190 C 1120 CONTINUE IFILE=ICOPNA CCCCC ISTAT=ICOPST ISTAT='OLD' GOTO1190 C 1190 CONTINUE IOUNIT=ICOPNU IFORM=ICOPFO IACCES=ICOPAC IREWR=ICOPRW ISUBN0='ADD' IERRFI='NO' C C ********************* C ** STEP 12-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO1210 GOTO1290 C 1210 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL EDWRST('EDADD ') WRITE(ICOUT,1211) 1211 FORMAT('***** ERROR IN EDADD--') CALL EDWRST('EDADD ') WRITE(ICOUT,1212) CALL EDWRST('EDADD ') 1212 FORMAT(' THE ADD FILE COULD NOT BE OPENED') WRITE(ICOUT,1213) CALL EDWRST('EDADD ') 1213 FORMAT(' (FILE NOT EXIST OR FILE PROTECTION VIOLATION)') WRITE(ICOUT,1214) CALL EDWRST('EDADD ') 1214 FORMAT(' NO ADDING WAS CARRIED OUT.') GOTO9000 C 1290 CONTINUE C C ***************************************** C ** STEP 21-- ** C ** SET UP A LOOP ** C ** THAT WILL READ ONE LINE AT A TIME ** C ** FROM THE FILE ** C ** AND INSERT IT AT THE PROPER POINT ** C ** IN THE WORKSPACE ** C ***************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ITARG=ICURLN DO2100IDUMMY=1,100000 C C ************************************ C ** STEP 22-- ** C ** READ IN A LINE FROM THE FILE ** C ************************************ C CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC NUMCRE=80 NUMCRE=238 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,2205,END=2190)IREC CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 C2205 FORMAT(A80) 2205 FORMAT(A238) C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2206)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDADD ') CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1993 C2206 FORMAT('IREC = ',A80) 2206 FORMAT('IREC = ',A238) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2207)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDADD ') 2207 FORMAT('NUMCRE = ',I8) C DO2200I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO2290 2200 CONTINUE IREV=0 2290 CONTINUE NUMCRE=IREV C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2295)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDADD ') CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1993 C2295 FORMAT('IREC = ',A80) 2295 FORMAT('IREC = ',A238) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2296)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDADD ') 2296 FORMAT('NUMCRE = ',I8) C C *************************************************** C ** STEP 23-- ** C ** DETERMINE IF THERE IS ROOM IN THE WORKSPACE ** C ** FOR THE NEW LINE ** C *************************************************** C NUMCH2=NUMCHA+NUMCRE CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C C ********************************************** C ** STEP 24-- ** C ** UPDATE THE WORKSPACE TABLES ** C ** AND INSERT THE LINE INTO THE WORKSPACE ** C ********************************************** C IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURLN+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO2419 IF(NUMLIN.LE.0)GOTO2419 IF(ICURLP.GT.NUMLIN)GOTO2419 DO2410ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 2410 CONTINUE 2419 CONTINUE C J1=NUMCHA+1 N1=NUMCRE J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2420J=J1,J2 I=I+1 ICHA(J)=IREC(I:I) 2420 CONTINUE 2429 CONTINUE ICURLN=ICURLP NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 C 2100 CONTINUE 2190 CONTINUE C C *************************** C ** STEP 25-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFEESW.EQ.'OFF')GOTO2529 C WRITE(ICOUT,999) CALL EDWRST('EDADD ') IMIN=ITARG+1 IMAX=ICURLN IDEL=IMAX-IMIN+1 ILINE=IMIN-1 DO2520IPASS=1,10000 ILINE=ILINE+1 IF(IPASS.GE.2.AND.IDEL.GE.11)ILINE=IMAX IF(ILINE.LT.1)GOTO2525 IF(ILINE.GT.IMAX)GOTO2525 IF(ILINE.GT.NUMLIN)GOTO2525 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2521)(ICHA(J),J=J1,J2) CALL EDWRST('EDADD ') ENDIF 2521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDADD ') ENDIF 2522 FORMAT(I6,':',3X,230A1) 2525 CONTINUE IF(IPASS.GE.2.AND.IDEL.GE.11)GOTO2528 2520 CONTINUE 2528 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDADD ') 2529 CONTINUE C C ********************** C ** STEP 31-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDADD ') WRITE(ICOUT,9011) CALL EDWRST('EDADD ') 9011 FORMAT('***** AT THE END OF EDADD--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDADD ') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDADD ') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDADD ') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDADD ') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,9017)ICURLN,NUMLIN,IFOUEX CALL EDWRST('EDADD ') 9017 FORMAT('ICURLN,NUMLIN,IFOUEX = ',2I8,2X,A4) WRITE(ICOUT,9018)IBLIM1,IBLIM2,IMIN,IMAX CALL EDWRST('EDADD ') 9018 FORMAT('IMIN,IMAX,IBLIM1,IBLIM2 = ',4I8) WRITE(ICOUT,999) CALL EDWRST('EDADD ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDADWO(ICNEWL,NCNEWL,ICWORD,NCWORD, 1ICOLL1,ICOLL2,IBLASW,IADDED) C C PURPOSE--ADD THE NCWORD CHARACTERS IN ICWORD C TO THE END OF ICNEWL. C START THE ADDITION AT COLUMN NCNEWL+1 OF ICNEWL. C IF IBLASW = YES, THEN THIS SUBROUTINE C SHOULD ADD THE WORD AND THEN APPEND THE APPROPRIATE C TRAILING SPACES (USUALLY 1, BUT IT WILL BE 2 C IF THE LAST CHARACTER IN ICWORD IS A PERIOD, C QUESTION MARK, OR EXCLAMATION POINT). C DURING EXECUTION OF THIS SUBROUTINE C (AS ICWORD IS BEING APPENDED TO ICLINE) C IF NO OVERFLOW WAS ENCOUNTERED C AND SO THE WORD WAS ACTUALLY ADDED, C THEN IADDED WILL BE SET TO NO C IF AN OVERFLOW IS ENCOUNTERED, C (AND SO THE WORD WILL NOT BE ADDED) C THEN IADDED WILL BE SET TO NO. C INPUT ARGUMENTS--ICNEWL = THE CHARACTER VARIABLE C TO WHICH THE APPENDING C IS BEING DONE. C NCNEWL = THE CURRENT TOTAL NUMBER OF C CHARACTERS IN ICNEWL. C THE NCNEWL-TH CHARACTER IN ICNEWL C MAY BE EITHER A BLANK OR A NON-BLANK C DEPENDING ON PRIOR CALLS TO THIS SUBROUTINE C AND DEPENDING ON PRIOR SETTINS OF IBLASW. C NEW CHARACTERS BEING ADDED TO C ICNEWL WILL START AT COLUMN NCNEWL+1 C ICWORD = THE CHARACTER VARIABLE C CONTAINING THE WORD BEING ADDED. C NCWORD = THE NUMBER OF CHARACTERS IN ICWORD C TO BE ADDED (STARTING WITH CHARACTER 1). C ICOLL1 = THE LOWER BOUND ON THE COLUMN NUMBER C IN ICLINE; THAT IS, UNDER NO CIRCUMSTANCES C MAY CHARACTERS BE INSERTED INTO ICLINE C BEFORE COLUMN ICOLL1. IF ICOLL1 IS NOT 1, C THEN THIS ALLOWS US TO FORCE LEAD BLANKS C INTO ICLINE. C ICOLL2 = THE UPPER BOUND ON THE COLUMN NUMBER C IN ICLINE; THAT IS, UNDER NO CIRCUMSTANCES C MAY CHARACTERS BE INSERTED INTO ICLINE C AFTER COLUMN ICOLL1. C IBLASW = THE CHARACTER VARIBLE WHICH SPECIFIES C WHETHER A TRAILING BLANK (OR BLANKS) C IS TO BE APPENDED AS A SEPARATOR C AFTER THE ADDED WORD. C IF IBLASW = YES, THEN APPEND A BLANK C (AND INCREMENT NCNEWL BY 1) C IF IBLASW = YES AND THE LAST CHARACTER C OF ICWORD IS A PERIOD, QUESTION MARK, C OR EXCLAMATION POINT, THEN APPEND C 2 SPACES (AND INCREMENT NCNEWL BY 2). C IF IBLASW = NO, THEN APPEND NO BLANKS C OUTPUT ARGUMENTS--ICNEWL = THE CHARACTER VARIABLE C TO WHICH THE APPENDING C IS BEING DONE. C NCNEWL = THE CURRENT TOTAL NUMBER OF C CHARACTERS IN ICNEWL. C NEW CHARACTERS BEING ADDED TO C ICNEWL WILL START AT COLUMN NCNEWL+1 C IADDED = THE CHARACTER VARIABLE WHICH C INDICATES WHETHER OR NOT THE C SPECIFIED WORD WAS IN FACT ADDED OR NOT. C IF NO OVERFLOW WAS ENCOUNTERED, C (AND SO THE WORD WAS ADDED), C THEN IADDED WILL BE SET TO YES . C IF AN OVERFLOW WAS ENCOUNTERED, C (AND SO THE WORD WAS NOT ADDED), C THEN IADDED WILL BE SET TO NO . C CAUTION--THE INPUT VARIABLES ICNEWL AND NCNEWL C MAY BE CHANGED INSIDE THIS SUBROUTINE. C NOTE--ICNEWL AND ICWORD ARE CHARACTER*240 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.6 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICNEWL CHARACTER*240 ICWORD CHARACTER*4 IBLASW CHARACTER*4 IADDED C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEX' ISUBN2='WO ' C IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'ADWO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDADWO') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDADWO') 51 FORMAT('***** AT THE BEGINNING OF EDADWO--') WRITE(ICOUT,54)NCNEWL CALL EDWRST('EDADWO') 54 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,55)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDADWO') ENDIF 55 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) WRITE(ICOUT,61)NCWORD CALL EDWRST('EDADWO') 61 FORMAT('NCWORD = ',I8) IF(NCWORD.GE.1)THEN WRITE(ICOUT,62)(ICWORD(I:I),I=1,100) CALL EDWRST('EDADWO') ENDIF 62 FORMAT('(ICWORD(I:I),I=1,100) = ',100A1) WRITE(ICOUT,71)ICOLL1,ICOLL2,IBLASW,IADDED CALL EDWRST('EDADWO') 71 FORMAT('ICOLL1,ICOLL2,IBLASW,IADDED = ',2I8,2X,A4,2X,A4) WRITE(ICOUT,999) CALL EDWRST('EDADWO') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** IF POSSIBLE (THAT IS, NO OVERFLOW), ** C ** ADD THE SPECIFIED WORD. ** C ******************************************* C ISTART=NCNEWL+1 ISTOP=ISTART+NCWORD-1 IF(ISTOP.GT.ICOLL2)GOTO1150 IF(ISTART.GT.ISTOP)GOTO1150 C J=0 DO1100I=ISTART,ISTOP J=J+1 ICNEWL(I:I)=ICWORD(J:J) 1100 CONTINUE IADDED='YES' NCNEWL=ISTOP GOTO1190 C 1150 CONTINUE IADDED='NO' GOTO9000 C 1190 CONTINUE C C ***************************** C ** STEP 12-- ** C ** IF CALLED FOR, ** C ** ADD TRAILING BLANK(S) ** C ***************************** C IF(IBLASW.EQ.'NO')GOTO1290 C I=NCNEWL+1 IF(I.GT.ICOLL2)GOTO1290 ICNEWL(I:I)=' ' NCNEWL=I C IF(NCWORD.LE.2)GOTO1290 IF(ICWORD(NCWORD:NCWORD).EQ.'.')GOTO1220 IF(ICWORD(NCWORD:NCWORD).EQ.'?')GOTO1220 IF(ICWORD(NCWORD:NCWORD).EQ.'!')GOTO1220 GOTO1290 1220 CONTINUE I=NCNEWL+1 IF(I.GT.ICOLL2)GOTO1290 ICNEWL(I:I)=' ' NCNEWL=I C 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'ADWO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDADWO') WRITE(ICOUT,9011) CALL EDWRST('EDADWO') 9011 FORMAT('***** AT THE END OF EDADWO--') WRITE(ICOUT,9014)NCNEWL CALL EDWRST('EDADWO') 9014 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,9015)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDADWO') ENDIF 9015 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) WRITE(ICOUT,9021)NCWORD CALL EDWRST('EDADWO') 9021 FORMAT('NCWORD = ',I8) IF(NCWORD.GE.1)THEN WRITE(ICOUT,9022)(ICWORD(I:I),I=1,100) CALL EDWRST('EDADWO') ENDIF 9022 FORMAT('(ICWORD(I:I),I=1,100) = ',100A1) WRITE(ICOUT,9031)ICOLL1,ICOLL2,IBLASW,IADDED CALL EDWRST('EDADWO') 9031 FORMAT('ICOLL1,ICOLL2,IBLASW,IADDED = ',2I8,2X,A4,2X,A4) WRITE(ICOUT,999) CALL EDWRST('EDADWO') IF(IBUGT1.EQ.'ON')CALL EDTRA1 9090 CONTINUE C RETURN END SUBROUTINE EDBOTT C C PURPOSE--GO TO BOTTOM OF FILE C (= LINE N+1 = "LINE" AFTER LAST REAL LINE). C C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDBO' ISUBN2='TT ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'BOTT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDBOTT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDBOTT') 51 FORMAT('***** AT THE BEGINNING OF EDBOTT--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO LINE N+1 ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'BOTT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=NUMLIN+1 IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDBOTT') ENDIF 1151 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDBOTT') ENDIF 1152 FORMAT(10X,'[BOTTOM]') 1159 CONTINUE ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'BOTT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDBOTT') WRITE(ICOUT,9011) CALL EDWRST('EDBOTT') 9011 FORMAT('***** AT THE END OF EDBOTT--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCALL C C PURPOSE--DEFINE THE CALL FILE, OPEN IT, AND C SET THE CALL SWITCH TO ON. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCA' ISUBN2='LL ' C IFOUND='YES' IERROR='NO' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CALL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCALL') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCALL') 51 FORMAT('***** AT THE BEGINNING OF EDCALL--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT IS TO BE CALLED ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CALL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE ISTAT='UNKNOWN' GOTO1190 C 1120 CONTINUE IFILE=ICALNA ISTAT=ICALST GOTO1190 C 1190 CONTINUE IOUNIT=ICALNU IFORM=ICALFO IACCES=ICALAC IREWR=ICALRW ISUBN0='CALP' IERRFI='NO' C ICALNA=IFILE ICALST=ISTAT C C ********************* C ** STEP 2-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='2' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'CALL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')IERROR=IERRFI IF(IERRFI.EQ.'YES')GOTO9000 C C *********************************** C ** STEP 3-- ** C ** SET THE CALL SWITCH TO ON ** C *********************************** C C ISTEPN='3' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'CALL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICCALL='ON' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CALL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCALL') WRITE(ICOUT,9011) CALL EDWRST('EDCALL') 9011 FORMAT('***** AT THE END OF EDCALL--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDCALL') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDCALL') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDCALL') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDCALL') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCEN2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C PURPOSE--CENTER THE LINE IN IOLDLI(.). C THE CENTERED LINE WILL BE PLACED IN INEWLI(.). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(*) DIMENSION INEWLI(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCE' ISUBN2='N2 ' C C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CEN2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCEN2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCEN2') 51 FORMAT('***** AT THE BEGINNING OF EDCEN2--') WRITE(ICOUT,71)NUMCOL CALL EDWRST('EDCEN2') 71 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,72)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCEN2') 72 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,73)NUMCNL CALL EDWRST('EDCEN2') 73 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,74)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCEN2') 74 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,81)ICENTC CALL EDWRST('EDCEN2') 81 FORMAT('ICENTC = ',I8) 90 CONTINUE C C ************************************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST NON-BLANK CHARACTER IN IOLDLI(.) ** C ************************************************************ C I2=0 IF(NUMCOL.LE.0)GOTO1190 DO1100I=1,NUMCOL I2=I IF(IOLDLI(I2).NE.' ')GOTO1190 1100 CONTINUE I2=NUMCOL+1 1190 CONTINUE IFIRST=I2 C C ************************************************************ C ** STEP 2-- ** C ** DETERMINE THE LAST NON-BLANK CHARACTER IN IOLDLI(.) ** C ************************************************************ C IREV=0 IF(NUMCOL.LE.0)GOTO1290 DO1200I=1,NUMCOL IREV=NUMCOL-I+1 IF(IOLDLI(IREV).NE.' ')GOTO1290 1200 CONTINUE IREV=0 1290 CONTINUE ILAST=IREV C C *************************************************************** C ** STEP 3-- C ** DETERMINE THE CENTER OF THE NON-BLANK STRING IN IOLDLI(.) C *************************************************************** C ICENT1=(IFIRST+ILAST)/2 C C ****************************************************** C ** STEP 4-- ** C ** DETERMINE THE DESIRED CENTER OF THE NEW STRING ** C ****************************************************** C ICENT2=ICENTC C C ******************************** C ** STEP 5-- ** C ** BLANK OUT THE NEW STRING ** C ******************************** C NUMCNL=1 DO1500I=1,240 INEWLI(I)=' ' 1500 CONTINUE C C ************************************** C ** STEP 6-- ** C ** FORM THE NEW (CENTERED) STRING ** C ************************************** C ISHIFT=ICENT2-ICENT1 C INEW=1 IF(IFIRST.LE.0)GOTO1690 IF(IFIRST.GT.ILAST)GOTO1690 DO1600IOLD=IFIRST,ILAST INEW=IOLD+ISHIFT IF(INEW.LT.IMLIM1)GOTO1600 IF(INEW.GT.IMLIM2)GOTO1600 INEWLI(INEW)=IOLDLI(IOLD) 1600 CONTINUE 1690 CONTINUE NUMCNL=INEW C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CEN2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCEN2') WRITE(ICOUT,9011) CALL EDWRST('EDCEN2') 9011 FORMAT('***** AT THE END OF EDCEN2--') WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDCEN2') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCEN2') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDCEN2') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCEN2') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)IFIRST,ILAST,ICENT1,ICENT2,ISHIFT CALL EDWRST('EDCEN2') 9041 FORMAT('IFIRST,ILAST,ICENT1,ICENT2,ISHIFT = ',5I8) 9090 CONTINUE C RETURN END SUBROUTINE EDCENT C C PURPOSE--CENTER CURRENT LINE C (AND NEXT IARG1-1 LINES) C SO AS TO BE BETWEEN MARGIN LIMITS. C COMMAND SYNTAX--CENTER WHERE IS BLANK OR SOME NUMBER. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(240) DIMENSION INEWLI(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCE' ISUBN2='NT ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CENT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCENT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCENT') 51 FORMAT('***** AT THE BEGINNING OF EDCENT--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE CENTERED. ** C ************************************ C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ICURLN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ICURLN GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) ISTART=ICURLN ISTOP=ISTART+IARG1-1 GOTO1190 C 1120 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) IARG2=NUMLIN+1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) ISTART=IARG1 ISTOP=IARG2 GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ******************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES TO BE CENTERED ** C ******************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART-1 2100 CONTINUE ILINE=ILINE+1 IF(ILINE.LE.ISTOP)GOTO2910 ILINE=ISTOP GOTO2900 2910 CONTINUE ICURLN=ILINE IF(ILINE.LT.1)GOTO2100 IF(ILINE.GT.NUMLIN)GOTO2900 C C ***************************** C ** STEP 22-- ** C ** COPY THE OLD LINE ** C ***************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 DO2200J=J1,J2 I=I+1 IOLDLI(I)=ICHA(J) 2200 CONTINUE NUMCOL=I C C *********************************** C ** STEP 23-- ** C ** APPLY THE DESIRED CENTERING ** C ** TO THE TARGET LINE, ** C ** SO AS TO CREATE ** C ** A NEW LINE. ** C *********************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDCEN2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C *************************************** C ** STEP 24-- ** C ** DETERMINE IF ROOM EXISTS IN THE ** C ** MAIN INTERNAL CHARACTER ARRAY ** C ** FOR THE NEW CENTERED LINE. ** C *************************************** C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH9=NUMCHA+NUMCNL CALL EDCHSI(NUMCH9) IF(IERROR.EQ.'YES')GOTO9000 C 2450 CONTINUE IF(ILINE.LT.1)GOTO2460 IF(ILINE.GT.NUMLIN)GOTO2470 GOTO2490 C 2460 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2461) CALL EDWRST('EDCENT') ENDIF 2461 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2462) CALL EDWRST('EDCENT') ENDIF 2462 FORMAT(10X,'[TOP]') 2469 CONTINUE GOTO2100 C 2470 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2471) CALL EDWRST('EDCENT') ENDIF 2471 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2472) CALL EDWRST('EDCENT') ENDIF 2472 FORMAT(10X,'[BOTTOM]') 2479 CONTINUE GOTO9000 C 2490 CONTINUE C C *************************************** C ** STEP 25-- ** C ** UPDATE THE MAIN CHARACTER ARRAY ** C ** WITH THE NEW LINE. ** C *************************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J1=NUMCHA+1 N1=NUMCNL J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ILINE)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2500J=J1,J2 I=I+1 ICHA(J)=INEWLI(I) 2500 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 C IF(IFEESW.EQ.'OFF')GOTO2629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2621)(ICHA(J),J=J1,J2) CALL EDWRST('EDCENT') ENDIF 2621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2622)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDCENT') ENDIF 2622 FORMAT(I6,':',3X,230A1) 2629 CONTINUE C GOTO2100 C 2900 CONTINUE IF(ILINE.LE.NUMLIN)GOTO2919 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2911) CALL EDWRST('EDCENT') ENDIF 2911 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2912) CALL EDWRST('EDCENT') ENDIF 2912 FORMAT(10X,'[BOTTOM]') 2919 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CENT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCENT') WRITE(ICOUT,9011) CALL EDWRST('EDCENT') 9011 FORMAT('***** AT THE END OF EDCENT--') WRITE(ICOUT,999) CALL EDWRST('EDCENT') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDCENT') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDCENT') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDCENT') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCENT') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDCENT') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCENT') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)ICURLN,ISTART,ISTOP CALL EDWRST('EDCENT') 9041 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9042)J1,N1,J2 CALL EDWRST('EDCENT') 9042 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDCENT') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCHA2(IGLOBA,ISTRI1,NUMCS1,ISTRI2,NUMCS2, 1IOLDLI,NUMCOL,INEWLI,NUMCNL,IFOUST) C C PURPOSE--SCAN IOLDLI(.) FOR THE STRING IN ISTRI1(.). C IF FOUND, THEN FORM THE NEW LINE INEWLI(.) C WHICH IS THE SAME AS IOLDLI(.) EXCEPT C ISTRI1(.) HAS BEEN CHANGED TO ISTRI2(.). C IF NOT FOUND, THEN INEWLI(.) = IOLDLI(.) C NOTE--IF IGLOBA='ON', THEN DO SO FOR ALL STRINGS IN IOLDLI(.), C OTHERWISE DO ONLY FOR THE FIRST STRING IN IOLDLI(.). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C UPDATED--APRIL 1990 FORCE IMASK TO BE NON-BLANK C UPDATED--APRIL 1990 ALLOW FOR (EXACTLY 1) WORD CHANGE VIA $ MASK CHAR C UPDATED--MARCH 1992 UNDO APRIL 1990 SINCE TRUNCATING A LINE C UPDATED--APRIL 1992 CHANGE MASK CHARACTER FROM $ TO ~ C UPDATED--SEPTEMBER 1994 CHANGE MASK CHARACTER FROM ~ TO ` C C--------------------------------------------------------------------- C CHARACTER*4 IGLOBA C CHARACTER*1 ISTRI1 CHARACTER*1 ISTRI2 CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C CHARACTER*4 IFOUST C CHARACTER*1 IMASKV CCCCC THE FOLLOWING 3 LINES WERE ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 CHARACTER*4 IMWSW CHARACTER*1 IMASKW CHARACTER*1 IMASWV C DIMENSION ISTRI1(*) DIMENSION ISTRI2(*) DIMENSION IOLDLI(*) DIMENSION INEWLI(*) C DIMENSION IMASKV(240) CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 DIMENSION IMASWV(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCH' ISUBN2='A2 ' C JPIM1=(-999) C CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 IMWSW='OFF' CCCCC THE MASK CHARACTER WAS CHANGED FROM ~ TO ` CCCCC THE FOLLOWING LINE WAS CHANGED SEPTEMBER 1994 CCCCC TO CHANGE THE MASK CHARACTER FROM ~ TO ` SEPTEMBER 1994 CCCCC IMASKW='$' IMASKW='`' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CHA2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCHA2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCHA2') 51 FORMAT('***** AT THE BEGINNING OF EDCHA2--') WRITE(ICOUT,52)IGLOBA CALL EDWRST('EDCHA2') 52 FORMAT('IGLOBA = ',A4) WRITE(ICOUT,61)NUMCS1 CALL EDWRST('EDCHA2') 61 FORMAT('NUMCS1 = ',I8) WRITE(ICOUT,62)(ISTRI1(I),I=1,NUMCS1) CALL EDWRST('EDCHA2') 62 FORMAT('(ISTRI1(I),I=1,NUMCS1) = ',110A1) WRITE(ICOUT,63)NUMCS2 CALL EDWRST('EDCHA2') 63 FORMAT('NUMCS2 = ',I8) WRITE(ICOUT,64)(ISTRI2(I),I=1,NUMCS2) CALL EDWRST('EDCHA2') 64 FORMAT('(ISTRI2(I),I=1,NUMCS2) = ',110A1) WRITE(ICOUT,71)NUMCOL CALL EDWRST('EDCHA2') 71 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,72)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCHA2') 72 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,73)NUMCNL CALL EDWRST('EDCHA2') 73 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,74)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCHA2') 74 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,81)IFOUST CALL EDWRST('EDCHA2') 81 FORMAT('IFOUST = ',A4) WRITE(ICOUT,82)ICLIM1,ICLIM2 CALL EDWRST('EDCHA2') 82 FORMAT('ICLIM1,ICLIM2 = ',2I8) 90 CONTINUE C IFOUST='NO' NUMCNL=NUMCOL IF(NUMCOL.LE.0)GOTO9000 DO1100I=1,NUMCOL INEWLI(I)=IOLDLI(I) 1100 CONTINUE C C ******************************* C ** STEP 11-- ** C ** TREAT THE CASE WHEN ** C ** STRING 1 IS NULL ** C ** (THAT IS, NUMCS1 <= 0) ** C ******************************* C IF(NUMCS1.LE.0)GOTO1200 GOTO1900 C 1200 CONTINUE IFOUST='YES' C K=0 C C STEP 11.1--COPY OUT TO THE COLUMN LIMITS C IMIN=1 IMAX=ICLIM1-1 IF(IMIN.GT.IMAX)GOTO1219 DO1210I=IMIN,IMAX K=K+1 INEWLI(K)=' ' IF(I.LE.NUMCOL)INEWLI(K)=IOLDLI(I) CCCCC WRITE(ICOUT,777)I,K,INEWLI(K),IMIN,IMAX CC777 FORMAT('I,K,INEWLI(I),IMIN,IMAX = ',2I8,2X,A1,2I8) 1210 CONTINUE 1219 CONTINUE C C STEP 11.2--COPY STRING 2 AT THE COLUMN LIMIT C IMIN=ICLIM1 IMAX=ICLIM1+NUMCS2-1 IF(IMIN.GT.IMAX)GOTO1229 L=0 DO1220I=IMIN,IMAX K=K+1 L=L+1 INEWLI(K)=ISTRI2(L) CCCCC WRITE(ICOUT,777)I,K,INEWLI(K),IMIN,IMAX 1220 CONTINUE 1229 CONTINUE C C STEP 11.3--PUSH (COPY) THE OLD LINE TO THE RIGHT C IMIN=ICLIM1+NUMCS2 IMAX=ICLIM2 IF(IMIN.GT.IMAX)GOTO1239 DO1230I=IMIN,IMAX I2=I-NUMCS2 IF(I2.GT.NUMCOL)GOTO1239 K=K+1 INEWLI(K)=IOLDLI(I2) CCCCC WRITE(ICOUT,777)I,K,INEWLI(K),IMIN,IMAX 1230 CONTINUE 1239 CONTINUE C C STEP 11.4--COPY BEYOND THE COLUMN LIMITS C IMIN=ICLIM2+1 IMAX=240 IF(IMIN.GT.IMAX)GOTO1249 DO1240I=IMIN,IMAX IF(I.GT.NUMCOL)GOTO1249 K=K+1 INEWLI(K)=IOLDLI(I) CCCCC WRITE(ICOUT,777)I,K,INEWLI(K),IMIN,IMAX 1240 CONTINUE 1249 CONTINUE C NUMCNL=K GOTO9000 C 1900 CONTINUE C C ********************************** C ** STEP 21-- ** C ** TREAT THE CASE WHEN ** C ** THE OLD STRING IS NON-NULL ** C ** (THAT IS, NUMCS1 >= 1) ** C ********************************** C C I IS THE INDEX OF STRING 1 C J IS THE INDEX OF THE OLD LINE C K IS THE INDEX OF THE NEW LINE C J=0 K=0 CCCCC THE FOLLOWING 2 LINES WERE ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 IMW=0 IMWSW='OFF' 2100 CONTINUE J=J+1 IF(J.GT.NUMCOL)GOTO2900 IF(J.GT.ICLIM2)GOTO2900 C IF(J.LT.ICLIM1)GOTO2210 IM=0 DO2200I=1,NUMCS1 JPIM1=J+(I-1) CCCCC THE FOLLOWING 1 LINE WAS ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 IF(ISTRI1(I).EQ.IMASKW.AND.IOLDLI(JPIM1).NE.' ')GOTO2207 IF(ISTRI1(I).EQ.IMASK)GOTO2200 CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC TO FORCE IMASK TO BE NON-BLANK APRIL 1990 CCCCC IF(ISTRI1(I).EQ.IMASK)GOTO2205 IF(ISTRI1(I).EQ.IMASK.AND.IOLDLI(JPIM1).NE.' ')GOTO2205 IF(IOLDLI(JPIM1).EQ.ISTRI1(I))GOTO2200 GOTO2210 2205 CONTINUE IM=IM+1 IMASKV(IM)=IOLDLI(JPIM1) GOTO2200 CCCCC THE FOLLOWING 4 LINES WERE ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 2207 CONTINUE IMWSW='ON' IMW=IMW+1 NMW=IMW IMASWV(IMW)=IOLDLI(JPIM1) CCCCC WRITE(ICOUT,888)J,K,I,IMW CC888 FORMAT('J,K,I,IMW = ',4I8) J=J+1 JPIM1=J+(I-1) IF(JPIM1.GT.NUMCOL)GOTO2290 IF(JPIM1.GT.ICLIM2)GOTO2290 IF(IOLDLI(JPIM1).NE.' ')GOTO2207 GOTO2290 2200 CONTINUE NM=IM NMW=IMW GOTO2290 C 2210 CONTINUE K=K+1 INEWLI(K)=IOLDLI(J) GOTO2100 C 2290 CONTINUE C IFOUST='YES' IF(NUMCS2.LE.0)GOTO2350 IM=0 DO2300I=1,NUMCS2 CCCCC THE FOLLOWING 9 LINES WERE ADDED APRIL 1990 CCCCC TO ALLOW FOR WORD MASK APRIL 1990 IF(ISTRI2(I).EQ.IMASKW)GOTO2310 GOTO2319 2310 CONTINUE DO2311L=1,NMW K=K+1 INEWLI(K)=IMASWV(L) 2311 CONTINUE J=J-1 GOTO2300 2319 CONTINUE K=K+1 IF(IM.GT.NM)IM=0 IF(ISTRI2(I).EQ.IMASK)IM=IM+1 IF(ISTRI2(I).EQ.IMASK)INEWLI(K)=IMASKV(IM) IF(ISTRI2(I).EQ.IMASK)GOTO2300 INEWLI(K)=ISTRI2(I) 2300 CONTINUE 2350 CONTINUE J=JPIM1 IF(IGLOBA.EQ.'ON')GOTO2100 C 2400 CONTINUE CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC J=J+1 IF(IMWSW.EQ.'ON')J=J-1 2410 CONTINUE J=J+1 IF(J.GT.NUMCOL)GOTO2900 K=K+1 INEWLI(K)=IOLDLI(J) GOTO2410 C 2900 CONTINUE NUMCNL=K GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CHA2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCHA2') WRITE(ICOUT,9011) CALL EDWRST('EDCHA2') 9011 FORMAT('***** AT THE END OF EDCHA2--') WRITE(ICOUT,9012)IGLOBA CALL EDWRST('EDCHA2') 9012 FORMAT('IGLOBA = ',A4) WRITE(ICOUT,9021)NUMCS1 CALL EDWRST('EDCHA2') 9021 FORMAT('NUMCS1 = ',I8) WRITE(ICOUT,9022)(ISTRI1(I),I=1,NUMCS1) CALL EDWRST('EDCHA2') 9022 FORMAT('(ISTRI1(I),I=1,NUMCS1) = ',100A1) WRITE(ICOUT,9023)NUMCS2 CALL EDWRST('EDCHA2') 9023 FORMAT('NUMCS2 = ',I8) WRITE(ICOUT,9024)(ISTRI2(I),I=1,NUMCS2) CALL EDWRST('EDCHA2') 9024 FORMAT('(ISTRI2(I),I=1,NUMCS2) = ',100A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDCHA2') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCHA2') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',100A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDCHA2') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCHA2') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',100A1) WRITE(ICOUT,9041)IFOUST CALL EDWRST('EDCHA2') 9041 FORMAT('IFOUST = ',A4) WRITE(ICOUT,9042)ICLIM1,ICLIM2 CALL EDWRST('EDCHA2') 9042 FORMAT('ICLIM1,ICLIM2 = ',2I8) 9090 CONTINUE C RETURN END SUBROUTINE EDCHAN(IGLOBA) C C PURPOSE--CHANGE A LINE OF TEXT C THE FIRST STRING WILL BE REPLACED BY THE SECOND STRING C COMMAND SYNTAX--C /// C NOTE--IF THE FINAL DELIMITER IS OMITTED, C IT WILL AUTOMATICALLY BE SUPPLIED BY THE EDITOR. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C UPDATED --APRIL 1990 FIX BOMB FOR C COMMAND WITH NO ARGS C C--------------------------------------------------------------------- C CHARACTER*4 IGLOBA C CHARACTER*1 ISTRIN CHARACTER*1 ISTRI1 CHARACTER*1 ISTRI2 CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C CHARACTER*1 IDELCH CHARACTER*4 IFOUEX CHARACTER*4 IFOUST CHARACTER*4 IFOUSA C DIMENSION ISTRIN(240) DIMENSION ISTRI1(240) DIMENSION ISTRI2(240) DIMENSION IOLDLI(240) DIMENSION INEWLI(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCH' ISUBN2='AN ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IFOUEX='NO' IFOUST='NO' IFOUSA='NO' CHANGE='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CHAN')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCHAN') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCHAN') 51 FORMAT('***** AT THE BEGINNING OF EDCHAN--') WRITE(ICOUT,52)IGLOBA CALL EDWRST('EDCHAN') 52 FORMAT('IGLOBA = ',A4) WRITE(ICOUT,61)NUMCCS CALL EDWRST('EDCHAN') 61 FORMAT('NUMCCS = ',I8) IF(NUMCCS.GE.1)WRITE(ICOUT,62)(ICHAST(I),I=1,NUMCCS) IF(NUMCCS.GE.1)CALL EDWRST('EDCHAN') 62 FORMAT('(ICHAST(I),I=1,NUMCCS) = ',80A1) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************** C ** STEP 10-- ** C ** SAVE THE CURRENT POINTERS ** C ** (FOR POSSIBLE LATER USE ** C ** BY THE UNDO COMMAND) ** C ********************************** C ISTEPN='10' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSACP C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE FULL CHANGE STRING ** C ** ON THE COMMAND LINE ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1190 C NUMCST=NUMCCS IF(NUMCCS.LE.0)GOTO1159 DO1155I=1,NUMCCS ISTRIN(I)=ICHAST(I) 1155 CONTINUE 1159 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 12-- ** C ** IF THE STRING IS NEW, ** C ** COPY THE STRING INTO ILOCST(.) ** C ** FOR FUTURE USE BY SUBSEQUENT ** C ** LOCATE COMMANDS. ** C ************************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFOUEX.EQ.'NO')GOTO1290 NUMCCS=NUMCST IF(NUMCST.LE.0)GOTO1290 DO1210I=1,NUMCST ICHAST(I)=ISTRIN(I) 1210 CONTINUE 1290 CONTINUE C C ***************************** C ** STEP 13-- ** C ** EXTRACT THE DELIMITER ** C ***************************** C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IDELCH=ISTRIN(1) ILOCD1=1 C C *********************************** C ** STEP 14-- ** C ** EXTRACT THE "OLD" SUBSTRING ** C *********************************** C ISTEPN='14' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J=0 ILOCD2=ILOCD1 IMIN=ILOCD1+1 IF(NUMCST.LT.IMIN)GOTO1490 DO1400I=IMIN,NUMCST I2=I J=J+1 IF(ISTRIN(I).EQ.IDELCH)GOTO1450 ISTRI1(J)=ISTRIN(I) 1400 CONTINUE ILOCD2=NUMCST+1 GOTO1490 1450 CONTINUE J=J-1 ILOCD2=I2 1490 CONTINUE NUMCS1=J C C *********************************** C ** STEP 15-- ** C ** EXTRACT THE "NEW" SUBSTRING ** C *********************************** C ISTEPN='15' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J=0 ILOCD3=ILOCD2 IMIN=ILOCD2+1 IF(NUMCST.LT.IMIN)GOTO1590 DO1500I=IMIN,NUMCST I2=I J=J+1 IF(ISTRIN(I).EQ.IDELCH)GOTO1550 ISTRI2(J)=ISTRIN(I) 1500 CONTINUE ILOCD3=NUMCST+1 GOTO1590 1550 CONTINUE J=J-1 ILOCD3=I2 1590 CONTINUE NUMCS2=J C C ***************************************************** C ** STEP 16-- ** C ** DETERMINE IF THERE IS A NUMBER DESIGNATION ** AT C ** THE END OF THE COMMAND LINE ** C ** (WHICH WOULD SPECIFY THAT ** C ** MULTIPLE LINES SHOULD BE CHANGED). ** C ** THUS DETERMINE THE START LINE FOR THE CHANGE, ** C ** AND THE STOP LINE FOR THE CHANGE. ** C ***************************************************** C ISTEPN='16' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN NUMLTC=1 IF(ILOCD3.EQ.NUMCST)GOTO1690 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1990 FOR MY 386 IF(NUMARG.LE.0)GOTO1690 IF(IARGT(NUMARG).EQ.'WORD'.AND.IHARG(NUMARG).EQ.IINFIN) 1NUMLTC=100000 IF(IARGT(NUMARG).EQ.'NUMB')NUMLTC=IARG(NUMARG) 1690 CONTINUE ISTOP=ISTART+(NUMLTC-1) C C ******************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES TO BE CHANGED ** C ******************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART-1 2100 CONTINUE ILINE=ILINE+1 IF(ILINE.LE.ISTOP)GOTO2910 ILINE=ISTOP GOTO2900 2910 CONTINUE ICURLN=ILINE IF(ILINE.LT.1)GOTO2100 IF(ILINE.GT.NUMLIN)GOTO2900 C C ***************************** C ** STEP 22-- ** C ** COPY THE OLD LINE ** C ***************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 DO2200J=J1,J2 I=I+1 IOLDLI(I)=ICHA(J) 2200 CONTINUE NUMCOL=I C C ******************************** C ** STEP 23-- ** C ** APPLY THE DESIRED CHANGE ** C ** TO THE TARGET LINE, ** C ** SO AS TO CREATE ** C ** A NEW LINE. ** C ******************************** C CALL EDCHA2(IGLOBA,ISTRI1,NUMCS1,ISTRI2,NUMCS2, 1IOLDLI,NUMCOL,INEWLI,NUMCNL,IFOUST) C IF(IFOUST.EQ.'YES')IFOUSA='YES' IF(IFOUST.EQ.'YES')CHANGE='YES' IF(IFOUST.EQ.'NO')GOTO2100 C C *************************************** C ** STEP 24-- ** C ** DETERMINE IF ROOM EXISTS IN THE ** C ** MAIN INTERNAL CHARACTER ARRAY ** C ** FOR THE NEW CHANGED LINE. ** C *************************************** C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH2=NUMCHA+NUMCNL CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C 2450 CONTINUE IF(ILINE.LT.1)GOTO2460 IF(ILINE.GT.NUMLIN)GOTO2470 GOTO2490 C 2460 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2461) CALL EDWRST('EDCHAN') ENDIF 2461 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2462) CALL EDWRST('EDCHAN') ENDIF 2462 FORMAT(10X,'[TOP]') 2469 CONTINUE GOTO2100 C 2470 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2471) CALL EDWRST('EDCHAN') ENDIF 2471 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2472) CALL EDWRST('EDCHAN') ENDIF 2472 FORMAT(10X,'[BOTTOM]') 2479 CONTINUE GOTO9000 C 2490 CONTINUE C C *************************************** C ** STEP 25-- ** C ** UPDATE THE MAIN CHARACTER ARRAY ** C ** WITH THE NEW LINE. ** C *************************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CHAN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J1=NUMCHA+1 N1=NUMCNL J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ILINE)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2500J=J1,J2 I=I+1 ICHA(J)=INEWLI(I) 2500 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 C IF(IFOUST.EQ.'NO')GOTO2629 IF(IFEESW.EQ.'OFF')GOTO2629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2621)(ICHA(J),J=J1,J2) CALL EDWRST('EDCHAN') ENDIF 2621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2622)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDCHAN') ENDIF 2622 FORMAT(I6,':',3X,230A1) 2629 CONTINUE C GOTO2100 C 2900 CONTINUE IF(ILINE.LE.NUMLIN)GOTO2919 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2911) CALL EDWRST('EDCHAN') ENDIF 2911 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2912) CALL EDWRST('EDCHAN') ENDIF 2912 FORMAT(10X,'[BOTTOM]') 2919 CONTINUE C IF(IFOUSA.EQ.'YES')GOTO2929 IF(IFEESW.EQ.'OFF')GOTO2929 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2921) CALL EDWRST('EDCHAN') ENDIF 2921 FORMAT('STRING NOT FOUND') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2922) CALL EDWRST('EDCHAN') ENDIF 2922 FORMAT(10X,'STRING NOT FOUND') 2929 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CHAN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCHAN') WRITE(ICOUT,9011) CALL EDWRST('EDCHAN') 9011 FORMAT('***** AT THE END OF EDCHAN--') WRITE(ICOUT,999) CALL EDWRST('EDCHAN') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDCHAN') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDCHAN') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9015)IGLOBA CALL EDWRST('EDCHAN') 9015 FORMAT('IGLOBA = ',A4) WRITE(ICOUT,9016)NUMCST CALL EDWRST('EDCHAN') 9016 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9017)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDCHAN') 9017 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9021)NUMCS1 CALL EDWRST('EDCHAN') 9021 FORMAT('NUMCS1 = ',I8) WRITE(ICOUT,9022)(ISTRI1(I),I=1,NUMCS1) CALL EDWRST('EDCHAN') 9022 FORMAT('(ISTRI1(I),I=1,NUMCS1) = ',110A1) WRITE(ICOUT,9023)NUMCS2 CALL EDWRST('EDCHAN') 9023 FORMAT('NUMCS2 = ',I8) WRITE(ICOUT,9024)(ISTRI2(I),I=1,NUMCS2) CALL EDWRST('EDCHAN') 9024 FORMAT('(ISTRI2(I),I=1,NUMCS2) = ',110A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDCHAN') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDCHAN') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDCHAN') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDCHAN') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9035)IFOUEX,IFOUST,IFOUSA,CHANGE CALL EDWRST('EDCHAN') 9035 FORMAT('IFOUEX,IFOUST,IFOUSA = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,9041)J1,N1,J2 CALL EDWRST('EDCHAN') 9041 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9042)ICURLN CALL EDWRST('EDCHAN') 9042 FORMAT('ICURLN = ',I8) WRITE(ICOUT,9051)NUMCCS CALL EDWRST('EDCHAN') 9051 FORMAT('NUMCCS = ',I8) IF(NUMCCS.GE.1)WRITE(ICOUT,9052)(ICHAST(I),I=1,NUMCCS) IF(NUMCCS.GE.1)CALL EDWRST('EDCHAN') 9052 FORMAT('(ICHAST(I),I=1,NUMCCS) = ',80A1) WRITE(ICOUT,999) CALL EDWRST('EDCHAN') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCHSI(NUMCHX) C C PURPOSE--CHECK TO SEE IF A NEW LINE WILL FIT C IN THE INTERNAL WORKSPACE. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDCH' ISUBN2='SI ' C IFOUND='YES' IERROR='NO' C C IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'CHSI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCHSI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCHSI') 51 FORMAT('***** AT THE BEGINNING OF EDCHSI--') WRITE(ICOUT,52)NUMLIN,MAXEDL CALL EDWRST('EDCHSI') 52 FORMAT('NUMLIN,MAXEDL = ',2I8) WRITE(ICOUT,53)NUMROW,MAXROW CALL EDWRST('EDCHSI') 53 FORMAT('NUMROW,MAXROW = ',2I8) WRITE(ICOUT,54)NUMCHA,MAXEDC,NUMCHX CALL EDWRST('EDCHSI') 54 FORMAT('NUMCHA,MAXEDC,NUMCHX = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************* C ** STEP 1-- ** C ** CHECK TO SEE IF THE WORKSPACE ** C ** WILL OVERFLOW ** C ************************************* C IF(NUMLIN.GE.MAXEDL)GOTO2410 IF(NUMROW.GE.MAXROW)GOTO2420 IF(NUMCHA.GE.MAXEDC)GOTO2430 IF(NUMCHX.GT.MAXEDC)GOTO2440 GOTO2490 C 2410 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCHSI') WRITE(ICOUT,2411) CALL EDWRST('EDCHSI') 2411 FORMAT('***** ERROR IN EDCHSI--') WRITE(ICOUT,2412) CALL EDWRST('EDCHSI') 2412 FORMAT(' NO ROOM LEFT FOR MORE LINES.') WRITE(ICOUT,2413)NUMLIN,MAXEDL CALL EDWRST('EDCHSI') 2413 FORMAT(' NUMLIN (',I8,') >= MAXEDL (',I8,')') IERROR='YES' GOTO9000 C 2420 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCHSI') WRITE(ICOUT,2421) CALL EDWRST('EDCHSI') 2421 FORMAT('***** ERROR IN EDCHSI--') WRITE(ICOUT,2422) CALL EDWRST('EDCHSI') 2422 FORMAT(' NO ROOM LEFT FOR MORE ROWS.') WRITE(ICOUT,2423)NUMROW,MAXROW CALL EDWRST('EDCHSI') 2423 FORMAT(' NUMROW (',I8,') >= MAXROW (',I8,')') IERROR='YES' GOTO9000 C 2430 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCHSI') WRITE(ICOUT,2431) CALL EDWRST('EDCHSI') 2431 FORMAT('***** ERROR IN EDCHSI--') WRITE(ICOUT,2432) CALL EDWRST('EDCHSI') 2432 FORMAT(' NO ROOM LEFT FOR MORE CHARACTERS.') WRITE(ICOUT,2433)NUMCHA,MAXEDC CALL EDWRST('EDCHSI') 2433 FORMAT(' NUMCHA (',I8,') >= MAXEDC (',I8,')') IERROR='YES' GOTO9000 C 2440 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCHSI') WRITE(ICOUT,2441) CALL EDWRST('EDCHSI') 2441 FORMAT('***** ERROR IN EDCHSI--') WRITE(ICOUT,2442) CALL EDWRST('EDCHSI') 2442 FORMAT(' NEW STRING WOULD EXCEED ICHA(.) WORKSPACE.') WRITE(ICOUT,2443)NUMCHA,MAXEDC,NUMCHX CALL EDWRST('EDCHSI') 2443 FORMAT(' NUMCHA,MAXEDC,NUMCHX = ',3I8) IERROR='YES' GOTO9000 C 2490 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'CHSI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCHSI') WRITE(ICOUT,9011) CALL EDWRST('EDCHSI') 9011 FORMAT('***** AT THE END OF EDCHSI--') WRITE(ICOUT,9012)NUMLIN,MAXEDL CALL EDWRST('EDCHSI') 9012 FORMAT('NUMLIN,MAXEDL = ',2I8) WRITE(ICOUT,9013)NUMROW,MAXROW CALL EDWRST('EDCHSI') 9013 FORMAT('NUMROW,MAXROW = ',2I8) WRITE(ICOUT,9014)NUMCHA,MAXEDC,NUMCHX CALL EDWRST('EDCHSI') 9014 FORMAT('NUMCHA,MAXEDC,NUMCHX = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDCHSI') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCLFI(IOUNIT,IENDFI,IREWIN) C C PURPOSE--CLOSE A FILE. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--NOVEMBER 1985. C C----------------------------------------------------------------------------- C CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCL' ISUBN2='FI ' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CLFI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCLFI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCLFI') 51 FORMAT('***** AT THE BEGINNING OF EDCLFI--') WRITE(ICOUT,52)IOUNIT CALL EDWRST('EDCLFI') 52 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,53)IENDFI CALL EDWRST('EDCLFI') 53 FORMAT('IENDFI = ',A4) WRITE(ICOUT,54)IREWIN CALL EDWRST('EDCLFI') 54 FORMAT('IREWIN = ',A4) 90 CONTINUE C C ********************* C ** STEP 1-- ** C ** CLOSE THE FILE ** C ********************* C ISTEPN='1' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'CLFI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IENDFI.EQ.'ON'.AND.IHOST1.EQ.'UNIV')GOTO1100 GOTO1190 1100 CONTINUE ENDFILE IOUNIT 1190 CONTINUE C IF(IREWIN.EQ.'ON')REWIND IOUNIT C CLOSE(IOUNIT) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CLFI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCLFI') WRITE(ICOUT,9011) CALL EDWRST('EDCLFI') 9011 FORMAT('***** AT THE END OF EDCLFI--') WRITE(ICOUT,9012)IOUNIT CALL EDWRST('EDCLFI') 9012 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9013)IENDFI CALL EDWRST('EDCLFI') 9013 FORMAT('IENDFI = ',A4) WRITE(ICOUT,9014)IENDFI CALL EDWRST('EDCLFI') 9014 FORMAT('IENDFI = ',A4) 9090 CONTINUE C RETURN END SUBROUTINE EDCLOS C C PURPOSE--CLOSE A FILE C NOTE--IF NO ARGUMENTS GIVEN, C THE THE DEFAULT PRINTER FILE WILL BE CLOSED. C --IF 1 ARGUMENT GIVEN (PRESUMEDLY A FILE NAME), C THEN THAT FILE WILL BE CLOSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CCCCC CHARACTER*80 IREC CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLI' ISUBN2='ST ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCLOS') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCLOS') 51 FORMAT('***** AT THE BEGINNING OF EDCLOS--') WRITE(ICOUT,53)IOPENU CALL EDWRST('EDCLOS') 53 FORMAT('IOPENU = ',I8) WRITE(ICOUT,54)IOPENA CALL EDWRST('EDCLOS') 54 FORMAT('IOPENA = ',A80) WRITE(ICOUT,55)IOPEST CALL EDWRST('EDCLOS') 55 FORMAT('IOPEST = ',A12) WRITE(ICOUT,56)IOPEFO CALL EDWRST('EDCLOS') 56 FORMAT('IOPEFO = ',A12) WRITE(ICOUT,57)IOPEAC CALL EDWRST('EDCLOS') 57 FORMAT('IOPEAC = ',A12) WRITE(ICOUT,58)IOPERW CALL EDWRST('EDCLOS') 58 FORMAT('IOPERW = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDCLOS') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT IS TO BE CLOSED ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE ISTAT='UNKNOWN' GOTO1190 C 1120 CONTINUE IFILE=IOPENA ISTAT=IOPEST GOTO1190 C 1190 CONTINUE IOUNIT=IOPENU IFORM=IOPEFO IACCES=IOPEAC IREWR=IOPERW ISUBN0='OPEN' IERRFI='NO' C C ********************** C ** STEP 12-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C **************************** C ** STEP 13-- ** C ** WRITE OUT A MESSAGE ** C ** IDENTIFYING THE FILE ** C **************************** C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL EDWRST('EDCLOS') WRITE(ICOUT,1305)IFILE CALL EDWRST('EDCLOS') 1305 FORMAT(10X,'FILE = ',A80) WRITE(ICOUT,999) CALL EDWRST('EDCLOS') C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCLOS') WRITE(ICOUT,9011) CALL EDWRST('EDCLOS') 9011 FORMAT('***** AT THE END OF EDCLOS--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDCLOS') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDCLOS') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDCLOS') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDCLOS') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCOIH(IVAL,IHOUT,NOUT,IVALID) C C PURPOSE--CONVERT AN INTEGER VARIABLE C TO A LEFT-JUSTIFIED CHARACTER*10 CHARACTER STRING C THIS SUBROUTINE IS VALID FOR (POSITIVE OR C NEGATIVE) INTEGERS UP TO 9 DIGITS. C C ORIGINAL VERSION--JULY 1986. C C--------------------------------------------------------------------- C CHARACTER*10 IHOUT CHARACTER*4 IVALID C CHARACTER*4 ISIGN CHARACTER*4 IHDIG C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C C MAXDIG IS THE MAXIMUM NUMBER OF DIGITS C FOR AN INTEGER VARIABLE. C THIS WILL VARY FROM ONE COMPUTER TO THE NEXT C DEPENDING ON THE NUMBER OF BITS FOR A WORD. C THE FOLLOWING DEFINED VALUE (= 10) C HAS BEEN SET FOR THE VAX 11/780. C CCCCC MAXDIG=11 MAXDIG=9 NUMDIG=(-999) IHOUT=' ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COIH')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCOIH') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCOIH') 51 FORMAT('***** AT THE BEGINNING OF EDCOIH--') WRITE(ICOUT,52)IBUGE2,ISUBRO,IERROR CALL EDWRST('EDCOIH') 52 FORMAT('IBUGE2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) WRITE(ICOUT,53)IVAL CALL EDWRST('EDCOIH') 53 FORMAT('IVAL = ',I11) WRITE(ICOUT,54)NUMDIG CALL EDWRST('EDCOIH') 54 FORMAT('NUMDIG = ',I8) WRITE(ICOUT,55)(IHOUT(I:I),I=1,NOUT) CALL EDWRST('EDCOIH') 55 FORMAT('IHOUT(.) = ',80A1) 90 CONTINUE C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C IERROR='NO' IVALID='YES' IVAL2=IVAL C C *********************** C ** STEP 2-- ** C ** DETERMINE SIGN. ** C *********************** C ISIGN='+' IF(IVAL2.LT.0)ISIGN='-' IVAL2=IABS(IVAL2) C C *********************************** C ** STEP 3-- ** C ** DETERMINE NUMBER OF DIGITS. ** C *********************************** C IMIN=1 IMAX=MAXDIG DO300I=IMIN,IMAX IREV=IMAX-I+IMIN IDIV=10**(IREV-1) IDIG=IVAL2/IDIV IF(IDIG.NE.0)GOTO350 300 CONTINUE NUMDIG=1 GOTO390 350 CONTINUE NUMDIG=IREV 390 CONTINUE C C *************************************** C ** STEP 4-- ** C ** IF NEGATIVE, ** C ** INSERT SIGN INTO OUTPUT VECTOR. ** C *************************************** C J=0 IF(ISIGN.EQ.'-')J=J+1 IF(ISIGN.EQ.'-')IHOUT(J:J)='-' C C ************************** C ** STEP 5-- ** C ** INSERT DIGITS INTO ** C ** OUTPUT VECTOR. ** C ************************** C IMIN=1 IMAX=NUMDIG DO500I=IMIN,IMAX IREV=IMAX-I+IMIN IDIV=10**(IREV-1) IDIG=IVAL2/IDIV C IF(IDIG.EQ.0)GOTO510 IF(IDIG.EQ.1)GOTO511 IF(IDIG.EQ.2)GOTO512 IF(IDIG.EQ.3)GOTO513 IF(IDIG.EQ.4)GOTO514 IF(IDIG.EQ.5)GOTO515 IF(IDIG.EQ.6)GOTO516 IF(IDIG.EQ.7)GOTO517 IF(IDIG.EQ.8)GOTO518 IF(IDIG.EQ.9)GOTO519 510 CONTINUE IHDIG='0' GOTO529 511 CONTINUE IHDIG='1' GOTO529 512 CONTINUE IHDIG='2' GOTO529 513 CONTINUE IHDIG='3' GOTO529 514 CONTINUE IHDIG='4' GOTO529 515 CONTINUE IHDIG='5' GOTO529 516 CONTINUE IHDIG='6' GOTO529 517 CONTINUE IHDIG='7' GOTO529 518 CONTINUE IHDIG='8' GOTO529 519 CONTINUE IHDIG='9' GOTO529 529 CONTINUE C J=J+1 IHOUT(J:J)=IHDIG IVAL2=IVAL2-IDIG*IDIV 500 CONTINUE NOUT=J C C **************** C ** STEP 6-- ** C ** EXIT. ** C **************** C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COIH')GOTO9090 WRITE(ICOUT,9011) CALL EDWRST('EDCOIH') 9011 FORMAT('***** AT THE END OF EDCOIH--') WRITE(ICOUT,9012)IBUGE2,ISUBRO,IERROR CALL EDWRST('EDCOIH') 9012 FORMAT('IBUGE2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) WRITE(ICOUT,9013)IVAL CALL EDWRST('EDCOIH') 9013 FORMAT('IVAL = ',I11) WRITE(ICOUT,9014)NOUT CALL EDWRST('EDCOIH') 9014 FORMAT('NOUT = ',I11) WRITE(ICOUT,9015)(IHOUT(I:I),I=1,NOUT) CALL EDWRST('EDCOIH') 9015 FORMAT('IHOUT(.) = ',80A1) 9090 CONTINUE C RETURN END SUBROUTINE EDCOP1 C C PURPOSE--COPY THE TEXT BLOCK OUT TO FILE C TREAT THE 2 CASES-- C COPY C COPY JUNK. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. CCCCC UPDATED --APRIL 1993. FORMAT CHANGED FROM 80 TO 130 C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCO' ISUBN2='P1 ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP1')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCOP1') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCOP1') 51 FORMAT('***** AT THE BEGINNING OF EDCOP1--') WRITE(ICOUT,52)IBLIM1,IBLIM2 CALL EDWRST('EDCOP1') 52 FORMAT('IBLIM1,IBLIM2 = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ***************************************** C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE BLOCK IS TO BE COPIED TO ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ***************************************** C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE ISTAT='UNKNOWN' GOTO1190 C 1120 CONTINUE IFILE=ICOPNA ISTAT=ICOPST GOTO1190 C 1190 CONTINUE IOUNIT=ICOPNU IFORM=ICOPFO IACCES=ICOPAC IREWR=ICOPRW ISUBN0='COP1' IERRFI='NO' C C ********************* C ** STEP 12-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C C ********************************** C ** STEP 21-- ** C ** SPECIFY THE END LINE ** C ** OF THE BLOCK OF TEXT ** C ** TO BE OPERATED ON ** C ** (COPIED, MOVED, ETC.) ** C ********************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC IBLIM2=ICURLN C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1')THEN WRITE(ICOUT,2111)IBLIM1,IBLIM2 CALL EDWRST('EDCOP1') ENDIF 2111 FORMAT('IBLIM1,IBLIM2 = ',2I8) C C **************************************************** C ** STEP 22-- ** C ** WRITE TEXT BLOCK OUT TO FILE ** C **************************************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IMIN=IBLIM1 IMAX=IBLIM2 IF(IMIN.LT.1)IMIN=1 IF(IMAX.GT.NUMLIN)IMAX=NUMLIN C IF(IMIN.GT.IMAX)GOTO2290 DO2200ILINE=IMIN,IMAX IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) WRITE(IOUNIT,2205)(ICHA(J),J=J1,J2) CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 C2205 FORMAT(80A1) 2205 FORMAT(238A1) IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1')THEN WRITE(ICOUT,2206)J1,J2,(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP1') ENDIF 2206 FORMAT('J1,J2,(ICHA(J),J=J1,J2) = ',2I8,2X,80A1) 2200 CONTINUE C 2290 CONTINUE ICURLN=IMAX C C *************************** C ** STEP 23-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFEESW.EQ.'OFF')GOTO2329 C WRITE(ICOUT,999) CALL EDWRST('EDCOP1') IDEL=IMAX-IMIN+1 ILINE=IMIN-1 DO2320IPASS=1,10000 ILINE=ILINE+1 IF(IPASS.GE.2.AND.IDEL.GE.11)ILINE=IMAX IF(ILINE.LT.1)GOTO2325 IF(ILINE.GT.IMAX)GOTO2325 IF(ILINE.GT.NUMLIN)GOTO2325 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2321)(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP1') ENDIF 2321 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2322)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP1') ENDIF 2322 FORMAT(I6,':',3X,230A1) 2325 CONTINUE IF(IPASS.GE.2.AND.IDEL.GE.11)GOTO2328 2320 CONTINUE 2328 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCOP1') 2329 CONTINUE C C ********************** C ** STEP 31-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP1') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC ENDFILE IOUNIT CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='ON' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP1')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCOP1') WRITE(ICOUT,9011) CALL EDWRST('EDCOP1') 9011 FORMAT('***** AT THE END OF EDCOP1--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDCOP1') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDCOP1') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDCOP1') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDCOP1') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,9017)ICURLN,IFOUEX CALL EDWRST('EDCOP1') 9017 FORMAT('ICURLN,IFOUEX = ',I8,2X,A4) WRITE(ICOUT,9018)IBLIM1,IBLIM2,IMIN,IMAX CALL EDWRST('EDCOP1') 9018 FORMAT('IBLIM1,IBLIM2,IMIN,IMAX = ',4I8) WRITE(ICOUT,999) CALL EDWRST('EDCOP1') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCOP2 C C PURPOSE--COPY AN INTERNALLY SPECIFIED TEXT BLOCK C OUT TO THE DEFAULT FILE (EDCOPY.TEX) OR C OUT TO A USER-SPECIFIED FILE. C TREAT THE 2 CASES-- C COPY 5 7 C COPY JUNK. 5 7 C NOTE--THE CASE COPY 5 7 JUNK. IS ONLY PARTIALLY SUPPORTED. C STEP 21 (EXTRACTING THE FILE NAME) WOULD NEED TO BE UPDATED C IN ORDER TO MAKE THIS FORM WORK.) C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. CCCCC UPDATED --APRIL 1993. FORMAT CHANGED FROM 80 TO 130 C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCO' ISUBN2='P2 ' C IFOUND='YES' IERROR='NO' C ISTART=(-999) ISTOP=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCOP2') 51 FORMAT('***** AT THE BEGINNING OF EDCOP2--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 11-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS OF THE BLOCK. ** C ************************************ C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.2)GOTO1120 GOTO1140 C 1120 CONTINUE IF(IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')GOTO1130 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') WRITE(ICOUT,1121) CALL EDWRST('EDCOP2') 1121 FORMAT('***** ERROR IN COPY COMMAND--') WRITE(ICOUT,1122) CALL EDWRST('EDCOP2') 1122 FORMAT(' FOR THIS FORM OF THE COPY COMMAND,') WRITE(ICOUT,1123) CALL EDWRST('EDCOP2') 1123 FORMAT(' BOTH ARGUMENTS SHOULD BE NUMERIC,') WRITE(ICOUT,1124) CALL EDWRST('EDCOP2') 1124 FORMAT(' BUT WERE NOT.') WRITE(ICOUT,1125)IHARG(1),IHARG(2) CALL EDWRST('EDCOP2') 1125 FORMAT(' THE 2 ARGUMENTS ARE--',A4,2X,A4) WRITE(ICOUT,1126) CALL EDWRST('EDCOP2') 1126 FORMAT(' EXAMPLE OF PROPER FORM--') WRITE(ICOUT,1127) CALL EDWRST('EDCOP2') 1127 FORMAT(' COPY 5 7') IERROR='YES' GOTO9000 C 1130 CONTINUE ISTART=IARG(1) ISTOP=IARG(2) GOTO1180 C 1140 CONTINUE IF(IARGT(1).EQ.'WORD')GOTO1150 IF(IARGT(3).EQ.'WORD')GOTO1160 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') WRITE(ICOUT,1141) CALL EDWRST('EDCOP2') 1141 FORMAT('***** ERROR IN COPY COMMAND--') WRITE(ICOUT,1142) CALL EDWRST('EDCOP2') 1142 FORMAT(' FOR THIS FORM OF THE COPY COMMAND,') WRITE(ICOUT,1143) CALL EDWRST('EDCOP2') 1143 FORMAT(' ARGUMENT 1 OR 3 MUST BE A FILE NAME,') WRITE(ICOUT,1144) CALL EDWRST('EDCOP2') 1144 FORMAT(' BUT WERE NOT.') WRITE(ICOUT,1145)IHARG(1),IHARG(2),IHARG(3) CALL EDWRST('EDCOP2') 1145 FORMAT(' THE 3 ARGUMENTS ARE--',A4,2X,A4,2X,A4) WRITE(ICOUT,1146) CALL EDWRST('EDCOP2') 1146 FORMAT(' EXAMPLES OF PROPER FORM--') WRITE(ICOUT,1147) CALL EDWRST('EDCOP2') 1147 FORMAT(' COPY JUNK. 5 7') WRITE(ICOUT,1148) CALL EDWRST('EDCOP2') 1148 FORMAT(' COPY 5 7 JUNK.') IERROR='YES' GOTO9000 C 1150 CONTINUE IF(IARGT(2).EQ.'NUMB'.AND.IARGT(3).EQ.'NUMB')GOTO1159 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') WRITE(ICOUT,1151) CALL EDWRST('EDCOP2') 1151 FORMAT('***** ERROR IN COPY COMMAND--') WRITE(ICOUT,1152) CALL EDWRST('EDCOP2') 1152 FORMAT(' FOR THIS FORM OF THE COPY COMMAND,') WRITE(ICOUT,1153) CALL EDWRST('EDCOP2') 1153 FORMAT(' ARGUMENTS 2 AND 3 MUST BE NUMERIC,') WRITE(ICOUT,1154) CALL EDWRST('EDCOP2') 1154 FORMAT(' BUT WERE NOT.') WRITE(ICOUT,1155)IHARG(2),IHARG(3) CALL EDWRST('EDCOP2') 1155 FORMAT(' THE 2 ARGUMENTS ARE--',A4,2X,A4) WRITE(ICOUT,1156) CALL EDWRST('EDCOP2') 1156 FORMAT(' EXAMPLE OF PROPER FORM--') WRITE(ICOUT,1157) CALL EDWRST('EDCOP2') 1157 FORMAT(' COPY JUNK. 5 7') IERROR='YES' GOTO9000 1159 CONTINUE ISTART=IARG(2) ISTOP=IARG(3) GOTO1180 C 1160 CONTINUE IF(IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')GOTO1169 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') WRITE(ICOUT,1161) CALL EDWRST('EDCOP2') 1161 FORMAT('***** ERROR IN COPY COMMAND--') WRITE(ICOUT,1162) CALL EDWRST('EDCOP2') 1162 FORMAT(' FOR THIS FORM OF THE COPY COMMAND,') WRITE(ICOUT,1163) CALL EDWRST('EDCOP2') 1163 FORMAT(' ARGUMENTS 1 AND 2 MUST BE NUMERIC,') WRITE(ICOUT,1164) CALL EDWRST('EDCOP2') 1164 FORMAT(' BUT WERE NOT.') WRITE(ICOUT,1165)IHARG(1),IHARG(2) CALL EDWRST('EDCOP2') 1165 FORMAT(' THE 2 ARGUMENTS ARE--',A4,2X,A4) WRITE(ICOUT,1166) CALL EDWRST('EDCOP2') 1166 FORMAT(' EXAMPLE OF PROPER FORM--') WRITE(ICOUT,1167) CALL EDWRST('EDCOP2') 1167 FORMAT(' COPY 5 7 JUNK.') IERROR='YES' GOTO9000 1169 CONTINUE ISTART=IARG(1) ISTOP=IARG(2) GOTO1180 C 1180 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ***************************************** C ** STEP 21-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE BLOCK IS TO BE COPIED TO ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ***************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB')GOTO2120 CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO2110 GOTO2120 C 2110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO2119 DO2111I=1,NUMCST IF(ISTRIN(I).EQ.' ')GOTO2119 IFILE(I:I)=ISTRIN(I) 2111 CONTINUE 2119 CONTINUE ISTAT='UNKNOWN' GOTO2190 C 2120 CONTINUE IFILE=ICOPNA ISTAT=ICOPST GOTO2190 C 2190 CONTINUE IOUNIT=ICOPNU IFORM=ICOPFO IACCES=ICOPAC IREWR=ICOPRW ISUBN0='COP2' IERRFI='NO' C C ********************* C ** STEP 22-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C C **************************************************** C ** STEP 31-- ** C ** WRITE TEXT BLOCK OUT TO FILE ** C **************************************************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IMIN=ISTART IMAX=ISTOP IF(IMIN.LT.1)IMIN=1 IF(IMAX.GT.NUMLIN)IMAX=NUMLIN C IF(IMIN.GT.IMAX)GOTO3190 DO3100ILINE=IMIN,IMAX IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) WRITE(IOUNIT,3105)(ICHA(J),J=J1,J2) CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 C3105 FORMAT(80A1) 3105 FORMAT(238A1) 3100 CONTINUE C 3190 CONTINUE ENDFILE IOUNIT REWIND IOUNIT C C *************************** C ** STEP 32-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='32' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFEESW.EQ.'OFF')GOTO3229 C WRITE(ICOUT,999) CALL EDWRST('EDCOP2') IDEL=IMAX-IMIN+1 ILINE=IMIN-1 DO3220IPASS=1,10000 ILINE=ILINE+1 IF(IPASS.GE.2.AND.IDEL.GE.11)ILINE=IMAX IF(ILINE.LT.1)GOTO3225 IF(ILINE.GT.IMAX)GOTO3225 IF(ILINE.GT.NUMLIN)GOTO3225 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,3221)(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP2') ENDIF 3221 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,3222)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP2') ENDIF 3222 FORMAT(I6,':',3X,230A1) 3225 CONTINUE IF(IPASS.GE.2.AND.IDEL.GE.11)GOTO3228 3220 CONTINUE 3228 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCOP2') 3229 CONTINUE C C ********************** C ** STEP 41-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP2') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC ENDFILE IOUNIT CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='ON' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCOP2') WRITE(ICOUT,9011) CALL EDWRST('EDCOP2') 9011 FORMAT('***** AT THE END OF EDCOP2--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDCOP2') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDCOP2') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDCOP2') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDCOP2') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,9017)ICURLN,IFOUND CALL EDWRST('EDCOP2') 9017 FORMAT('ICURLN,IFOUND = ',I8,2X,A4) WRITE(ICOUT,9018)ISTART,ISTOP,IMIN,IMAX,IDEL CALL EDWRST('EDCOP2') 9018 FORMAT('ISTART,ISTOP,IMIN,IMAX,IDEL = ',5I8) WRITE(ICOUT,999) CALL EDWRST('EDCOP2') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCOP3 C C PURPOSE--COPY THE TEXT BLOCK IN LINES ARG1 TO ARG2 C OUT TO EDCOPY.TEX AND THEN C INSERT THE BLOCK AFTER LINE ARG3. C TREAT THE 1 CASE-- C COPY 5 7 10 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. CCCCC UPDATED --APRIL 1993. FORMAT CHANGED FROM 80 TO 130 C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC CHARACTER*80 IREC CHARACTER*240 IREC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCO' ISUBN2='P3 ' C IFOUND='YES' IERROR='NO' C ISTART=(-999) ISTOP=(-999) ITARG=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP3')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCOP3') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCOP3') 51 FORMAT('*****AT THE BEGINNING OF EDCOP3--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 11-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS OF THE BLOCK. ** C ** DETERMINE THE LINE NUMBER ** C ** AFTER WHICH THE BLOCK IS ** C ** TO BE MOVED. ** C ************************************ C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IARGT(1).EQ.'NUMB'.AND.IARGT(2).EQ.'NUMB'.AND. 1 IARGT(3).EQ.'NUMB')GOTO1120 C WRITE(ICOUT,999) CALL EDWRST('EDCOP3') WRITE(ICOUT,1111) CALL EDWRST('EDCOP3') 1111 FORMAT('***** ERROR IN COPY COMMAND--') WRITE(ICOUT,1112) CALL EDWRST('EDCOP3') 1112 FORMAT(' ONE OF THE 3 ARGUMENTS IS NON-NUMERIC') IERROR='YES' GOTO9000 C 1120 CONTINUE ISTART=IARG(1) ISTOP=IARG(2) ITARG=IARG(3) C IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ***************************************** C ** STEP 12-- ** C ** DEFINE THE NAME OF THE FILE ** C ** THAT THE BLOCK IS TO BE COPIED TO ** C ** (USE THE DEFAULT FILE NAME). ** C ***************************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IFILE=ICOPNA ISTAT=ICOPST IOUNIT=ICOPNU IFORM=ICOPFO IACCES=ICOPAC IREWR=ICOPRW ISUBN0='COP3' IERRFI='NO' C C ********************* C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C C **************************************************** C ** STEP 21-- ** C ** WRITE TEXT BLOCK OUT TO FILE ** C **************************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IMIN=ISTART IMAX=ISTOP IF(IMIN.LT.1)IMIN=1 IF(IMAX.GT.NUMLIN)IMAX=NUMLIN C IF(IMIN.GT.IMAX)GOTO2190 DO2100ILINE=IMIN,IMAX IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) WRITE(IOUNIT,2105)(ICHA(J),J=J1,J2) CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 C2105 FORMAT(80A1) 2105 FORMAT(238A1) 2100 CONTINUE C 2190 CONTINUE ENDFILE IOUNIT REWIND IOUNIT C C ***************************************** C ** STEP 31-- ** C ** SET UP A LOOP ** C ** THAT WILL READ ONE LINE AT A TIME ** C ** FROM THE FILE ** C ** AND INSERT IT AT THE PROPER POINT ** C ** IN THE WORKSPACE ** C ***************************************** C ISTEPN='31' IF(IBUGE3.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLN=ITARG C DO3100IDUMMY=1,100000 C C ************************************ C ** STEP 32-- ** C ** READ IN A LINE FROM THE FILE ** C ************************************ C CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 CCCCC NUMCRE=80 NUMCRE=238 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,3205,END=3190)IREC CCCCC THE FOLLOWING LINE WAS CHANGED APRIL 1993 C3205 FORMAT(A80) 3205 FORMAT(A238) C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,3206)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDCOP3') 3206 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,3207)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDCOP3') 3207 FORMAT('NUMCRE = ',I8) C DO3200I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO3290 3200 CONTINUE IREV=0 3290 CONTINUE NUMCRE=IREV C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,3295)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDCOP3') 3295 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,3296)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDCOP3') 3296 FORMAT('NUMCRE = ',I8) C C *************************************************** C ** STEP 33-- ** C ** DETERMINE IF THERE IS ROOM IN THE WORKSPACE ** C ** FOR THE NEW LINE ** C *************************************************** C NUMCH2=NUMCHA+NUMCRE CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C C ********************************************** C ** STEP 34-- ** C ** UPDATE THE WORKSPACE TABLES ** C ** AND INSERT THE LINE INTO THE WORKSPACE ** C ********************************************** C IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURLN+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO3419 IF(NUMLIN.LE.0)GOTO3419 IF(ICURLP.GT.NUMLIN)GOTO3419 DO3410ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 3410 CONTINUE 3419 CONTINUE C J1=NUMCHA+1 N1=NUMCRE J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO3420J=J1,J2 I=I+1 ICHA(J)=IREC(I:I) 3420 CONTINUE 3429 CONTINUE ICURLN=ICURLP NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 C 3100 CONTINUE 3190 CONTINUE C C *************************** C ** STEP 35-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='35' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFEESW.EQ.'OFF')GOTO2529 C WRITE(ICOUT,999) CALL EDWRST('EDCOP3') IMIN=ITARG+1 IMAX=ICURLN IDEL=IMAX-IMIN+1 ILINE=IMIN-1 DO2520IPASS=1,10000 ILINE=ILINE+1 IF(IPASS.GE.2.AND.IDEL.GE.11)ILINE=IMAX IF(ILINE.LT.1)GOTO2525 IF(ILINE.GT.IMAX)GOTO2525 IF(ILINE.GT.NUMLIN)GOTO2525 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2521)(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP3') ENDIF 2521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDCOP3') ENDIF 2522 FORMAT(I6,':',3X,230A1) 2525 CONTINUE IF(IPASS.GE.2.AND.IDEL.GE.11)GOTO2528 2520 CONTINUE 2528 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDCOP3') 2529 CONTINUE C C ********************** C ** STEP 41-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COP3') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC ENDFILE IOUNIT CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='ON' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COP3')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCOP3') WRITE(ICOUT,9011) CALL EDWRST('EDCOP3') 9011 FORMAT('*****AT THE END OF EDCOP3--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDCOP3') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDCOP3') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDCOP3') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDCOP3') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,9017)ICURLN,IFOUND CALL EDWRST('EDCOP3') 9017 FORMAT('ICURLN,IFOUND = ',I8,2X,A4) WRITE(ICOUT,9018)IBLIM1,IBLIM2,IMIN,IMAX CALL EDWRST('EDCOP3') 9018 FORMAT('IBLIM1,IBLIM2,IMIN,IMAX = ',4I8) WRITE(ICOUT,999) CALL EDWRST('EDCOP3') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDCOST(ICTEMP,NCTEMP) C C PURPOSE--CONVERT THE STRING IN THE CHARACTER*240 C STRING VARIABLE INTO THE DIMENSIONED (240) C CHARACTER*1 VARIABLE IANS(.). C ADJUST IWIDTH ALSO. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.7 C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICTEMP C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCO' ISUBN2='ST ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COST')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCOST') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCOST') 51 FORMAT('***** AT THE BEGINNING OF EDCOST--') WRITE(ICOUT,52)NCTEMP CALL EDWRST('EDCOST') 52 FORMAT('NCTEMP = ',I8) IF(NCTEMP.GE.1)THEN WRITE(ICOUT,53)(ICTEMP(I:I),I=1,NCTEMP) CALL EDWRST('EDCOST') ENDIF 53 FORMAT('(ICTEMP(I:I),I=1,NCTEMP) = ',110A1) WRITE(ICOUT,62)IWIDTH CALL EDWRST('EDCOST') 62 FORMAT('IWIDTH = ',I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,63)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDCOST') ENDIF 63 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,999) CALL EDWRST('EDCOST') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************** C ** STEP 1-- ** C ** CONVERT THE STRING ** C ************************** C DO1100I=1,240 IANS(I)=' ' 1100 CONTINUE C IMAX=NCTEMP IF(IMAX.LT.0)IMAX=0 IF(IMAX.GT.240)IMAX=240 IWIDTH=IMAX IF(IMAX.LE.0)GOTO1290 DO1200I=1,IMAX IANS(I)=ICTEMP(I:I) 1200 CONTINUE 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'COST')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCOST') WRITE(ICOUT,9011) CALL EDWRST('EDCOST') 9011 FORMAT('***** AT THE END OF EDCOST--') WRITE(ICOUT,9012)NCTEMP CALL EDWRST('EDCOST') 9012 FORMAT('NCTEMP = ',I8) IF(NCTEMP.GE.1)THEN WRITE(ICOUT,9013)(ICTEMP(I:I),I=1,NCTEMP) CALL EDWRST('EDCOST') ENDIF 9013 FORMAT('(ICTEMP(I:I),I=1,NCTEMP) = ',110A1) WRITE(ICOUT,9022)IWIDTH CALL EDWRST('EDCOST') 9022 FORMAT('IWIDTH = ',I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9023)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDCOST') ENDIF 9023 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9032)IMAX CALL EDWRST('EDCOST') 9032 FORMAT('IMAX = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDCOST') IF(IBUGT1.EQ.'ON')CALL EDTRA1 9090 CONTINUE C RETURN END SUBROUTINE EDCUT C C PURPOSE--CUT CURRENT FROM STRING TO END OF LINE. C THE STRING WHICH FOLLOWS THE SPLIT COMMAND C WILL BE INCLUDED IN THE CUT. C NOTE--IN THE EVENT THAT THERE IS MORE THAN C ONE OCCURRANCE OF THE STRING ON THE LINE, C THE CUTTING WILL BE DONE FROM THE C LAST SUCH OCCURRANCE. C COMMAND SYNTAX--CUT C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.6 C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICLINE CHARACTER*240 ICNEWL CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 IFEES2 C CHARACTER*4 IEOF C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCU' ISUBN2='T ' C IFOUND='YES' IERROR='NO' C IEOF='NO' IARG1=(-999) IARG2=(-999) J=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDCUT ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDCUT ') 51 FORMAT('*****AT THE BEGINNING OF EDCUT--') WRITE(ICOUT,52)IPRISW,ICURLN CALL EDWRST('EDCUT ') 52 FORMAT('IPRISW,ICURLN = ',A4,I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************************** C ** STEP 11-- ** C ** SET THE LINE NUMBER ** C ** TO BE OPERATED ON. ** C ********************************************** C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ISTART C IF(ISTART.LE.0)ISTART=1 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C C *************************** C ** STEP 21-- ** C ** EXTRACT THE LINE. ** C *************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(N1.LE.0)GOTO9000 J=J1-1 DO2100I=1,N1 J=J+1 ICLINE(I:I)=ICHA(J) 2100 CONTINUE NCLINE=N1 C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO2199 WRITE(ICOUT,2191)NUMCST CALL EDWRST('EDCUT ') 2191 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,2192)(ISTRIN(I),I=1,100) CALL EDWRST('EDCUT ') ENDIF 2192 FORMAT('(ISTRIN(I),I=1,100) = ',100A1) 2199 CONTINUE C C ************************************ C ** STEP 22-- ** C ** EXTRACT THE TARGET STRING ** C ** FROM THE COMMAND LINE. ** C ************************************ C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) IF(IFOUST.EQ.'YES')GOTO2290 NUMCST=0 C 2290 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO2299 WRITE(ICOUT,2291)NUMCST CALL EDWRST('EDCUT ') 2291 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,2292)(ISTRIN(I),I=1,100) CALL EDWRST('EDCUT ') ENDIF 2292 FORMAT('(ISTRIN(I),I=1,100) = ',100A1) 2299 CONTINUE C ********************************************* C ** STEP 23-- ** C ** DETERMINE THE LAST OCCURRANCE OF ** C ** THE TARGET STRING ON THE CURRENT LINE. ** C ********************************************* C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IC1=(-999) DO2310I=1,NCLINE I2=I DO2320J=1,NUMCST IJ=I+J-1 IF(ICLINE(IJ:IJ).EQ.ISTRIN(J))GOTO2320 GOTO2310 2320 CONTINUE IC1=I2-1 2310 CONTINUE IF(IC1.LE.(-1))GOTO9000 C 2390 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO2399 WRITE(ICOUT,2391)IC1 CALL EDWRST('EDCUT ') 2391 FORMAT('IC1 = ',I8) 2399 CONTINUE C C ******************************************* C ** STEP 24-- ** C ** FORM THE NEW LINE ** C ******************************************* C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDZERO(ICNEWL,NCNEWL) IF(IC1.LE.0)NCNEWL=1 IF(IC1.LE.0)GOTO2490 C DO2410I=1,IC1 IP=I ICNEWL(IP:IP)=ICLINE(I:I) 2410 CONTINUE NCNEWL=IP C 2490 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO2499 WRITE(ICOUT,2491)NCNEWL CALL EDWRST('EDCUT ') 2491 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,2492)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDCUT ') ENDIF 2492 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) 2499 CONTINUE IF(NCNEWL.LE.0)GOTO9000 C C ********************************************* C ** STEP 31-- ** C ** INSERT THE CORRECT (CUT) LINE ** C ** IMMEDIATELY AFTER THE ORIGINAL LINE. ** C ********************************************* C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURL2=ISTOP CALL EDINLI(ICNEWL,NCNEWL,ICURL2) ISTAR2=ICURL2 ISTOP2=ICURL2 C C *********************************************** C ** STEP 32-- ** C ** DELETE THE OLD (ORIGINAL) LINE. ** C *********************************************** C ISTEPN='32' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IFEES2='OFF' CALL EDDELI(ISTART,IFEES2) CCCCC IDELSW='OFF' CCCCC IDELLN='-999' C C *********************************************** C ** STEP 33-- ** C ** PRINT THE NEW (CUT) LINE. ** C *********************************************** C ISTEPN='33' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IDEL=ISTOP-ISTART+1 ISTAR3=ISTAR2-IDEL ISTOP3=ISTOP2-IDEL DO3300ILINE=ISTAR3,ISTOP3 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(N1.LE.0)GOTO3300 J=J1-1 DO3310I=1,N1 J=J+1 ICNEWL(I:I)=ICHA(J) 3310 CONTINUE NCNEWL=N1 IF(IFEESW.EQ.'ON')CALL EDWRLI(ICNEWL,NCNEWL,ILINE) 3300 CONTINUE C C *********************************************** C ** STEP 34-- ** C ** SET THE CURRENT LINE POSITION. ** C *********************************************** C ISTEPN='33' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CUT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLN=ISTOP3 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CUT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDCUT ') WRITE(ICOUT,9011) CALL EDWRST('EDCUT ') 9011 FORMAT('*****AT THE END OF EDCUT--') WRITE(ICOUT,9012)ICURLN,ISTART,ISTOP CALL EDWRST('EDCUT ') 9012 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9013)IPRISW CALL EDWRST('EDCUT ') 9013 FORMAT('IPRISW = ',A4) WRITE(ICOUT,9014)ISTART,ISTOP,ISTAR2,ISTOP2 CALL EDWRST('EDCUT ') 9014 FORMAT('ISTART,ISTOP,ISTAR2,ISTOP2 = ',4I8) WRITE(ICOUT,9015)IDEL,ISTAR3,ISTOP3,ICURLN CALL EDWRST('EDCUT ') 9015 FORMAT('IDEL,ISTAR3,ISTOP3,ICURLN = ',4I8) WRITE(ICOUT,9031)NCLINE CALL EDWRST('EDCUT ') 9031 FORMAT('NCLINE = ',I8) IF(NCLINE.GE.1)THEN WRITE(ICOUT,9032)(ICLINE(I:I),I=1,100) CALL EDWRST('EDCUT ') ENDIF 9032 FORMAT('(ICLINE(I:I),I=1,100) = ',100A1) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDDEBL(ISTRIN,NUMCST) C C PURPOSE--"DEBLANK" THE TRAILING BLANKS FROM A CHARACTER STRING. C DANGER--THE INPUT ARGUMENTS ISTRIN AND NUMCST C ARE BOTH CHANGED BY THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN DIMENSION ISTRIN(*) C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IF(IBUGMA.EQ.'OFF'.AND.ISUBRO.NE.'DEBL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDEBL') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDEBL') 51 FORMAT('***** AT THE BEGINNING OF EDDEBL--') WRITE(ICOUT,52)IBUGMA,IERROR CALL EDWRST('EDDEBL') 52 FORMAT('IBUGMA,IERROR = ',A4,2X,A4) WRITE(ICOUT,53)NUMCST CALL EDWRST('EDDEBL') 53 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)WRITE(ICOUT,54)(ISTRIN(I),I=1,NUMCST) IF(NUMCST.GE.1)CALL EDWRST('EDDEBL') 54 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',80A1) 90 CONTINUE C DO1100I=1,NUMCST IREV=NUMCST-I+1 IF(ISTRIN(IREV).NE.' ')GOTO1190 1100 CONTINUE IREV=0 1190 CONTINUE NUMCST=IREV C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C C 9000 CONTINUE IF(IBUGMA.EQ.'OFF'.AND.ISUBRO.NE.'DEBL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDEBL') WRITE(ICOUT,9011) CALL EDWRST('EDDEBL') 9011 FORMAT('***** AT THE END OF EDDEBL--') WRITE(ICOUT,9012)IBUGMA,IERROR CALL EDWRST('EDDEBL') 9012 FORMAT('IBUGMA,IERROR = ',A4,2X,A4) WRITE(ICOUT,9013)NUMCST CALL EDWRST('EDDEBL') 9013 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)WRITE(ICOUT,9014)(ISTRIN(I),I=1,NUMCST) IF(NUMCST.GE.1)CALL EDWRST('EDDEBL') 9014 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',80A1) 9090 CONTINUE C RETURN END SUBROUTINE EDDEFI(IHARLC,IHARL2) C C PURPOSE--CREATE USER-DEFINED COMMANDS. C USED INPUT ARGUMENTS--IHARLC (A CHARACTER VECTOR) C --IHARL2 (A CHARACTER VECTOR) C --NUMARG C USED OUTPUT ARGUMENTS--ICOM3 C ICOM4 C ICOM5 C NUMCOM C NCOM5 C IFOUND C IERROR C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86/6 C ORIGINAL VERSION--JUNE 1986. C C-----NON-COMMON VARIABLES---------------------------------------- C CHARACTER*4 IHARLC CHARACTER*4 IHARL2 C CHARACTER*30 ICOM5J CHARACTER*4 IC4 CHARACTER*1 IC1 CHARACTER*4 IC4LC CHARACTER*1 IC1LC CHARACTER*30 ICTE30 C DIMENSION IHARLC(*) DIMENSION IHARL2(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDE' ISUBN2='FI ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDEFI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDEFI') 51 FORMAT('AT THE BEGINNING OF EDDEFI--') WRITE(ICOUT,53)IBUGE2,ISUBRO CALL EDWRST('EDDEFI') 53 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,55)NUMARG CALL EDWRST('EDDEFI') 55 FORMAT('NUMARG = ',I8) IF(NUMARG.LE.0)GOTO59 DO56I=1,NUMARG WRITE(ICOUT,57)I,IHARLC(I) CALL EDWRST('EDDEFI') 57 FORMAT('I,IHARLC(I) = ',I8,2X,A4) 56 CONTINUE 59 CONTINUE WRITE(ICOUT,61)NUMCOM CALL EDWRST('EDDEFI') 61 FORMAT('NUMCOM = ',I8) IF(NUMCOM.LE.0)GOTO69 DO62I=1,NUMCOM WRITE(ICOUT,63)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) CALL EDWRST('EDDEFI') 63 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ', 1I8,2X,A4,2X,A4,I8,A60) 62 CONTINUE 69 CONTINUE WRITE(ICOUT,81)IFOUND,IERROR CALL EDWRST('EDDEFI') 81 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 90 CONTINUE C C *************************************************** C ** STEP 11-- ** C ** DETERMINE THE ELEMENT NUMBER FOR THE COMMAND.** C ** IS IT AN EXISTING USER-DEFINED COMMAND? ** C ** IS IT A NEW USER-DEFINED COMMAND? ** C *************************************************** C IF(NUMARG.LE.0)GOTO1180 C I2=1 IF(NUMCOM.LE.0)GOTO1190 DO1100I=1,NUMCOM I2=I IF(IHARG(1).EQ.ICOM3(I).AND.IHARG2(1).EQ.ICOM4(I))GOTO1190 1100 CONTINUE I2=NUMCOM+1 GOTO1190 C 1180 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDEFI') WRITE(ICOUT,1181) CALL EDWRST('EDDEFI') 1181 FORMAT('***** ERROR IN SUBROUTINE EDDEFI--') WRITE(ICOUT,1182) CALL EDWRST('EDDEFI') 1182 FORMAT(' WHEN USING THE DEFINE COMMAND,') WRITE(ICOUT,1183) CALL EDWRST('EDDEFI') 1183 FORMAT(' YOU MUST HAVE SOME ENTRY') WRITE(ICOUT,1184) CALL EDWRST('EDDEFI') 1184 FORMAT(' AFTER THE WORD DEFINE ;') WRITE(ICOUT,1185) CALL EDWRST('EDDEFI') 1185 FORMAT(' BUT NONE WAS GIVEN HERE.') WRITE(ICOUT,1186)NUMARG CALL EDWRST('EDDEFI') 1186 FORMAT(' NUMARG = ',I8) IERROR='YES' GOTO9000 C 1190 CONTINUE C C ************************************************* C ** STEP 12-- ** C ** EXTRACT THE NAME OF THE COMMAND. ** C ************************************************* C ICOM3(I2)=IHARG(1) ICOM4(I2)=IHARG2(1) C C *************************************************** C ** STEP 12-- ** C ** EXTRACT THE ASCII SEQUENCE. ** C *************************************************** C ICTE30(1:30)=' ' ICOM5(I2)=ICTE30(1:30) NCOM5(I2)=0 C J=0 IF(NUMARG.LE.1)GOTO1290 DO1200I=2,NUMARG J=J+1 IC4=IHARG(I) IC1=IC4(1:1) C IC4LC=IHARLC(I) IC1LC=IC4LC(1:1) C IF(IC4(1:3).EQ.'NUL')IC1LC=INULC IF(IC4(1:3).EQ.'SOH')IC1LC=ISOHC IF(IC4(1:3).EQ.'STX')IC1LC=ISTXC IF(IC4(1:3).EQ.'ETX')IC1LC=IETXC IF(IC4(1:3).EQ.'EOT')IC1LC=IEOTC IF(IC4(1:3).EQ.'ENQ')IC1LC=IENQC IF(IC4(1:3).EQ.'ACK')IC1LC=IACKC IF(IC4(1:3).EQ.'BEL')IC1LC=IBELC IF(IC4(1:2).EQ.'BS')IC1LC=IBSC IF(IC4(1:3).EQ.'HTX')IC1LC=IHTC IF(IC4(1:2).EQ.'LF')IC1LC=ILFC IF(IC4(1:2).EQ.'VT')IC1LC=IVTC IF(IC4(1:2).EQ.'FF')IC1LC=IFFC IF(IC4(1:2).EQ.'CR')IC1LC=ICRC IF(IC4(1:2).EQ.'SO')IC1LC=ISOC IF(IC4(1:2).EQ.'SI')IC1LC=ISIC IF(IC4(1:3).EQ.'DLE')IC1LC=IDLEC IF(IC4(1:3).EQ.'DC1')IC1LC=IDC1C IF(IC4(1:3).EQ.'DC2')IC1LC=IDC2C IF(IC4(1:3).EQ.'DC3')IC1LC=IDC3C IF(IC4(1:3).EQ.'DC4')IC1LC=IDC4C IF(IC4(1:3).EQ.'NAK')IC1LC=INAKC IF(IC4(1:3).EQ.'SYN')IC1LC=ISYNC IF(IC4(1:3).EQ.'ETB')IC1LC=IETBC IF(IC4(1:3).EQ.'CAN')IC1LC=ICANC IF(IC4(1:2).EQ.'EM')IC1LC=IEMC IF(IC4(1:3).EQ.'SUB')IC1LC=ISUBC IF(IC4(1:3).EQ.'ESC')IC1LC=IESCC IF(IC4(1:2).EQ.'FS')IC1LC=IFSC IF(IC4(1:2).EQ.'GS')IC1LC=IGSC IF(IC4(1:2).EQ.'RS')IC1LC=IRSC IF(IC4(1:2).EQ.'US')IC1LC=IUSC IF(IC4(1:3).EQ.'BLA')IC1LC=' ' IF(IC4(1:2).EQ.'SP')IC1LC=' ' IF(IC4(1:3).EQ.'BLA')IC1LC=' ' IF(IC4(1:2).EQ.'BL')IC1LC=' ' C ICTE30(J:J)=IC1LC 1200 CONTINUE C 1290 CONTINUE ICOM5(I2)=ICTE30(1:30) NCOM5(I2)=J IF(I2.GT.NUMCOM)NUMCOM=I2 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DEFI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDEFI') WRITE(ICOUT,9011) CALL EDWRST('EDDEFI') 9011 FORMAT('AT THE END OF EDDEFI--') WRITE(ICOUT,9013)IBUGE2,ISUBRO CALL EDWRST('EDDEFI') 9013 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,9015)NUMARG CALL EDWRST('EDDEFI') 9015 FORMAT('NUMARG = ',I8) IF(NUMARG.LE.0)GOTO9019 DO9016I=1,NUMARG WRITE(ICOUT,9017)I,IHARG(I) CALL EDWRST('EDDEFI') 9017 FORMAT('I,IHARG(I) = ',I8,2X,A4) 9016 CONTINUE 9019 CONTINUE WRITE(ICOUT,9021)I2,NUMCOM CALL EDWRST('EDDEFI') 9021 FORMAT('I2,NUMCOM = ',2I8) WRITE(ICOUT,9022)I2,ICOM3(I2),ICOM4(I2),NCOM5(I2) CALL EDWRST('EDDEFI') 9022 FORMAT('I2,ICOM3(I2),ICOM4(I2),NCOM5(I2) = ', 1I8,2X,A4,2X,A4,I8) IMAX=NCOM5(I) IF(IMAX.LE.0)GOTO9033 ICOM5J=ICOM5(I) DO9031I=1,IMAX WRITE(ICOUT,9032)I,ICOM5J(I:I) CALL EDWRST('EDDEFI') 9032 FORMAT('I,ICOM5J(I:I) = ',I8,2X,A1) 9031 CONTINUE 9033 CONTINUE IF(NUMCOM.LE.0)GOTO9043 DO9041I=1,NUMCOM WRITE(ICOUT,9042)I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) CALL EDWRST('EDDEFI') 9042 FORMAT('I,ICOM3(I),ICOM4(I),NCOM5(I),ICOM5(I) = ', 1I8,2X,A4,2X,A4,I8,A30) 9041 CONTINUE 9043 CONTINUE WRITE(ICOUT,9051)IFOUND,IERROR CALL EDWRST('EDDEFI') 9051 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 9090 CONTINUE C RETURN END SUBROUTINE EDDELE C C PURPOSE--DELETE LINES OF TEXT. C IF NO ARGUMENTS, THEN DELETE CURRENT LINE. C IF 1 ARGUMENT , THEN DELETE CURRENT LINE C + NEXT (N-1) LINES; C THAT IS, DELETE RELATIVE. C IF 2 ARGUMENTS, THEN DELETE LINES N1 TO N2, C THAT IS, DELETE ABSOLUTE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ITOP CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDE' ISUBN2='LE ' C IFOUND='YES' IERROR='NO' C ITOP='NO' IEOF='NO' IARG1=(-999) IARG2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DELE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDELE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDELE') 51 FORMAT('*****AT THE BEGINNING OF EDDELE--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 WRITE(ICOUT,52)ICURLN,IDELSW,IDELLN CALL EDWRST('EDDELE') 52 FORMAT('ICURLN,IDELSW,IDELLN = ',I8,2X,A4,I8) 90 CONTINUE C C ********************************** C ** STEP 10-- ** C ** SAVE THE CURRENT POINTERS ** C ** (FOR POSSIBLE LATER USE ** C ** BY THE UNDO COMMAND) ** C ********************************** C ISTEPN='10' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSACP C C ************************************ C ** STEP 11-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE DELETED. ** C ************************************ C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ICURLN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ICURLN GOTO1190 C 1110 CONTINUE CCCCC IARG1=NUMLIN+1 IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) ISTART=ICURLN ISTOP=ISTART+IARG1-1 GOTO1190 C 1120 CONTINUE CCCCC IARG1=NUMLIN+1 IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) CCCCC IARG2=NUMLIN+1 IARG2=1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) ISTART=IARG1 ISTOP=IARG2 GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ************************************************ C ** STEP 21-- ** C ** WRITE OUT A MESSAGE ** C ** IF ATTEMPT TO DELETE BEFORE LINE 1, OR ** C ** IF ATTEMPT TO DELETE BEYOND LINE NUMLIN. ** C ************************************************ C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.GE.1)GOTO1219 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1211) CALL EDWRST('EDDELE') ENDIF 1211 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1212) CALL EDWRST('EDDELE') ENDIF 1212 FORMAT(10X,'[TOP]') 1219 CONTINUE C IF(ISTOP.LE.NUMLIN)GOTO1229 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1221) CALL EDWRST('EDDELE') ENDIF 1221 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1222) CALL EDWRST('EDDELE') ENDIF 1222 FORMAT(10X,'[BOTTOM]') 1229 CONTINUE C C **************************** C ** STEP 22-- ** C ** DELETE THE LINES. ** C **************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LT.1)ITOP='YES' IF(ISTOP.GT.NUMLIN)IEOF='YES' C IF(ISTART.LT.1.AND.ISTOP.LT.1)GOTO9000 IF(ISTART.GT.NUMLIN.AND.ISTOP.GT.NUMLIN)GOTO9000 C IF(ISTART.LT.1)ISTART=1 IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C IDEL=ISTOP-ISTART+1 ISTOPP=ISTOP+1 IF(ISTOPP.LE.0)GOTO1519 IF(ISTOPP.GT.NUMLIN)GOTO1519 DO1510ILINE=ISTOPP,NUMLIN ILINEM=ILINE-IDEL IF(ILINEM.GE.1)IPOINT(ILINEM)=IPOINT(ILINE) IPOINT(ILINE)=(-999) 1510 CONTINUE 1519 CONTINUE NUMLIN=NUMLIN-IDEL C IF(1.LE.ISTART.AND.ISTART.LE.NUMLIN)GOTO1520 GOTO1529 C 1520 CONTINUE CCCCC ILINE=ISTART-1 CCCCC IF(ILINE.LE.0)GOTO1529 CCCCC IROW=IPOINT(ILINE) CCCCC J1=ILOCC1(IROW) CCCCC N1=NUMCPL(IROW) CCCCC J2=J1+(N1-1) ILINE=ISTART 1529 CONTINUE C IF(IFEESW.EQ.'OFF')GOTO1539 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1533) 1533 FORMAT('[DELETED LINE]') CALL EDWRST('EDDELE') ENDIF IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1534)ILINE 1534 FORMAT(I6,':',3X,'[DELETED LINE]') CALL EDWRST('EDDELE') ENDIF 1539 CONTINUE ICURLN=ISTART IDELSW='ON' IDELLN=ICURLN GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DELE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDELE') WRITE(ICOUT,9011) CALL EDWRST('EDDELE') 9011 FORMAT('*****AT THE END OF EDDELE--') WRITE(ICOUT,9012)ITOP,IEOF,ISTART,ISTOP CALL EDWRST('EDDELE') 9012 FORMAT('ITOP,IEOF,ISTART,ISTOP = ',A4,2X,A4,2I8) WRITE(ICOUT,9013)ICURLN,IDELSW,IDELLN CALL EDWRST('EDDELE') 9013 FORMAT('ICURLN,IDELSW,IDELLN = ',I8,2X,A4,I8) WRITE(ICOUT,999) CALL EDWRST('EDDELE') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDDELI(ICURL2,IFEES2) C C PURPOSE--DELETE LINE ICURL2. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*4 IFEES2 C CHARACTER*4 ITOP CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDE' ISUBN2='LI ' C IFOUND='YES' IERROR='NO' C ITOP='NO' IEOF='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DELI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDELI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDELI') 51 FORMAT('*****AT THE BEGINNING OF EDDELI--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 WRITE(ICOUT,52)ICURL2,IDELSW,IDELLN CALL EDWRST('EDDELI') 52 FORMAT('ICURL2,IDELSW,IDELLN = ',I8,2X,A4,I8) WRITE(ICOUT,53)IFEES2 CALL EDWRST('EDDELI') 53 FORMAT('IFEES2 = ',A4) 90 CONTINUE C C ********************************** C ** STEP 10-- ** C ** SAVE THE CURRENT POINTERS ** C ** (FOR POSSIBLE LATER USE ** C ** BY THE UNDO COMMAND) ** C ********************************** C ISTEPN='10' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSACP C C ************************************ C ** STEP 11-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE DELETED. ** C ************************************ C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURL2 ISTOP=ICURL2 C C ************************************************ C ** STEP 21-- ** C ** WRITE OUT A MESSAGE ** C ** IF ATTEMPT TO DELETE BEFORE LINE 1, OR ** C ** IF ATTEMPT TO DELETE BEYOND LINE NUMLIN. ** C ************************************************ C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.GE.1)GOTO1219 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1211) CALL EDWRST('EDDELI') ENDIF 1211 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1212) CALL EDWRST('EDDELI') ENDIF 1212 FORMAT(10X,'[TOP]') 1219 CONTINUE C IF(ISTOP.LE.NUMLIN)GOTO1229 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1221) CALL EDWRST('EDDELI') ENDIF 1221 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1222) CALL EDWRST('EDDELI') ENDIF 1222 FORMAT(10X,'[BOTTOM]') 1229 CONTINUE C C **************************** C ** STEP 22-- ** C ** DELETE THE LINES. ** C **************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LT.1)ITOP='YES' IF(ISTOP.GT.NUMLIN)IEOF='YES' C IF(ISTART.LT.1.AND.ISTOP.LT.1)GOTO9000 IF(ISTART.GT.NUMLIN.AND.ISTOP.GT.NUMLIN)GOTO9000 C IF(ISTART.LT.1)ISTART=1 IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C IDEL=ISTOP-ISTART+1 ISTOPP=ISTOP+1 IF(ISTOPP.LE.0)GOTO1519 IF(ISTOPP.GT.NUMLIN)GOTO1519 DO1510ILINE=ISTOPP,NUMLIN ILINEM=ILINE-IDEL IF(ILINEM.GE.1)IPOINT(ILINEM)=IPOINT(ILINE) IPOINT(ILINE)=(-999) 1510 CONTINUE 1519 CONTINUE NUMLIN=NUMLIN-IDEL C IF(1.LE.ISTART.AND.ISTART.LE.NUMLIN)GOTO1520 GOTO1529 C 1520 CONTINUE CCCCC ILINE=ISTART-1 CCCCC IF(ILINE.LE.0)GOTO1529 CCCCC IROW=IPOINT(ILINE) CCCCC J1=ILOCC1(IROW) CCCCC N1=NUMCPL(IROW) CCCCC J2=J1+(N1-1) ILINE=ISTART 1529 CONTINUE C IF(IFEES2.EQ.'OFF')GOTO1539 IF(IFEESW.EQ.'OFF')GOTO1539 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1533) CALL EDWRST('EDDELI') ENDIF CCCCC WRITE(ICOUT,1533)(ICHA(J),J=J1,J2) C1533 FORMAT(238A1) 1533 FORMAT('[DELETED LINE]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1534)ILINE 1534 FORMAT(I6,':',3X,'[DELETED LINE]') CALL EDWRST('EDDELI') ENDIF 1539 CONTINUE ICURLN=ISTART CCCCC IDELSW='ON' CCCCC IDELLN=ICURLN GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DELI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDELI') WRITE(ICOUT,9011) CALL EDWRST('EDDELI') 9011 FORMAT('*****AT THE END OF EDDELI--') WRITE(ICOUT,9012)ITOP,IEOF,ISTART,ISTOP CALL EDWRST('EDDELI') 9012 FORMAT('ITOP,IEOF,ISTART,ISTOP = ',A4,2X,A4,2I8) WRITE(ICOUT,9013)ICURL2,IDELSW,IDELLN CALL EDWRST('EDDELI') 9013 FORMAT('ICURL2,IDELSW,IDELLN = ',I8,2X,A4,I8) WRITE(ICOUT,9014)IFEES2 CALL EDWRST('EDDELI') 9014 FORMAT('IFEES2 = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDDELI') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDDEMN(IMANUF,IMODEL) C C PURPOSE--SPECIFY DEVICE MANUFACTURER C (THAT IS, TERMINAL MANUFACTURER AND MODEL) C C DATE--JULY 24, 1986 C C------------------------------------------------------------------------------- C CHARACTER*4 IMANUF CHARACTER*4 IMODEL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' CCCCC THE FOLLOWING LINE WAS ADDED (FOR MENU/GUI) MAY 1993 INCLUDE 'DPCODV.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDDE' ISUBN2='MN ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDEMN') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDEMN') 51 FORMAT('***** AT THE BEGINNING OF EDDEMN--') WRITE(ICOUT,52)ICOM,ICOM2,NUMARG,IHARG(1) CALL EDWRST('EDDEMN') 52 FORMAT('ICOM,ICOM2,NUMARG,IHARG(1) = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,53)IHARG(2),IHARG(3) CALL EDWRST('EDDEMN') 53 FORMAT('IHARG(2),IHARG(3) = ',A4,2X,A4) WRITE(ICOUT,54)IMANUF,IMODEL CALL EDWRST('EDDEMN') 54 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) WRITE(ICOUT,55)IFOUND,IERROR CALL EDWRST('EDDEMN') 55 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 90 CONTINUE C IF(IHARG(2).EQ.'TEKT')GOTO1010 IF(IHARG(2).EQ.'IBM')GOTO1020 IF(IHARG(2).EQ.'IBM-')GOTO1020 IF(IHARG(2).EQ.'HDS')GOTO1030 IF(IHARG(2).EQ.'QUME')GOTO1040 IF(IHARG(2).EQ.'VT')GOTO1050 IF(IHARG(2).EQ.'VT-1')GOTO1050 IF(IHARG(2).EQ.'VT-2')GOTO1050 C IF(IHARG(2).EQ.'DOS')GOTO2100 IF(IHARG(2).EQ.'UNIX')GOTO2200 C IF(IHARG(2).EQ.'TURB')GOTO3100 IF(IHARG(2).EQ.'X11')GOTO3200 IF(IHARG(2).EQ.'X')GOTO3200 IF(IHARG(2).EQ.'MOTI')GOTO3300 IF(IHARG(2).EQ.'MAC')GOTO3400 IF(IHARG(2).EQ.'MACI')GOTO3400 C IFOUND='NO' GOTO9000 C 1010 CONTINUE IMANUF='TEKT' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 1020 CONTINUE IMANUF='IBM' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 1030 CONTINUE IMANUF='HDS' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 1040 CONTINUE IMANUF='QUME' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 1050 CONTINUE IMANUF='VT' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 2100 CONTINUE IMANUF='DOS' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 2200 CONTINUE IMANUF='UNIX' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 3100 CONTINUE IMANUF='TURB' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) CCCCC THE FOLLOWING 3 LINES WERE ADDED (FOR MENU/GUI) MAY 1993 CALL TCINCO(ISUBRO) CALL TCLOTC(ISUBRO) CALL TCSHME(ISUBRO) GOTO8000 C 3200 CONTINUE IMANUF='X11' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 3300 CONTINUE IMANUF='MOTI' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 3400 CONTINUE IMANUF='MAC' IMODEL=' ' IF(NUMARG.GE.3)IMODEL=IHARG(3) GOTO8000 C 8000 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1919 WRITE(ICOUT,1911)IMANUF,IMODEL CALL EDWRST('EDDEMN') 1911 FORMAT('TERMINAL = ',A4,2X,A4) 1919 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DEMN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDEMN') WRITE(ICOUT,9011) CALL EDWRST('EDDEMN') 9011 FORMAT('***** AT THE END OF EDDEMN--') WRITE(ICOUT,9012)ICOM,ICOM2,NUMARG,IHARG(1) CALL EDWRST('EDDEMN') 9012 FORMAT('ICOM,ICOM2,NUMARG,IHARG(1) = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,9013)IHARG(2),IHARG(3) CALL EDWRST('EDDEMN') 9013 FORMAT('IHARG(2),IHARG(3) = ',A4,2X,A4) WRITE(ICOUT,9014)IMANUF,IMODEL CALL EDWRST('EDDEMN') 9014 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) WRITE(ICOUT,9015)IFOUND,IERROR CALL EDWRST('EDDEMN') 9015 FORMAT('IFOUND,IERROR = ',A4,2X,A4) 9090 CONTINUE C RETURN END SUBROUTINE EDDEPR C C PURPOSE--DEACTIVATE THE PRINTER C (FOR THE IBM-PC PRINTER, C SEND DOWN A CONTROL LOWER CASE P C = ASCII DLE = CHAR(16) ) C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDE' ISUBN2='PR ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DEPR')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDEPR') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDEPR') 51 FORMAT('***** AT THE BEGINNING OF EDDEPR--') 90 CONTINUE C NCOUT=1 ICOUT(1:1)=IDLEC ILOUT=(-1) CALL EDWRST('EDDEPR') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDEPR') WRITE(ICOUT,9011) CALL EDWRST('EDDEPR') 9011 FORMAT('***** AT THE END OF EDDEPR--') 9090 CONTINUE C RETURN END SUBROUTINE EDDI C C PURPOSE--DELETE AND REWRIE CURRENT LINE OF TEXT C THE STRING WHICH FOLLOWS THE INSERT COMMAND C WILL REPLACE THE CURRENT LINE. C IF NO STRING FOLLOWS THE REWRITE COMMAND, C THEN A BLANK LINE (CONSISTING OF 1 BLANK CHARACTER) C WILL BE INSERTED. C COMMAND SYNTAX--REWRITE C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN CCCCC ADD FOLLOWING LINE NOVEMBER 1994. CHARACTER*4 IFOUST C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDI' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDI ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDI ') 51 FORMAT('***** AT THE BEGINNING OF EDDI--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************** C ** STEP 1-- ** C ** DETERMINE THE STRING THAT WILL ** C ** REPLACE THE CURRENT LINE. ** C ************************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) C C **************************** C ** STEP 2-- ** C ** REWRITE THE LINE. ** C **************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMLIN.GE.MAXEDL)GOTO1510 IF(NUMROW.GE.MAXROW)GOTO1520 IF(NUMCHA.GE.MAXEDC)GOTO1530 NUMCH2=NUMCHA+NUMCST IF(NUMCH2.GT.MAXEDC)GOTO1540 GOTO1550 C 1510 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1511) CALL EDWRST('EDDI ') 1511 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1512) CALL EDWRST('EDDI ') 1512 FORMAT(' NO ROOM LEFT FOR MORE LINES.') WRITE(ICOUT,1513)NUMLIN,MAXEDL CALL EDWRST('EDDI ') 1513 FORMAT(' NUMLIN (',I8,') >= MAXEDL (',I8,')') IERROR='YES' GOTO9000 C 1520 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1521) CALL EDWRST('EDDI ') 1521 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1522) CALL EDWRST('EDDI ') 1522 FORMAT(' NO ROOM LEFT FOR MORE ROWS.') WRITE(ICOUT,1523)NUMROW,MAXROW CALL EDWRST('EDDI ') 1523 FORMAT(' NUMROW (',I8,') >= MAXROW (',I8,')') IERROR='YES' GOTO9000 C 1530 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1531) CALL EDWRST('EDDI ') 1531 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1532) CALL EDWRST('EDDI ') 1532 FORMAT(' NO ROOM LEFT FOR MORE CHARACTERS.') WRITE(ICOUT,1533)NUMCHA,MAXEDC CALL EDWRST('EDDI ') 1533 FORMAT(' NUMCHA (',I8,') >= MAXEDC (',I8,')') IERROR='YES' GOTO9000 C 1540 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1541) CALL EDWRST('EDDI ') 1541 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1542) CALL EDWRST('EDDI ') 1542 FORMAT(' NEW STRING WOULD EXCEED ICHA(.) WORKSPACE.') WRITE(ICOUT,1543)NUMCHA,NUMCST,MAXEDC CALL EDWRST('EDDI ') 1543 FORMAT(' NUMCHA,NUMCST,MAXEDC = ',3I8) IERROR='YES' GOTO9000 C 1550 CONTINUE IF(ICURLN.LT.1)GOTO1560 IF(ICURLN.GT.NUMLIN)GOTO1570 GOTO1580 C 1560 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1561) CALL EDWRST('EDDI ') 1561 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1562) CALL EDWRST('EDDI ') 1562 FORMAT(' ATTEMPT TO REWRITE THE NON-EXISTENT LINE.') WRITE(ICOUT,1563) CALL EDWRST('EDDI ') 1563 FORMAT(' AT THE TOP OF THE FILE ("LINE" 0)') IERROR='YES' GOTO9000 C 1570 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,1571) CALL EDWRST('EDDI ') 1571 FORMAT('***** ERROR IN EDDI--') WRITE(ICOUT,1572) CALL EDWRST('EDDI ') 1572 FORMAT(' ATTEMPT TO REWRITE THE NON-EXISTENT LINE.') WRITE(ICOUT,1573) CALL EDWRST('EDDI ') 1573 FORMAT(' AT THE BOTTOM OF THE FILE ("LINE" NUMLIN+1 )') IERROR='YES' GOTO9000 C 1580 CONTINUE J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ICURLN)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO1585J=J1,J2 I=I+1 ICHA(J)=ISTRIN(I) 1585 CONTINUE 1589 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,9011) CALL EDWRST('EDDI ') 9011 FORMAT('***** AT THE END OF EDDI--') WRITE(ICOUT,999) CALL EDWRST('EDDI ') WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDDI ') 9014 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDDI ') 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDDI ') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDDI ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDDUMP C C PURPOSE--DUMP TRACE/DEBUG INFORMATION C C DATE--JANUARY 24,1985 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C IFOUND='YES' C CALL EDTRA1 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE EDDUPL C C PURPOSE--INSERT 1 LINE OF TEXT (AFTER CURRENT LINE). C THE STRING WHICH FOLLOWS THE INSERT COMMAND C WILL BE INSERTED. C IF NO STRING FOLLOWS THE INSERT COMMAND, C THEN A BLANK LINE (CONSISTING OF 1 BLANK CHARACTER) C WILL BE INSERTED. C COMMAND SYNTAX--INSERT C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*240 ISTRIN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDDU' ISUBN2='PL ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C NUMCST=(-999) ISTRIN(1:1)=' ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DUPL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDDUPL') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDDUPL') 51 FORMAT('***** AT THE BEGINNING OF EDDUPL--') WRITE(ICOUT,52)NCHH1,NCHH2,NCHH3 CALL EDWRST('EDDUPL') 52 FORMAT('NCHH1,NCHH2,NCHH3 = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE INSERTED ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DUPL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C DO1110I=1,240 ISTRIN(I:I)=' ' 1110 CONTINUE C IARG1=1 IF(NUMARG.GE.1)IARG1=IARG(1) C IF(IARG1.EQ.1)NUMCST=NCHH1 IF(IARG1.EQ.2)NUMCST=NCHH2 IF(IARG1.EQ.3)NUMCST=NCHH3 IF(IARG1.EQ.4)NUMCST=NCHH4 IF(IARG1.EQ.5)NUMCST=NCHH5 IF(IARG1.EQ.6)NUMCST=NCHH6 IF(IARG1.EQ.7)NUMCST=NCHH7 IF(IARG1.EQ.8)NUMCST=NCHH8 IF(IARG1.EQ.9)NUMCST=NCHH9 IF(IARG1.EQ.10)NUMCST=NCHH10 C IF(NUMCST.LE.0)GOTO1190 DO1120I=1,NUMCST IF(IARG1.EQ.1)ISTRIN(I:I)=IHOLS1(I:I) IF(IARG1.EQ.2)ISTRIN(I:I)=IHOLS2(I:I) IF(IARG1.EQ.3)ISTRIN(I:I)=IHOLS3(I:I) IF(IARG1.EQ.4)ISTRIN(I:I)=IHOLS4(I:I) IF(IARG1.EQ.5)ISTRIN(I:I)=IHOLS5(I:I) IF(IARG1.EQ.6)ISTRIN(I:I)=IHOLS6(I:I) IF(IARG1.EQ.7)ISTRIN(I:I)=IHOLS7(I:I) IF(IARG1.EQ.8)ISTRIN(I:I)=IHOLS8(I:I) IF(IARG1.EQ.9)ISTRIN(I:I)=IHOLS9(I:I) IF(IARG1.EQ.10)ISTRIN(I:I)=IHOL10(I:I) 1120 CONTINUE 1190 CONTINUE C IF(NUMCST.LE.0)ISTRIN(1:1)=' ' IF(NUMCST.LE.0)NUMCST=1 C C ***************************************************** C ** STEP 2-- ** C ** DETERMINE THE NUMBER OF TIMES ** C ** THAT THE STRING WILL BE INSERTED (DUPLICATED) ** C ***************************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DUPL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IARG2=1 IF(NUMARG.GE.2)IARG2=IARG(2) NUMDUP=IARG2 C C **************************** C ** STEP 3-- ** C ** INSERT THE LINE. ** C **************************** C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DUPL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCHP=NUMCHA+NUMCST*NUMDUP CALL EDCHSI(NUMCHP) IF(IERROR.EQ.'YES')GOTO9000 C 1550 CONTINUE DO1555IDUP=1,NUMDUP C IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURLN+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO1569 IF(NUMLIN.LE.0)GOTO1569 IF(ICURLP.GT.NUMLIN)GOTO1569 DO1560ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 1560 CONTINUE 1569 CONTINUE C J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO1570J=J1,J2 I=I+1 ICHA(J)=ISTRIN(I:I) 1570 CONTINUE 1579 CONTINUE ICURLN=ICURLP IF(IDUP.EQ.1)IMIN=ICURLN NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 C 1555 CONTINUE IMAX=ICURLN C C *************************** C ** STEP 23-- ** C ** WRITE OUT A MESSAGE ** C *************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'COPY') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C IF(IFEESW.EQ.'OFF')GOTO2329 C WRITE(ICOUT,999) CALL EDWRST('EDDUPL') IDEL=IMAX-IMIN+1 ILINE=IMIN-1 DO2320IPASS=1,10000 ILINE=ILINE+1 IF(IPASS.GE.2.AND.IDEL.GE.11)ILINE=IMAX IF(ILINE.LT.1)GOTO2325 IF(ILINE.GT.IMAX)GOTO2325 IF(ILINE.GT.NUMLIN)GOTO2325 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2321)(ICHA(J),J=J1,J2) CALL EDWRST('EDDUPL') ENDIF 2321 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2322)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDDUPL') ENDIF 2322 FORMAT(I6,':',3X,230A1) 2325 CONTINUE IF(IPASS.GE.2.AND.IDEL.GE.11)GOTO2328 2320 CONTINUE 2328 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDDUPL') 2329 CONTINUE C C ********************** C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DUPL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDDUPL') WRITE(ICOUT,9011) CALL EDWRST('EDDUPL') 9011 FORMAT('***** AT THE END OF EDDUPL--') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDDUPL') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDDUPL') 9014 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9015)(ISTRIN(I:I),I=1,NUMCST) CALL EDWRST('EDDUPL') 9015 FORMAT('(ISTRIN(I:I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDDUPL') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)NUMARG,IARG(1),IARG(2) CALL EDWRST('EDDUPL') 9018 FORMAT('NUMARG,IARG(1),IARG(2) = ',3I8) WRITE(ICOUT,9019)IARG1,IARG2,NUMDUP CALL EDWRST('EDDUPL') 9019 FORMAT('IARG1,IARG2,NUMDUP = ',3I8) WRITE(ICOUT,9021)ICURLN,NUMLIN,NUMROW CALL EDWRST('EDDUPL') 9021 FORMAT('ICURLN,NUMLIN,NUMROW = ',3I8) WRITE(ICOUT,9022)IMIN,IMAX CALL EDWRST('EDDUPL') 9022 FORMAT('IMIN,IMAX = ',2I8) WRITE(ICOUT,999) CALL EDWRST('EDDUPL') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDEA C C PURPOSE--EXTEND ALL LINES BY STRING . C START WITH THE CURRENT LINE. C THE STRING WHICH FOLLOWS THE EXTEND COMMAND C WILL BE APPENDED. C COMMAND SYNTAX--EA C METHOD--LOOPING WITH THE EXTEND COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.6 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*4 IANS0 C DIMENSION IANS0(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEA' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EA')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEA ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEA ') 51 FORMAT('***** AT THE BEGINNING OF EDEA--') WRITE(ICOUT,52)NUMARG,IWIDTH CALL EDWRST('EDEA ') 52 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** COPY THE OPIGINAL COMMAND LINE ** C ******************************************* C NUMASV=NUMARG IWIDT0=IWIDTH DO1100I=1,IWIDTH IANS0(I)=IANS(I) IF(IBUGED.EQ.'OFF'.AND.ISUBRO.EQ.'EA')THEN WRITE(ICOUT,1111)I,IANS(I),IANS0(I) CALL EDWRST('EDEA ') ENDIF 1111 FORMAT('I,IANS(I),IANS0(I) = ',I8,2X,A1,2X,A1) 1100 CONTINUE C C ******************************************* C ** STEP 21-- ** C ** LOOP THROUGH (CURRENT +) ** C ** REMAINING LINES OF TEXT ** C ** VIA MULTIPLE CALLS ** C ** TO THE EXTEND COMMAND ** C ******************************************* C DO2100IDUMMY=1,100000 C IF(IBUGED.EQ.'OFF'.AND.ISUBRO.EQ.'EA')THEN WRITE(ICOUT,2119)IDUMMY,ICURLN,NUMLIN CALL EDWRST('EDEA ') ENDIF 2119 FORMAT('IDUMMY,ICURLN,NUMLIN = ',3I8) IF(ICURLN.GT.NUMLIN)GOTO2170 C IANS(1)='E' IANS(2)='X' IANS(3)='T' IANS(4)=' ' J=4 IWIDTH=2 IMIN=IWIDTH+2 IF(IWIDT0.LT.IMIN)GOTO2118 DO2110I=IMIN,IWIDT0 IF(IANS0(I).EQ.' ')IWIDTH=J IF(IANS0(I).EQ.' ')GOTO2118 J=J+1 IANS(J)=IANS0(I) IF(IBUGED.EQ.'OFF'.AND.ISUBRO.EQ.'EA')THEN WRITE(ICOUT,2111)I,J,IANS0(I),IANS(J) CALL EDWRST('EDEA ') ENDIF 2111 FORMAT('I,J,IANS0(I),IANS(J) = ',2I8,2X,A1,2X,A1) 2110 CONTINUE IWIDTH=J 2118 CONTINUE NUMARG=1 ICOM='EXT' CALL EDEXTE C ICOM='N ' ICOM2=' ' NUMARG=0 CALL EDNEXT C 2100 CONTINUE C 2170 CONTINUE IWIDTH=IWIDT0 DO2175I=1,IWIDT0 IANS(I)=IANS0(I) 2175 CONTINUE ICOM='EA ' ICOM2=' ' NUMARG=NUMASV IFOUND='YES' IERROR='NO' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EA')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEA ') WRITE(ICOUT,9021) CALL EDWRST('EDEA ') 9021 FORMAT('***** AT THE END OF EDEA--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 WRITE(ICOUT,999) CALL EDWRST('EDEA ') WRITE(ICOUT,9012)NUMARG,IWIDTH CALL EDWRST('EDEA ') 9012 FORMAT('NUMARG,IWIDTH = ',2I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDEA ') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',210A1) WRITE(ICOUT,9014)IWIDT0 CALL EDWRST('EDEA ') 9014 FORMAT('IWIDT0 = ',I8) WRITE(ICOUT,9015)(IANS0(I),I=1,IWIDT0) CALL EDWRST('EDEA ') 9015 FORMAT('(IANS0(I),I=1,IWIDT0) = ',80A1) 9090 CONTINUE C RETURN END SUBROUTINE EDECCO C C PURPOSE--ECHO A COMMAND LINE BACK C (THAT IS, PUT IT IN A BOX FOR NOTICEABILITY) C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IAST CHARACTER*1 IBL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEC' ISUBN2='CO ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ECCO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDECCO') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDECCO') 51 FORMAT('*****AT THE BEGINNING OF EDECCO--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************* C ** STEP 1-- ** C ** ECHO THE COMMAND LINE ** C ************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ECCO') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IAST='*' IBL=' ' C IMAX=IWIDTH+8 WRITE(ICOUT,999) CALL EDWRST('EDECCO') WRITE(ICOUT,1211)(IAST,I=1,IMAX) CALL EDWRST('EDECCO') 1211 FORMAT(10X,230A1) WRITE(ICOUT,1212)IAST,IAST,IBL,IBL,(IANS(I),I=1,IWIDTH), 1IBL,IBL,IAST,IAST CALL EDWRST('EDECCO') 1212 FORMAT(10X,230A1) WRITE(ICOUT,1213)(IAST,I=1,IMAX) CALL EDWRST('EDECCO') 1213 FORMAT(10X,230A1) WRITE(ICOUT,999) CALL EDWRST('EDECCO') C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ECCO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDECCO') WRITE(ICOUT,9011) CALL EDWRST('EDECCO') 9011 FORMAT('*****AT THE END OF EDECCO--') WRITE(ICOUT,9012)IWIDTH,IMAX CALL EDWRST('EDECCO') 9012 FORMAT('IWIDTH,IMAX = ',2I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDEDIT C C PURPOSE--CHANGE TO EDIT MODE (FROM INPUT MODE) C C DATE--JANUARY 24,1985 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDED' ISUBN2='IT ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EDIT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEDIT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEDIT') 51 FORMAT('*****AT THE BEGINNING OF EDEDIT--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IMODE='EDIT' C CCCCC IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDEDIT') ENDIF 1151 FORMAT('YOU HAVE JUST ENTERED EDIT MODE') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDEDIT') ENDIF 1152 FORMAT(10X,'YOU HAVE JUST ENTERED EDIT MODE') 1159 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EDIT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEDIT') WRITE(ICOUT,9011) CALL EDWRST('EDEDIT') 9011 FORMAT('*****AT THE END OF EDEDIT--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDERAS(IMANUF,IMODEL) C C PURPOSE--WRITE OUT THE CONTENTS OF THE ICERAS STRING C WHICH (IF PROPERLY SET) WILL ERASE THE TERMINAL SCREEN. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED --APRIL 1990. C C--------------------------------------------------------------------- C CHARACTER*4 IMANUF CHARACTER*4 IMODEL C CHARACTER*238 ICSTR CHARACTER*4 ISUBN0 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDER' ISUBN2='AS ' C IFOUND='YES' IERROR='NO' C ISUBN0='ERAS' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ERAS')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDERAS') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDERAS') 51 FORMAT('***** AT THE BEGINNING OF EDERAS--') WRITE(ICOUT,52)IMANUF,IMODEL CALL EDWRST('EDERAS') 52 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *************************** C ** STEP 11-- ** C ** ERASE THE SCREEN ** C ** AND POSITION CURSOR ** C ** AT TOP OF SCREEN ** C *************************** C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ERAS') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC WRITE(ICOUT,1111)ICERAS C1111 FORMAT(A4) C C THE FOLLOWING 2 ASSEMBLY CALLS C ARE COMMENTED OUT IN THE VAX VERSION-- C CVVVV CALL ASERSC CVVVV CALL ASPOCT C C ******************************************** C ** STEP 1-- ** C ** BRANCH ACCORDING TO THE MANUFACTURER ** C ** AND THE MODEL ** C ******************************************** C IF(IMANUF.EQ.'TEKT')GOTO1010 IF(IMANUF.EQ.'HP')GOTO1020 IF(IMANUF.EQ.'GENE')GOTO1030 IF(IMANUF.EQ.'IBM')GOTO1040 IF(IMANUF.EQ.'HDS')GOTO1050 IF(IMANUF.EQ.'QUME')GOTO1060 IF(IMANUF.EQ.'VT')GOTO1070 IF(IMANUF.EQ.'MAC')GOTO1080 IF(IMANUF.EQ.'FORT')GOTO1090 GOTO9000 C 1010 CONTINUE IF(IMODEL.EQ.'4662')GOTO9000 C IF(IMODEL.EQ.'4020')GOTO1200 IF(IMODEL.EQ.'4022')GOTO1200 IF(IMODEL.EQ.'4025')GOTO1200 IF(IMODEL.EQ.'4027')GOTO1200 C IF(IMODEL.EQ.'4105')GOTO1300 IF(IMODEL.EQ.'4107')GOTO1300 IF(IMODEL.EQ.'4109')GOTO1300 IF(IMODEL.EQ.'4115')GOTO1300 IF(IMODEL.EQ.'4107')GOTO1300 IF(IMODEL.EQ.'4109')GOTO1300 IF(IMODEL.EQ.'4115')GOTO1300 C GOTO1100 C 1020 CONTINUE IF(IMODEL.EQ.'7221')GOTO2100 IF(IMODEL.EQ.'2622')GOTO2300 IF(IMODEL.EQ.'2623')GOTO2300 IF(IMODEL.EQ.'2627')GOTO2300 IF(IMODEL.EQ.'2647')GOTO2300 GOTO2200 C 1030 CONTINUE IF(IMODEL.EQ.'CODE')GOTO3200 GOTO3100 C 1040 CONTINUE GOTO4100 C 1050 CONTINUE GOTO5100 C 1060 CONTINUE GOTO6100 C 1070 CONTINUE GOTO7100 C 1080 CONTINUE GOTO8100 C 1090 CONTINUE GOTO9100 C ************************************************************ C ** STEP 11-- ** C ** TREAT THE TEKTRONIX 400X, 401X, 405X, AND 4114 CASES ** C ** (THESE ARE ALL NON-COLOR (= MONOCHROME) DEVICES) ** C ** TO ERASE THE SCREEN, ** C ** WRITE OUT AN ESCAPE FORM-FEED ** C ************************************************************ C 1100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)=IFFC NCSTR=2 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) C CCCCC DO1130J=1,10 CCCCC ICSTR(J:J)=INULC C1130 CONTINUE CCCCC NCSTR=10 CCCCC CCCCC AGERDE=10.0 CCCCC INULLI=AGERDE+0.5 CCCCC IF(INULLI.LE.0)GOTO1139 CCCCC DO1135I=1,INULLI CCCCC CALL EDWRGS(ICSTR,NCSTR,ISUBN0) C1135 CONTINUE C1139 CONTINUE C GOTO9000 C C ****************************************************** C ** STEP 12-- ** C ** TREAT THE TEKTRONIX 4020, 4022, AND 4025 CASES ** C ** (NON-COLOR RASTER DEVICES). ** C ** TO ERASE THE SCREEN, ** C ** USE THE !ERA COMMAND ** C ** REFERENCE--4027 OPERATOR'S MANUAL, PAGE 5-6. ** C ****************************************************** C 1200 CONTINUE CCCCC WRITE(IGUNIT,1211)JCOL C1211 FORMAT('!ERA G C',I1,';') CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC ICSTR(1:8)='!ERA G C;' ICSTR(1:9)='!ERA G C;' IX=JCOL+48 CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC ICSTR(9:9)=CHAR(IX) ICSTR(10:10)=CHAR(IX) CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC ICSTR(10:10)=';' ICSTR(11:11)=';' CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC NCSTR=10 NCSTR=11 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 13-- ** C ** TREAT THE 4105 CASE ** C ** (COLOR DEVICE) ** C ** TO ERASE THE SCREEN, ** C ** SET THE BACKGROUND COLOR AND ** C ** THEN CARRY OUT THE ERASE ** C ** REFERENCE--PAGE 5-51 ** C ****************************************************** C 1300 CONTINUE JCOL=1 CCCCC WRITE(IGUNIT,1311)IESCC,JCOL C1311 FORMAT(A1,'RA1',I1,'0') ICSTR(1:1)=IESCC ICSTR(2:4)='RA1' IX=JCOL+48 ICSTR(5:5)=CHAR(IX) ICSTR(6:6)='0' NCSTR=6 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) CCCCC WRITE(IGUNIT,1312)IESCC,IFFC C1312 FORMAT(A1,A1) ICSTR(1:1)=IESCC ICSTR(2:2)=IFFC NCSTR=2 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 21-- ** C ** TREAT THE HEWLETT-PACKARD 7221 CASE ** C ** (MULTI-COLOR PENPLOTTER) ** C ** THERE IS NO ERASE INSTRUCTION PER SE. ** C ** REFERENCE--HP 7221A GRAPHICS PLOTTER ** C ** OPERATING AND PROGRAMMING MANUAL, ** C ** PAGE XX. ** C ****************************************************** C 2100 CONTINUE GOTO9000 C C ****************************************************** C ** STEP 22-- ** C ** TREAT THE HEWLETT-PACKARD HP-GL CASES ** C ** (ALL PLOTTERS THAT TAKE HP-GL INSTRUCTIONS) ** C ** (MULTI-COLOR PENPLOTTERS) ** C ** THERE IS NO ERASE INSTRUCTION PER SE. ** C ** REFERENCE--HP 9872C GRAPHICS PLOTTER ** C ** OPERATING AND PROGRAMMING MANUAL, ** C ** PAGE XX, EDERAS. ** C ****************************************************** C 2200 CONTINUE GOTO9000 C C ********************************************************** C ** STEP 23-- ** C ** TREAT THE HEWLETT-PACKARD HP-2622 CASES ** C ** (ALL PLOTTERS THAT TAKE HP-2622-LIKE INSTRUCTIONS) ** C ** (MONOCHROME DISPLAY TERMINALS) ** C ** REFERENCE--HP 2322C GRAPHICS PLOTTER ** C ** REFERENCE MANUAL, ** C ** PAGE 10-4, 10-3. ** C ********************************************************** C 2300 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:5)='*daZ' NCSTR=5 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 31-- ** C ** TREAT THE GENERAL (DEVICE-INDEPENDENT) CASE ** C ****************************************************** C 3100 CONTINUE CCCCC WRITE(IGUNIT,3111) C3111 FORMAT('ERASE SCREEN') ICSTR(1:12)='ERASE SCREEN' NCSTR=12 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C *************************************************************** C ** STEP 32-- ** C ** TREAT THE CODED GENERAL (DEVICE-INDEPENDENT) CASE ** C *************************************************************** C 3200 CONTINUE ICSTR(1:4)='ERSC' NCSTR=4 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 41-- ** C ** TREAT THE IBM-PC CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 4100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 51-- ** C ** TREAT THE HDS CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 5100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 61-- ** C ** TREAT THE QUME CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 6100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 71-- ** C ** TREAT THE VT CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 7100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 81-- ** C ** TREAT THE MAC CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 8100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ****************************************************** C ** STEP 91-- ** C ** TREAT THE FORTUNE CASE ** C ** TO ERASE SCREEN--- ** C ** WRITE OUT AN ESCAPE [ 2 J ** C ** REFERENCE--XX ** C ** XX ** C ** PAGES XX AND XX ** C ****************************************************** C 9100 CONTINUE ICSTR(1:1)=IESCC ICSTR(2:2)='[' ICSTR(3:3)='2' ICSTR(4:4)='J' ICSTR(5:5)=IESCC ICSTR(6:6)='[' ICSTR(7:7)='H' NCSTR=7 CALL EDWRGS(ICSTR,NCSTR,ISUBN0) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ERAS')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDERAS') WRITE(ICOUT,9011) CALL EDWRST('EDERAS') 9011 FORMAT('***** AT THE END OF EDERAS--') WRITE(ICOUT,9015)IESCC,IFFC,ISYNC CALL EDWRST('EDERAS') 9015 FORMAT('IESCC,IFFC,ISYNC = ',A1,2X,A1,2X,A1) WRITE(ICOUT,9018)IMANUF,IMODEL CALL EDWRST('EDERAS') 9018 FORMAT('IMANUF,IMODEL = ',A4,2X,A4) WRITE(ICOUT,9019)IX CALL EDWRST('EDERAS') 9019 FORMAT('IX = ',I8) WRITE(ICOUT,9023)NCSTR CALL EDWRST('EDERAS') 9023 FORMAT('NCSTR = ',I8) IF(NCSTR.LE.0)GOTO9027 DO9025I=1,NCSTR IASCNE=ICHAR(ICSTR(I:I)) WRITE(ICOUT,9026)I,ICSTR(I:I),IASCNE CALL EDWRST('EDERAS') 9026 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8) 9025 CONTINUE 9027 CONTINUE WRITE(ICOUT,9029)IBUGE2,ISUBRO,IERROR CALL EDWRST('EDERAS') 9029 FORMAT('IBUGE2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END CCCCC THE FOLLOWING LINE WAS AUGMENTED JULY 1992 CCCCC SUBROUTINE EDEXIT SUBROUTINE EDEXIT(STOPSW) C C PURPOSE--CARRY OUT A NORMAL EXIT FROM THE EDITOR. C BEFORE DOING SO, FIRST COPY THE CURRENT WORKSPACE C CONTENTS OUT TO THE ORIGINAL FILE. C NOTE--NO ARGUMENTS ARE EXPECTED. C SYNTAX--E C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED--JULY 1992 ADD STOP SWITCH (STOPSW) C C--------------------------------------------------------------------- C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1992 CHARACTER*4 STOPSW C CHARACTER*4 ID C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEX' ISUBN2='IT ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EXIT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEXIT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEXIT') 51 FORMAT('*****AT THE BEGINNING OF EDEXIT--') WRITE(ICOUT,52)NUMLIN CALL EDWRST('EDEXIT') 52 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,53)IORINA CALL EDWRST('EDEXIT') 53 FORMAT('IORINA = ',A80) WRITE(ICOUT,54)IORIST CALL EDWRST('EDEXIT') 54 FORMAT('IORIST = ',A12) WRITE(ICOUT,55)IORINU CALL EDWRST('EDEXIT') 55 FORMAT('IORINU = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *************************************** C ** STEP 1-- ** C ** WRITE WORKSPACE OUT TO THE FILE ** C *************************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ID='ORIG' IF(IORINA.NE.ICOMNA.AND.IORINA.NE.ISAVNA) 1CALL EDWRWF(ID) C C ****************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE ** C ****************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'EXIT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,1205) CALL EDWRST('EDEXIT') 1205 FORMAT('THIS IS A NORMAL EDITOR EXIT') WRITE(ICOUT,1206)IORINA CALL EDWRST('EDEXIT') 1206 FORMAT('FILE = ',A80) WRITE(ICOUT,1207)NUMLIN CALL EDWRST('EDEXIT') 1207 FORMAT('NUMBER OF LINES = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDEXIT') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EXIT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEXIT') WRITE(ICOUT,9011) CALL EDWRST('EDEXIT') 9011 FORMAT('*****AT THE END OF EDEXIT--') WRITE(ICOUT,9012)NUMLIN CALL EDWRST('EDEXIT') 9012 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,9013)IORINA CALL EDWRST('EDEXIT') 9013 FORMAT('IORINA = ',A80) WRITE(ICOUT,9014)IORIST CALL EDWRST('EDEXIT') 9014 FORMAT('IORIST = ',A12) WRITE(ICOUT,9015)IORINU CALL EDWRST('EDEXIT') 9015 FORMAT('IORINU = ',I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C IF(ICOM.EQ.'ER'.OR.ICOM.EQ.'ERR'.OR.ICOM.EQ.'EXRR')RETURN IF(ICOM.NE.'ER'.AND.ICOM.NE.'ERR'.AND.ICOM.NE.'EXRR' 1.AND.IHOST1.EQ.'VAX ')CALL EXIT(1) CCCCC THE FOLLOWING LINE WAS CHANGED JULY 1992 CCCCC STOP STOPSW='YES' END SUBROUTINE EDEXST(ISTRIN,NUMCST,IFOUST) C C PURPOSE--SCAN IANS(.) AND EXTRACT THE C STRING AFTER THE COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 ICASE CHARACTER*5 IC5 C DIMENSION ISTRIN(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEX' ISUBN2='ST ' C IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'EXST')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEXST') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEXST') 51 FORMAT('***** AT THE BEGINNING OF EDEXST--') WRITE(ICOUT,52)IBUGE3,ISUBRO CALL EDWRST('EDEXST') 52 FORMAT('IBUGE3,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,54)NUMARG,IWIDTH CALL EDWRST('EDEXST') 54 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDEXST') ENDIF 55 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,999) CALL EDWRST('EDEXST') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************** C ** STEP 1-- ** C ** EXTRACT THE STRING ** C ************************** C CCCCC ISTRIN(1)=' ' CCCCC NUMCST=1 NUMCST=0 IFOUST='NO' C IF(NUMARG.LE.0)GOTO1190 IF(IWIDTH.LE.1)GOTO1190 C DO1120I=1,IWIDTH I2=I IF(IANS(I).EQ.' ')GOTO1125 1120 CONTINUE I2=IWIDTH+1 1125 CONTINUE IFIRBL=I2 C IMIN=IFIRBL+1 IF(IMIN.GT.IWIDTH)GOTO1190 C ICASE='PRIN' DO1130I=IMIN,IWIDTH IF(IANS(I).EQ.'('.AND.IANS(I+1).EQ.')')ICASE='NONP' 1130 CONTINUE C IF(ICASE.EQ.'PRIN')GOTO1140 GOTO1150 C 1140 CONTINUE J=0 DO1141I=IMIN,IWIDTH J=J+1 ISTRIN(J)=IANS(I) 1141 CONTINUE NUMCST=J IFOUST='YES' GOTO1190 C 1150 CONTINUE J=0 I=IMIN 1152 CONTINUE IF(I.GT.IWIDTH)GOTO1159 C IVALUE=-1 C IC5=' ' IC5(1:1)=IANS(I) IF(I+1.GT.IWIDTH)GOTO1155 IC5(2:2)=IANS(I+1) IF(I+2.GT.IWIDTH)GOTO1155 IC5(3:3)=IANS(I+2) IF(I+3.GT.IWIDTH)GOTO1155 IC5(4:4)=IANS(I+3) IF(I+4.GT.IWIDTH)GOTO1151 IC5(5:5)=IANS(I+4) 1151 CONTINUE C IF(IC5.EQ.'NUL()')IVALUE=0 IF(IC5.EQ.'nul()')IVALUE=0 IF(IC5.EQ.'SOH()')IVALUE=1 IF(IC5.EQ.'soh()')IVALUE=1 IF(IC5.EQ.'STX()')IVALUE=2 IF(IC5.EQ.'stx()')IVALUE=2 IF(IC5.EQ.'ETX()')IVALUE=3 IF(IC5.EQ.'etx()')IVALUE=3 IF(IC5.EQ.'EOT()')IVALUE=4 IF(IC5.EQ.'eot()')IVALUE=4 IF(IC5.EQ.'ENQ()')IVALUE=5 IF(IC5.EQ.'enq()')IVALUE=5 IF(IC5.EQ.'ACK()')IVALUE=6 IF(IC5.EQ.'ack()')IVALUE=6 IF(IC5.EQ.'BEL()')IVALUE=7 IF(IC5.EQ.'bel()')IVALUE=7 IF(IC5.EQ.'BS()')IVALUE=8 IF(IC5.EQ.'bs()')IVALUE=8 IF(IC5.EQ.'HT()')IVALUE=9 IF(IC5.EQ.'ht()')IVALUE=9 IF(IC5.EQ.'LF()')IVALUE=10 IF(IC5.EQ.'lf()')IVALUE=10 IF(IC5.EQ.'VT()')IVALUE=11 IF(IC5.EQ.'vt()')IVALUE=11 IF(IC5.EQ.'FF()')IVALUE=12 IF(IC5.EQ.'ff()')IVALUE=12 IF(IC5.EQ.'CR()')IVALUE=130 IF(IC5.EQ.'cr()')IVALUE=130 IF(IC5.EQ.'SO()')IVALUE=14 IF(IC5.EQ.'so()')IVALUE=14 IF(IC5.EQ.'SI()')IVALUE=15 IF(IC5.EQ.'si()')IVALUE=15 IF(IC5.EQ.'DLE()')IVALUE=16 IF(IC5.EQ.'dle()')IVALUE=16 IF(IC5.EQ.'DC1()')IVALUE=17 IF(IC5.EQ.'dc1()')IVALUE=17 IF(IC5.EQ.'DC2()')IVALUE=18 IF(IC5.EQ.'dc2()')IVALUE=18 IF(IC5.EQ.'DC3()')IVALUE=19 IF(IC5.EQ.'dc3()')IVALUE=19 IF(IC5.EQ.'DC4()')IVALUE=20 IF(IC5.EQ.'dc4()')IVALUE=20 IF(IC5.EQ.'NAK()')IVALUE=21 IF(IC5.EQ.'nak()')IVALUE=21 IF(IC5.EQ.'SYN()')IVALUE=22 IF(IC5.EQ.'syn()')IVALUE=22 IF(IC5.EQ.'ETB()')IVALUE=23 IF(IC5.EQ.'etb()')IVALUE=23 IF(IC5.EQ.'CAN()')IVALUE=24 IF(IC5.EQ.'can()')IVALUE=24 IF(IC5.EQ.'EM()')IVALUE=25 IF(IC5.EQ.'em()')IVALUE=25 IF(IC5.EQ.'SUB()')IVALUE=26 IF(IC5.EQ.'sub()')IVALUE=26 IF(IC5.EQ.'ESC()')IVALUE=27 IF(IC5.EQ.'esc()')IVALUE=27 IF(IC5.EQ.'FS()')IVALUE=28 IF(IC5.EQ.'fs()')IVALUE=28 IF(IC5.EQ.'GS()')IVALUE=29 IF(IC5.EQ.'gs()')IVALUE=29 IF(IC5.EQ.'RS()')IVALUE=30 IF(IC5.EQ.'rs()')IVALUE=30 IF(IC5.EQ.'US()')IVALUE=31 IF(IC5.EQ.'us()')IVALUE=31 1155 CONTINUE C IF(IVALUE.GE.0.AND.IVALUE.LE.31) THEN J=J+1 ISTRIN(J)=CHAR(IVALUE) IW=1 IF(0.LE.IVALUE.AND.IVALUE.LE.7)IW=5 IF(8.LE.IVALUE.AND.IVALUE.LE.15)IW=4 IF(16.LE.IVALUE.AND.IVALUE.LE.24)IW=5 IF(IVALUE.EQ.25)IW=4 IF(IVALUE.EQ.26)IW=5 IF(IVALUE.EQ.27)IW=5 IF(IVALUE.EQ.28)IW=4 IF(IVALUE.EQ.29)IW=4 IF(IVALUE.EQ.30)IW=4 IF(IVALUE.EQ.31)IW=4 I=I+IW GOTO1152 ENDIF C IF(IVALUE.LE.-1) THEN J=J+1 ISTRIN(J)=IANS(I) I=I+1 GOTO1152 ENDIF C 1159 CONTINUE NUMCST=J IFOUST='YES' GOTO1190 C 1190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'EXST')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEXST') WRITE(ICOUT,9011) CALL EDWRST('EDEXST') 9011 FORMAT('***** AT THE END OF EDEXST--') WRITE(ICOUT,9012)IBUGE3,ISUBRO CALL EDWRST('EDEXST') 9012 FORMAT('IBUGE3,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,9014)NUMCST,IFOUST CALL EDWRST('EDEXST') 9014 FORMAT('NUMCST,IFOUST = ',I8,2X,A4) C IF(NUMCST.LE.0)GOTO9019 DO9016I=1,NUMCST WRITE(ICOUT,9017)I,ISTRIN(I) CALL EDWRST('EDEXST') 9017 FORMAT('I,ISTRIN(I) = ',I8,A4) 9016 CONTINUE 9019 CONTINUE C WRITE(ICOUT,999) CALL EDWRST('EDEXST') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDEXTE C C PURPOSE--EXTEND CURRENT LINE BY STRING . C THE STRING WHICH FOLLOWS THE EXTEND COMMAND C WILL BE APPENDED. C COMMAND SYNTAX--EXTEND C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEX' ISUBN2='TE ' C IFOUND='YES' IERROR='NO' C IFIRBL=(-999) J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EXTE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEXTE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEXTE') 51 FORMAT('***** AT THE BEGINNING OF EDEXTE--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE EXTENDED ** C ******************************************* C CALL EDEXST(ISTRIN,NUMCST,IFOUST) IF(IFOUST.EQ.'YES')GOTO1190 NUMCST=0 1190 CONTINUE C C **************************** C ** STEP 3-- ** C ** EXTEND THE LINE. ** C **************************** C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'EXTE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMLIN.GE.MAXEDL)GOTO1510 IF(NUMROW.GE.MAXROW)GOTO1520 IF(NUMCHA.GE.MAXEDC)GOTO1530 CCCCC THE FOLLOWING LINE WAS ADDED MAY 1990 IF(ICURLN.GT.NUMLIN)GOTO1610 ICURRO=IPOINT(ICURLN) CCCCC THE FOLLOWING LINE WAS ADDED MAY 1990 IF(ICURRO.LE.0)GOTO1610 NUMCH2=NUMCHA+NUMCPL(ICURRO)+NUMCST IF(NUMCH2.GT.MAXEDC)GOTO1540 GOTO1550 C 1510 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,1511) CALL EDWRST('EDEXTE') 1511 FORMAT('***** ERROR IN EDEXTE--') WRITE(ICOUT,1512) CALL EDWRST('EDEXTE') 1512 FORMAT(' NO ROOM LEFT FOR MORE LINES.') WRITE(ICOUT,1513)NUMLIN,MAXEDL CALL EDWRST('EDEXTE') 1513 FORMAT(' NUMLIN (',I8,') >= MAXEDL (',I8,')') IERROR='YES' GOTO9000 C 1520 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,1521) CALL EDWRST('EDEXTE') 1521 FORMAT('***** ERROR IN EDEXTE--') WRITE(ICOUT,1522) CALL EDWRST('EDEXTE') 1522 FORMAT(' NO ROOM LEFT FOR MORE ROWS.') WRITE(ICOUT,1523)NUMROW,MAXROW CALL EDWRST('EDEXTE') 1523 FORMAT(' NUMROW (',I8,') >= MAXROW (',I8,')') IERROR='YES' GOTO9000 C 1530 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,1531) CALL EDWRST('EDEXTE') 1531 FORMAT('***** ERROR IN EDEXTE--') WRITE(ICOUT,1532) CALL EDWRST('EDEXTE') 1532 FORMAT(' NO ROOM LEFT FOR MORE CHARACTERS.') WRITE(ICOUT,1533)NUMCHA,MAXEDC CALL EDWRST('EDEXTE') 1533 FORMAT(' NUMCHA (',I8,') >= MAXEDC (',I8,')') IERROR='YES' GOTO9000 C 1540 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,1541) CALL EDWRST('EDEXTE') 1541 FORMAT('***** ERROR IN EDEXTE--') WRITE(ICOUT,1542) CALL EDWRST('EDEXTE') 1542 FORMAT(' NO ROOM LEFT FOR MORE ROWS.') WRITE(ICOUT,1543)NUMROW,MAXROW CALL EDWRST('EDEXTE') 1543 FORMAT(' NUMROW (',I8,') >= MAXROW (',I8,')') IERROR='YES' GOTO9000 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1990 1610 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,1611) CALL EDWRST('EDEXTE') 1611 FORMAT('***** ERROR IN EDEXTE--') WRITE(ICOUT,1612) CALL EDWRST('EDEXTE') 1612 FORMAT(' [BOTTOM]') IERROR='YES' GOTO9000 C 1550 CONTINUE IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN NUMRP1=NUMROW+1 C J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 C IROW0=IPOINT(ICURLN) J10=ILOCC1(IROW0) N10=NUMCPL(IROW0) J20=J10+(N10-1) C J=J1-1 IF(J10.GT.J20)GOTO1572 DO1571K=J10,J20 J=J+1 ICHA(J)=ICHA(K) 1571 CONTINUE 1572 CONTINUE C IF(NUMCST.LE.0)GOTO1574 DO1573K=1,NUMCST J=J+1 ICHA(J)=ISTRIN(K) 1573 CONTINUE 1574 CONTINUE C IPOINT(ICURLN)=IROW NUMCPL(IROW)=(J20-J10+1)+NUMCST C 1579 CONTINUE NUMROW=NUMRP1 NUMCHA=J C C ************************** C ** STEP 4-- ** C ** PRINT OUT THE LINE ** C ************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'EXTE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ICURLN J3=ILOCC1(IROW) N3=NUMCPL(IROW) J4=J3+(N3-1) IF(IFEESW.EQ.'OFF')GOTO1629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1621)(ICHA(J),J=J3,J4) CALL EDWRST('EDEXTE') ENDIF 1621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1622)ILINE,(ICHA(J),J=J3,J4) CALL EDWRST('EDEXTE') ENDIF C1622 FORMAT(I6,':',3X,230A1) 1622 FORMAT(I6,':',3X,238A1) 1629 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'EXTE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,9011) CALL EDWRST('EDEXTE') 9011 FORMAT('***** AT THE END OF EDEXTE--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 WRITE(ICOUT,999) CALL EDWRST('EDEXTE') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDEXTE') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDEXTE') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDEXTE') 9014 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDEXTE') 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9016)IFIRBL CALL EDWRST('EDEXTE') 9016 FORMAT('IFIRBL = ',I8) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDEXTE') 9017 FORMAT('J1,N1,J2 = ',3I8) 9090 CONTINUE C RETURN END SUBROUTINE EDEXWO(ICLINE,NCLINE,IC1,IC2,IC3,IC4, 1ICWORD,NCWORD,IFOUWO) C C PURPOSE--SCAN ICLINE AND EXTRACT THE C FIRST NON-BLANK WORD (= STRING) C BETWEEN COLUMNS IC1 AND IC2. C PLACE THE COLUMN NUMBER OF THE C ACTUAL FIRST NON-BLANK CHARACTER INTO IC3. C PLACE THE COLUMN NUMBER OF THE C ACTUAL LAST NON-BLANK CHARACTER INTO IC4. C PLACE THE FOUND WORD INTO ICWORD. C PLACE THE NUMBER OF CHARACTERS INTO NCWORD. C IF A NON-BLANK WORD IS FOUND, SET IFOUWO TO YES; C IF NOT FOUND (THAT IS, HAVE ALL BLANKS), SET IFOUWO TO NO. C NOTE--ICLINE AND ICWORD ARE CHARACTER*240 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.6 C ORIGINAL VERSION--MAY 1986. C UPDATED--OCTOBER 1991. C C--------------------------------------------------------------------- C CHARACTER*240 ICLINE CHARACTER*240 ICWORD CHARACTER*4 IFOUWO C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDEX' ISUBN2='WO ' C IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'EXWO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDEXWO') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDEXWO') 51 FORMAT('***** AT THE BEGINNING OF EDEXWO--') WRITE(ICOUT,54)NCLINE CALL EDWRST('EDEXWO') 54 FORMAT('NCLINE = ',I8) CCCCC IF(NCLINE.GE.1)THEN CCCCC WRITE(ICOUT,55)(ICLINE(I:I),I=1,100) non-fortran 77 on unix CCC55 FORMAT('(ICLINE(I:I),I=1,NCLINE) = ',100A1) WRITE(ICOUT,61)IC1,IC2,IC3,IC4 CALL EDWRST('EDEXWO') 61 FORMAT('IC1,IC23,IC3,IC4 = ',4I8) WRITE(ICOUT,71)NCWORD CALL EDWRST('EDEXWO') 71 FORMAT('NCWORD = ',I8) IF(NCWORD.GE.1)THEN WRITE(ICOUT,72)(ICWORD(I:I),I=1,100) CALL EDWRST('EDEXWO') ENDIF 72 FORMAT('(ICWORD(I:I),I=1,100) = ',100A1) WRITE(ICOUT,999) CALL EDWRST('EDEXWO') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************** C ** STEP 11-- ** C ** FIND THE FIRST NON-BLANK ** C ********************************** C DO1100I=IC1,IC2 I2=I IF(ICLINE(I:I).NE.' ')GOTO1180 1100 CONTINUE IC3=IC1 IC4=IC2 NCWORD=0 IFOUWO='NO' GOTO9000 C 1180 CONTINUE IC3=I2 IFOUWO='YES' GOTO1190 C 1190 CONTINUE C C ********************************************* C ** STEP 12-- ** C ** FIND THE LAST CONTIGUOUS NON-BLANK ** C ********************************************* C DO1200I=IC3,IC2 I2=I IF(ICLINE(I:I).EQ.' ')GOTO1280 1200 CONTINUE IC4=IC2 GOTO1290 1280 CONTINUE IC4=I2-1 GOTO1290 C 1290 CONTINUE C C ********************************************* C ** STEP 13-- ** C ** COPY OVER THE WORD. ** C ********************************************* C J=0 DO1300I=IC3,IC4 J=J+1 ICWORD(J:J)=ICLINE(I:I) 1300 CONTINUE NCWORD=J C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE3.EQ.'OFF'.AND.ISUBRO.NE.'EXWO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDEXWO') WRITE(ICOUT,9011) CALL EDWRST('EDEXWO') 9011 FORMAT('***** AT THE END OF EDEXWO--') WRITE(ICOUT,9014)NCLINE CALL EDWRST('EDEXWO') 9014 FORMAT('NCLINE = ',I8) CCCCC IF(NCLINE.GE.1)THEN CCCCC WRITE(ICOUT,9015)(ICLINE(I:I),I=1,100) non-fortran 77 on unix C9015 FORMAT('(ICLINE(I:I),I=1,100) = ',100A1) WRITE(ICOUT,9021)IC1,IC2,IC3,IC4 CALL EDWRST('EDEXWO') 9021 FORMAT('IC1,IC23,IC3,IC4 = ',4I8) WRITE(ICOUT,9031)NCWORD CALL EDWRST('EDEXWO') 9031 FORMAT('NCWORD = ',I8) IF(NCWORD.GE.1)THEN WRITE(ICOUT,9032)(ICWORD(I:I),I=1,100) CALL EDWRST('EDEXWO') ENDIF 9032 FORMAT('(ICWORD(I:I),I=1,NCWORD) = ',100A1) WRITE(ICOUT,9041)IFOUWO CALL EDWRST('EDEXWO') 9041 FORMAT('IFOUWO = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDEXWO') IF(IBUGT1.EQ.'ON')CALL EDTRA1 9090 CONTINUE C RETURN END SUBROUTINE EDFIN2(ISTRIN,NUMCST,J1,J2,IHIT) C C PURPOSE--SCAN ICHA(.) BETWEEN C ELEMENTS J1 AND J2 (INCLUSIVE) C AND DETERMINE IF THE STRING IN ISTRIN(.) C IS CONTAINED THERIN IN COLUMNS 1, 2, 3, ... C IF SO, THEN SET IHIT TO 'YES' C IF NO, THEN SET IHIT TO 'NO' C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IHIT C DIMENSION ISTRIN(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDFI' ISUBN2='N2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIN2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDFIN2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDFIN2') 51 FORMAT('***** AT THE BEGINNING OF EDFIN2--') WRITE(ICOUT,54)NUMCST CALL EDWRST('EDFIN2') 54 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,55)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDFIN2') ENDIF 55 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,56)J1,J2 CALL EDWRST('EDFIN2') 56 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,57)IHIT CALL EDWRST('EDFIN2') 57 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDFIN2') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' C IF(J1.GT.J2)GOTO9000 IF(NUMCST.LE.0)IHIT='YES' IF(NUMCST.LE.0)GOTO9000 C J=J1-1 DO1100I=1,NUMCST J=J+1 IF(ISTRIN(I).EQ.IMASK)GOTO1100 IF(ICHA(J).EQ.ISTRIN(I))GOTO1100 GOTO1190 1100 CONTINUE IHIT='YES' GOTO9000 1190 CONTINUE IHIT='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIN2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDFIN2') WRITE(ICOUT,9011) CALL EDWRST('EDFIN2') 9011 FORMAT('***** AT THE END OF EDFIN2--') WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDFIN2') 9014 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDFIN2') ENDIF 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9016)J1,J2 CALL EDWRST('EDFIN2') 9016 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,9017)IHIT CALL EDWRST('EDFIN2') 9017 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDFIN2') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDFIND C C PURPOSE--FIND THE NEXT OCCURRANCE OF A STRING C (START THE SEARCH WITH THE NEXT LINE) C NOTE-- C LOCATE ABC WILL LOCATE ABC IF IN ANY COLUMN C FIND ABC WILL LOCATE ABC ONLY IF IN COLUMNS 1, 2, AND 3 C COMMAND SYNTAX--FIND C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 IHIT C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDFI' ISUBN2='ND ' C IFOUND='YES' IERROR='NO' C IHIT='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIND')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDFIND') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDFIND') 51 FORMAT('***** AT THE BEGINNING OF EDFIND--') WRITE(ICOUT,52)IALL CALL EDWRST('EDFIND') 52 FORMAT('IALL = ',A4) WRITE(ICOUT,53)IWIDTH CALL EDWRST('EDFIND') 53 FORMAT('IWIDTH = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE FOUND ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'FIND') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) IF(IFOUST.EQ.'YES')GOTO1190 C NUMCST=NUMCFS IF(NUMCFS.LE.0)GOTO1159 DO1155I=1,NUMCFS ISTRIN(I)=IFINST(I) 1155 CONTINUE 1159 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 2-- ** C ** IF THE STRING IS NEW, ** C ** COPY THE STRING INTO IFINST(.) ** C ** FOR FUTURE USE BY SUBSEQUENT ** C ** FIND COMMANDS. ** C ************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'FIND') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFOUST.EQ.'NO')GOTO1290 NUMCFS=NUMCST IF(NUMCST.LE.0)GOTO1290 DO1210I=1,NUMCST IFINST(I)=ISTRIN(I) 1210 CONTINUE 1290 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'FIND') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLP=ICURLN+1 C ISTART=ICURLP ISTOP=NUMLIN C C **************************** C ** STEP 4-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'FIND') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDFIN2(ISTRIN,NUMCST,J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1520 GOTO1510 C 1520 CONTINUE ICURLN=ILINE IF(IFEESW.EQ.'OFF')GOTO1529 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDFIND') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDFIND') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1529 CONTINUE IF(IALL.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=NUMLIN+1 IF(IFEESW.EQ.'OFF')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDFIND') ENDIF 1551 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDFIND') ENDIF 1552 FORMAT(10X,'[BOTTOM]') 1559 CONTINUE C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIND')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDFIND') WRITE(ICOUT,9011) CALL EDWRST('EDFIND') 9011 FORMAT('***** AT THE END OF EDFIND--') WRITE(ICOUT,9016)IWIDTH CALL EDWRST('EDFIND') 9016 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDFIND') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,ICURLN CALL EDWRST('EDFIND') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',4I8) WRITE(ICOUT,9019)IALL,IFOUST CALL EDWRST('EDFIND') 9019 FORMAT('IALL,IFOUST = ',A4,2X,A4) WRITE(ICOUT,999) CALL EDWRST('EDFIND') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDFIRS C C PURPOSE--GO TO FIRST LINE OF FILE C (= LINE 1) C C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDFI' ISUBN2='ST ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIRS')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDFIRS') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDFIRS') 51 FORMAT('***** AT THE BEGINNING OF EDFIRS--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO LINE 1 ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'FIRS') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=1 IF(ILINE.GT.NUMLIN)GOTO1150 C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121)(ICHA(J),J=J1,J2) CALL EDWRST('EDFIRS') ENDIF 1121 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDFIRS') ENDIF 1122 FORMAT(I6,':',3X,230A1) 1129 CONTINUE GOTO1190 C 1150 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDFIRS') ENDIF 1151 FORMAT('THE FILE IS EMPTY--THERE IS NO LINE 1.') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDFIRS') ENDIF 1152 FORMAT(10X,'THE FILE IS EMPTY--THERE IS NO LINE 1.') 1159 CONTINUE GOTO1190 C 1190 CONTINUE C ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'FIRS')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDFIRS') WRITE(ICOUT,9011) CALL EDWRST('EDFIRS') 9011 FORMAT('***** AT THE END OF EDFIRS--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDGETF(IFORIG) C C PURPOSE--STRIP OFF THE FILE NAME C FROM THE RUN LINE ON A VAX C THEREFORE, CAN SAY FED XXX C RATHER THAN FED C XXX C NOTE--THIS SUBROUTINE IS VAX-DEPENDENT. C DATE--OCTOBER 15, 1985 C C------------------------------------------------------------------------------ CHARACTER*80 IFORIG CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C CCCCC IF(IHOST1.EQ.'VAX ')IJUNK=CLI$GET_VALUE('PARAM1',IFORIG) CCCCC IF(IHOST1.EQ.'UNIX ')IJUNK=GETARG(etc.) C RETURN END SUBROUTINE EDGO(IMARK) C C PURPOSE--GO TO LINE K C C NOTE--IF NO ARGUMENTS, THEN GO TO CURRENT LINE C IF 1 ARGUMENT, THEN GO TO LINE K. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDGO' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'GO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDGO ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDGO ') 51 FORMAT('***** AT THE BEGINNING OF EDGO--') WRITE(ICOUT,52)IMARK CALL EDWRST('EDGO ') 52 FORMAT('IMARK = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO LINE K ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'GO') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C K=IMARK IF(NUMARG.GE.1.AND.IARGT(1).EQ.'NUMB')K=IARG(1) C ILINE=K C IF(ILINE.LT.1)GOTO1110 IF(ILINE.GT.NUMLIN)GOTO1120 GOTO1130 C 1110 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1119 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1111) CALL EDWRST('EDGO ') ENDIF 1111 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1112) CALL EDWRST('EDGO ') ENDIF 1112 FORMAT(10X,'[TOP]') 1119 CONTINUE ILINE=0 GOTO1190 C 1120 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121) CALL EDWRST('EDGO ') ENDIF 1121 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122) CALL EDWRST('EDGO ') ENDIF 1122 FORMAT(10X,'[BOTTOM]') 1129 CONTINUE ILINE=NUMLIN+1 GOTO1190 C 1130 CONTINUE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1139 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1131)(ICHA(J),J=J1,J2) CALL EDWRST('EDGO ') ENDIF 1131 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1132)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDGO ') ENDIF 1132 FORMAT(I6,':',3X,230A1) 1139 CONTINUE GOTO1190 C 1190 CONTINUE ICURLN=ILINE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'GO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDGO ') WRITE(ICOUT,9011) CALL EDWRST('EDGO ') 9011 FORMAT('***** AT THE END OF EDGO--') WRITE(ICOUT,9012)IMARK CALL EDWRST('EDGO ') 9012 FORMAT('IMARK = ',I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDGONU C C PURPOSE--THE ANALYST HAS ENTERED A LINE NUMBER-- C GO TO THAT LINE NUMBER. C C NOTE--NO ARGUMENTS ARE EXPECTED C (THE COMMAND IS THE LINE NUMBER) C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDGO' ISUBN2='NU ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'GONU')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDGONU') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDGONU') 51 FORMAT('***** AT THE BEGINNING OF EDGONU--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO LINE K ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'GONU') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ICOMI C IF(ILINE.LT.1)GOTO1110 IF(ILINE.GT.NUMLIN)GOTO1120 GOTO1130 C 1110 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1119 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1111) CALL EDWRST('EDGONU') ENDIF 1111 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1112) CALL EDWRST('EDGONU') ENDIF 1112 FORMAT(10X,'[TOP]') 1119 CONTINUE ILINE=0 GOTO1190 C 1120 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121) CALL EDWRST('EDGONU') ENDIF 1121 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122) CALL EDWRST('EDGONU') ENDIF 1122 FORMAT(10X,'[BOTTOM]') 1129 CONTINUE ILINE=NUMLIN+1 GOTO1190 C 1130 CONTINUE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1139 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1131)(ICHA(J),J=J1,J2) CALL EDWRST('EDGONU') ENDIF 1131 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1132)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDGONU') ENDIF 1132 FORMAT(I6,':',3X,230A1) 1139 CONTINUE GOTO1190 C 1190 CONTINUE ICURLN=ILINE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'GONU')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDGONU') WRITE(ICOUT,9011) CALL EDWRST('EDGONU') 9011 FORMAT('***** AT THE END OF EDGONU--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDHELP C C PURPOSE--READ THE HELP FILE AND WRITE IT OUT C (1 LINE AT A TIME) TO THE SCREEN. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED --JULY 1992. PRINT ONE PAGE AT A TIME C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 ITABID CHARACTER*4 IWORD1 CHARACTER*4 IWORD2 CHARACTER*4 IWORD3 CHARACTER*4 IWORD4 CHARACTER*4 IWOR12 C CHARACTER*1 ICHAR1 C CHARACTER*4 ICTEST C CHARACTER*4 IW1 CHARACTER*4 IW2 CHARACTER*4 IW3 CHARACTER*4 IW4 CHARACTER*4 IW5 C CHARACTER*4 IZ1 CHARACTER*4 IZ2 CHARACTER*4 IZ3 CHARACTER*4 IZ4 C CHARACTER*4 ICTEXT C CHARACTER*20 ISTRIN C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1992 CHARACTER*1 IYESNO C DIMENSION ITABID(100) DIMENSION ITABLN(100) C DIMENSION ICTEXT(20) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDHE' ISUBN2='LP ' C NUMLF=(-999) NUMSEC=(-999) ISECNA=(-999) C NUMAR2=(-999) C IWORD1=' ' IWORD2=' ' IWORD3=' ' IWORD4=' ' IWOR12=' ' C ICTEST=' ' C IW1=' ' IW2=' ' IW3=' ' IW4=' ' IW5=' ' C IZ1=' ' IZ2=' ' IZ3=' ' IZ4=' ' C JCHAR1=(-999) JSEC=(-999) JSECP1=(-999) C ISKIP=(-999) ISTART=(-999) ISTOP=(-999) C ISTRIN=' ' C NUMWOR=(-999) C ILOC2=(-999) ILOC3=(-999) ILOC4=(-999) C ILOC2P=(-999) ILOC3P=(-999) ILOC4P=(-999) C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1992 IYESNO=' ' C IFOUND='YES' IERROR='NO' C ISUBN1='EDHE' ISUBN2='LP ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HELP')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDHELP') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDHELP') 51 FORMAT('*****AT THE BEGINNING OF EDHELP--') WRITE(ICOUT,53)IHELNU CALL EDWRST('EDHELP') 53 FORMAT('IHELNU = ',I8) WRITE(ICOUT,54)IHELNA CALL EDWRST('EDHELP') 54 FORMAT('IHELNA = ',A80) WRITE(ICOUT,55)IHELST CALL EDWRST('EDHELP') 55 FORMAT('IHELST = ',A12) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************** C ** STEP 1-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IOUNIT=IHELNU IFILE=IHELNA ISTAT=IHELST IFORM=IHELFO IACCES=IHELAC IREWR=IHELRW ISUBN0='HELP' IERRFI='NO' C IF(IBUGE2.EQ.'OFF')GOTO1199 WRITE(ICOUT,1193)IOUNIT CALL EDWRST('EDHELP') 1193 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,1194)IFILE CALL EDWRST('EDHELP') 1194 FORMAT('IFILE = ',A80) WRITE(ICOUT,1195)ISTAT,IFORM,IACCES,IREWR CALL EDWRST('EDHELP') 1195 FORMAT('ISTAT,IFORM,IACCES,IREWR = ', 1A12,2X,A12,2X,A12,2X,A12) WRITE(ICOUT,1196)ISUBN0,IERRFI CALL EDWRST('EDHELP') 1196 FORMAT('ISUBN0,IERRFI = ',A4,2X,A4) 1199 CONTINUE C C ********************* C ** STEP 2-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO9000 C C ********************************************************** C ********************************************************** C ** STEP 2-- ** C ** COPY OVER THE FIRST 4 WORDS AFTER THE WORD HELP. ** C ********************************************************** C ********************************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IWORD1=IHARG(1) IWOR12=IHARG2(1) IWORD2=IHARG(2) IWORD3=IHARG(3) IWORD4=IHARG(4) C NUMAR2=NUMARG IF(NUMARG.LE.0)NUMAR2=1 IF(NUMARG.LE.0)IWORD1='OVER' C C ******************************************************** C ******************************************************** C ** STEP 3-- ** C ** STRIP OUT THE FIRST CHARACTER OF THE FIRST WORD. ** C ******************************************************** C ******************************************************** C ISTEPN='3' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICHAR1=IWORD1(1:1) C C ************************************************************ C ************************************************************ C ** STEP 4-- ** C ** READ IN FILE INFORMATION ** C ** FROM THE BEGINNING LINES OF THE FILE. ** C ** THE FIRST LINE CONTAINS THE ** C ** NUMBER OF LINES IN THE FILE (ANUMLF) (F10.0 FORMAT). ** C ** THE SECOND LINE CONTAINS THE NUMBER OF ** C ** SECTIONS IN THE FILE (ANUMSF) (F10.0 FORMAT) ** C ** THE NEXT ANUMSF LINES CONTAIN ** C ** THE THIRD LINE CONTAINS THE SECTION NUMBER ** C ** OF THE A SECTION (ASECNA) (F10.0 FORMAT). ** C ** THE STARTING LINE NUMBER OF EACH SECTION ** C ** IN THE FILE (ATABLN) (F10.0 FORMAT), AND ** C ** THE IDENTIFIER (IF ANY) FOR EACH SECTION ** C ** IN THE FILE (ITABID(.) (A4 FORMAT). ** C ************************************************************ C ************************************************************ C CCCCC READ(IOUNIT,1411)ANUMLF C1411 FORMAT(F10.0) CCCCC NUMLF=ANUMLF+0.5 NUMLF=1000000 READ(IOUNIT,1412)ANUMSF 1412 FORMAT(F10.0) NUMSEC=ANUMSF+0.5 READ(IOUNIT,1413)ASECNA 1413 FORMAT(F10.0) ISECNA=ASECNA+0.5 IF(NUMSEC.LE.0)GOTO1490 DO1420I=1,NUMSEC READ(IOUNIT,1421)ATABLN,ITABID(I) 1421 FORMAT(F10.0,A4) ITABLN(I)=ATABLN+0.5 IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN WRITE(ICOUT,1422)I,ATABLN,ITABLN(I),ITABID(I) CALL EDWRST('EDHELP') ENDIF 1422 FORMAT('I,ATABLN,ITABLN(I),ITABID(I) = ',I8,E15.7,I8,2X,A4) 1420 CONTINUE 1490 CONTINUE C C ******************************************************* C ******************************************************* C ** STEP 5-- ** C ** BASED ON THE FIRST CHARACTER OF THE FIRST WORD, ** C ** DO A TABLE LOOK-UP WHICH WILL SPECIFY ** C ** THE ABSOLUTE LINE NUMBER IN THE FILE ** C ** IN WHICH ALL COMMANDS STARTING OFF WITH THAT ** C ** CHARACTER WILL START. ** C ******************************************************* C ******************************************************* C ISTEPN='5' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C JCHAR1=ICHAR(ICHAR1) C JSEC=NUMSEC IF(65.LE.JCHAR1.AND.JCHAR1.LE.90)JSEC=JCHAR1-65+ISECNA IF(IWORD1.EQ.'OVER')JSEC=1 IF(IWORD1.EQ.'ABBR')JSEC=2 IF(IWORD1.EQ.'DEFA')JSEC=3 IF(IWORD1.EQ.'DEF')JSEC=3 IF(IWORD1.EQ.'EXAM')JSEC=4 IF(IWORD1.EQ.'FEAT')JSEC=5 IF(IWORD1.EQ.'HOST')JSEC=6 IF(IWORD1.EQ.'IMPL')JSEC=7 IF(IWORD1.EQ.'LANG')JSEC=8 IF(IWORD1.EQ.'MODE')JSEC=9 IF(IWORD1.EQ.'OUTP')JSEC=10 IF(IWORD1.EQ.'PORT')JSEC=11 IF(IWORD1.EQ.'SUMM')JSEC=12 IF(IWORD1.EQ.'TERM')JSEC=13 IF(IWORD1.EQ.'TUTO')JSEC=14 ISTART=ITABLN(JSEC) C IF(ISTART.LE.NUMLF)GOTO1509 WRITE(ICOUT,999) CALL EDWRST('EDHELP') WRITE(ICOUT,1501) CALL EDWRST('EDHELP') 1501 FORMAT('***** INTERNAL ERROR IN EDHELP--') WRITE(ICOUT,1502) CALL EDWRST('EDHELP') 1502 FORMAT('THE START LINE EXCEEDS THE NUMBER OF LINES.') WRITE(ICOUT,1503)IWORD1,JCHAR1,JSEC,JSECP1,ISTART,NUMLF CALL EDWRST('EDHELP') 1503 FORMAT('IWORD1,JCHAR1,JSEC,JSECP1,ISTART,NUMLF = ',6I8) IERROR='YES' GOTO8000 1509 CONTINUE C JSECP1=JSEC+1 ISTOP=NUMLF IF(JSECP1.LE.NUMSEC)ISTOP=ITABLN(JSECP1) IF(ISTOP.LE.ISTART)ISTOP=NUMLF IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HELP') 1GOTO1590 1511 FORMAT('***** FROM 1511 IN MIDDLE OF EDHELP--') WRITE(ICOUT,1512)ICHAR1,JCHAR1,IWORD1,IWOR12 CALL EDWRST('EDHELP') 1512 FORMAT('ICHAR1,JCHAR1,IWORD1,IWOR12 = ',A1,2X,I8,2X,A4,2X,A4) WRITE(ICOUT,1513)JSEC,JSECP1,ISTART,ISTOP CALL EDWRST('EDHELP') 1513 FORMAT('JSEC,JSECP1,ISTART,ISTOP = ',4I8) 1590 CONTINUE C C ************************************************* C ************************************************* C ** STEP 6-- ** C ** READ DOWN IN THE FILE TO ** C ** THE LINE BEFORE WHERE THE CHARACTER RESIDES** C ************************************************* C ************************************************* C ISTEPN='6' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C REWIND(IOUNIT) C ISKIP=ISTART-1 IF(ISKIP.LE.0)GOTO1690 DO1600I=1,ISKIP READ(IOUNIT,1605,END=1780) 1605 FORMAT() 1600 CONTINUE 1690 CONTINUE C C ****************************************************** C ****************************************************** C ** STEP 7-- ** C ** LOOP THROUGH THE VARIOUS LINES OF THIS SECTION ** C ** OF THE FILE. ** C ****************************************************** C ****************************************************** C ISTEPN='7' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C DO1700I=ISTART,ISTOP I2=I C C ***************************************** C ***************************************** C ** STEP 8-- ** C ** READ IN SUCCEEDING LINES UNTIL ** C ** GET A HIT BASED ON THE FIRST WORD ** C ** OF THE COMMAND. ** C ***************************************** C ***************************************** C READ(IOUNIT,1702,END=1780)IW1,IW2,IW3,IW4,IW5 1702 FORMAT(5A4) IF(IW1.EQ.' ')GOTO1700 ICTEST=IW1 IF(ICTEST(3:3).EQ.' ')ICTEST(3:4)=' ' IF(ICTEST(2:2).EQ.' ')ICTEST(2:4)=' ' CCCCC WRITE(ICOUT,1703)I,IW1,ICTEST,IWORD1,IWOR12 C1703 FORMAT('I,IW1,ICTEST,IWORD1,IWOR12 = ', CCCCC1I8,2X,A4,2X,A4,2X,A4,2X,A4) IF(ICTEST.EQ.IWORD1)GOTO1706 GOTO1700 1706 CONTINUE IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP')THEN WRITE(ICOUT,1707)I,IW1,IW2,IW3,IW4,IW5, 1 ICTEST,IWORD1,IWOR12 CALL EDWRST('EDHELP') ENDIF 1707 FORMAT('I,IW1,IW2,IW3,IW4,IW5,ICTEST,IWORD1,IWOR12 = ', 1I8,2X,5A4,2X,A4,2X,A4,2X,A4) C C *************************************** C *************************************** C ** STEP 9-- ** C ** IF GOT A HIT ON THE FIRST WORD, ** C ** CHECK FOR A HIT ON ALL WORDS ** C *************************************** C *************************************** C DO1710J=1,4 JP4=J+4 JP8=J+8 JP12=J+12 JP16=J+16 ISTRIN(J:J)=IW1(J:J) ISTRIN(JP4:JP4)=IW2(J:J) ISTRIN(JP8:JP8)=IW3(J:J) ISTRIN(JP12:JP12)=IW4(J:J) ISTRIN(JP16:JP16)=IW5(J:J) 1710 CONTINUE C NUMWOR=1 ILOC2=1 ILOC3=1 ILOC4=1 DO1720J=1,16 IF(ISTRIN(J:J).EQ.' ')GOTO1725 GOTO1720 1725 CONTINUE NUMWOR=NUMWOR+1 IF(NUMWOR.EQ.2)ILOC2=J+1 IF(NUMWOR.EQ.3)ILOC3=J+1 IF(NUMWOR.EQ.4)ILOC4=J+1 1720 CONTINUE C ILOC2P=ILOC2+3 ILOC3P=ILOC3+3 ILOC4P=ILOC4+3 IZ1=IW1 IZ2(1:4)=' ' IF(NUMWOR.GE.2)IZ2(1:4)=ISTRIN(ILOC2:ILOC2P) IZ3(1:4)=' ' IF(NUMWOR.GE.3)IZ3(1:4)=ISTRIN(ILOC3:ILOC3P) IZ4(1:4)=' ' IF(NUMWOR.GE.4)IZ4(1:4)=ISTRIN(ILOC4:ILOC4P) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HELP') 1GOTO1739 WRITE(ICOUT,1731) CALL EDWRST('EDHELP') 1731 FORMAT('***** FROM 1731 IN MIDDLE OF EDHELP--') WRITE(ICOUT,1732)IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 CALL EDWRST('EDHELP') 1732 FORMAT('IWORD1,IWORD2,IWORD3,IWORD4,IWOR12 = ', 1A4,2X,A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,1733)IW1,IW2,IW3,IW4,IW5 CALL EDWRST('EDHELP') 1733 FORMAT('IW1,IW2,IW3,IW4,IW5 = ',A4,2X,A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,1734)IZ1,IZ2,IZ3,IZ4 CALL EDWRST('EDHELP') 1734 FORMAT('IZ1,IZ2,IZ3,IZ4 = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,1735)ISTRIN CALL EDWRST('EDHELP') 1735 FORMAT('ISTRIN = ',A20) WRITE(ICOUT,1736)NUMWOR CALL EDWRST('EDHELP') 1736 FORMAT('NUMWOR = ',I8) WRITE(ICOUT,1737)ILOC2,ILOC3,ILOC4 CALL EDWRST('EDHELP') 1737 FORMAT('ILOC2,ILOC3,ILOC4 = ',3I8) WRITE(ICOUT,1738)ILOC2P,ILOC3P,ILOC4P CALL EDWRST('EDHELP') 1738 FORMAT('ILOC2P,ILOC3P,ILOC4P = ',3I8) 1739 CONTINUE C 1752 CONTINUE IF(NUMAR2.LE.1)GOTO1790 IF(NUMWOR.LE.1)GOTO1790 IF(IZ2.EQ.IWORD2)GOTO1753 GOTO1700 C 1753 CONTINUE IF(NUMAR2.LE.2)GOTO1790 IF(NUMWOR.LE.2)GOTO1790 IF(IZ3.EQ.IWORD3)GOTO1754 GOTO1700 C 1754 CONTINUE IF(NUMAR2.LE.3)GOTO1790 IF(NUMWOR.LE.3)GOTO1790 IF(IZ4.EQ.IWORD4)GOTO1790 GOTO1700 C 1700 CONTINUE C 1780 CONTINUE IERROR='YES' WRITE(ICOUT,999) CALL EDWRST('EDHELP') WRITE(ICOUT,1781) CALL EDWRST('EDHELP') 1781 FORMAT('***** ERROR IN EDHELP--') WRITE(ICOUT,1782) CALL EDWRST('EDHELP') 1782 FORMAT(' THE SPECIFIED COMMAND FOR WHICH') WRITE(ICOUT,1783) CALL EDWRST('EDHELP') 1783 FORMAT(' HELP WAS DESIRED WAS NOT FOUND') WRITE(ICOUT,1784) CALL EDWRST('EDHELP') 1784 FORMAT(' IN THE HELP FILE.') WRITE(ICOUT,1785) CALL EDWRST('EDHELP') 1785 FORMAT(' THE ENTERED COMMAND LINE WAS AS FOLLOWS--') WRITE(ICOUT,1786)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDHELP') 1786 FORMAT(' ',230A1) GOTO8000 C 1790 CONTINUE C C **************************************************** C **************************************************** C ** STEP 10-- ** C ** IF HAVE A HIT ON ALL WORDS, ** C ** THEN READ IN AND WRITE OUT ** C ** THE ENTIRE TEXT DESCRIPTION ASSOCIATED WITH ** C ** THE DESIRED COMMAND. ** C ** THIS DESCRIPTION WILL START ON THE NEXT LINE ** C ** AND WILL FINISH WITH A LINE OF HYPHENS. ** C **************************************************** C **************************************************** C ISTEPN='10' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC THE FOLLOWING LINE WAS ADDED JULY 1992 K=0 C WRITE(ICOUT,999) CALL EDWRST('EDHELP') CCCCC DO2000I=1,2 DO2000I=1,100000 READ(IOUNIT,2005,END=2090)(ICTEXT(J),J=1,20) 2005 FORMAT(20A4) IF(ICTEXT(1).EQ.'----')GOTO2090 C DO2010J=1,20 JREV=20-J+1 IF(ICTEXT(JREV).NE.' ')GOTO2015 2010 CONTINUE 2015 CONTINUE JMAX=JREV C WRITE(ICOUT,2006)(ICTEXT(J),J=1,JMAX) CALL EDWRST('EDHELP') 2006 FORMAT(20A4) C CCCCC THE FOLLOWING SECTION WAS ADDED JULY 1992 CCCCC SO THAT HELP INFO WOULD COME OUT 1 PAGE AT A TIME JULY 1992 K=K+1 IF(K.GE.20)THEN WRITE(ICOUT,2007) CALL EDWRST('EDHELP') 2007 FORMAT(' More...?') READ(IRD,2008)IYESNO 2008 FORMAT(A1) IF(IYESNO.EQ.'N')GOTO2090 K=0 ENDIF C 2000 CONTINUE C 2090 CONTINUE C C *********************************************** C *********************************************** C ** STEP 11-- ** C ** CLOSE THE HELP FILE. ** C *********************************************** C *********************************************** C ISTEPN='11' C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C 8000 CONTINUE C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HELP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C **************** C **************** C ** STEP 90-- ** C ** EXIT. ** C **************** C **************** C 9000 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDHELP') IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HELP')GOTO9090 WRITE(ICOUT,9011) CALL EDWRST('EDHELP') 9011 FORMAT('***** AT THE END OF EDHELP--') WRITE(ICOUT,9012)ISKIP,ISTART,ISTOP,JMAX CALL EDWRST('EDHELP') 9012 FORMAT('ISKIP,ISTART,ISTOP,JMAX = ',4I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 9090 CONTINUE C RETURN END SUBROUTINE EDHOLD C C PURPOSE--HOLD (= SAVE) THE CURRENT LINE C COMMAND SYNTAX--HOLD WHERE IS BLANK, OR 1 TO 10 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*240 ISTRIN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDHO' ISUBN2='LD ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C NUMCST=(-999) ISTRIN(1:1)=' ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HOLD')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDHOLD') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDHOLD') 51 FORMAT('***** AT THE BEGINNING OF EDHOLD--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE HELD ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HOLD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ICURLN IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 IF(J1.GT.J2)GOTO1190 IF(N1.LE.0)GOTO1190 DO1100J=J1,J2 I=I+1 ISTRIN(I:I)=ICHA(J) 1100 CONTINUE 1190 CONTINUE NUMCST=I C IF(NUMCST.LE.0)ISTRIN(1:1)=' ' IF(NUMCST.LE.0)NUMCST=1 C C ******************************************************* C ** STEP 2-- ** C ** COPY THE STRING ** C ** INTO IHOLS1, IHOLS2, IHOLS3, ..., OR IHOLS10. ** C ******************************************************* C C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'HOLD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IARG1=1 IF(NUMARG.GE.1)IARG1=IARG(1) C IF(IARG1.EQ.1)NCHH1=NUMCST IF(IARG1.EQ.2)NCHH2=NUMCST IF(IARG1.EQ.3)NCHH3=NUMCST IF(IARG1.EQ.4)NCHH4=NUMCST IF(IARG1.EQ.5)NCHH5=NUMCST IF(IARG1.EQ.6)NCHH6=NUMCST IF(IARG1.EQ.7)NCHH7=NUMCST IF(IARG1.EQ.8)NCHH8=NUMCST IF(IARG1.EQ.9)NCHH9=NUMCST IF(IARG1.EQ.10)NCHH10=NUMCST C IF(NUMCST.LE.0)GOTO1290 DO1200I=1,NUMCST IF(IARG1.EQ.1)IHOLS1(I:I)=ISTRIN(I:I) IF(IARG1.EQ.2)IHOLS2(I:I)=ISTRIN(I:I) IF(IARG1.EQ.3)IHOLS3(I:I)=ISTRIN(I:I) IF(IARG1.EQ.4)IHOLS4(I:I)=ISTRIN(I:I) IF(IARG1.EQ.5)IHOLS5(I:I)=ISTRIN(I:I) IF(IARG1.EQ.6)IHOLS6(I:I)=ISTRIN(I:I) IF(IARG1.EQ.7)IHOLS7(I:I)=ISTRIN(I:I) IF(IARG1.EQ.8)IHOLS8(I:I)=ISTRIN(I:I) IF(IARG1.EQ.9)IHOLS9(I:I)=ISTRIN(I:I) IF(IARG1.EQ.10)IHOL10(I:I)=ISTRIN(I:I) 1200 CONTINUE 1290 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'HOLD')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDHOLD') WRITE(ICOUT,9011) CALL EDWRST('EDHOLD') 9011 FORMAT('***** AT THE END OF EDHOLD--') WRITE(ICOUT,9016)ICURLN,IARG1 CALL EDWRST('EDHOLD') 9016 FORMAT('ICURLN,IARG1 = ',2I8) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDHOLD') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)NUMCST CALL EDWRST('EDHOLD') 9018 FORMAT('NUMCST = ',A4) WRITE(ICOUT,9019)(ISTRIN(I:I),I=1,NUMCST) CALL EDWRST('EDHOLD') 9019 FORMAT('(ISTRIN(I:I),I=1,NUMCST) = ',80A1) WRITE(ICOUT,999) CALL EDWRST('EDHOLD') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDIND2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C PURPOSE--INDENT THE LINE IN IOLDLI(.). C THE INDENTED LINE WILL BE PLACED IN INEWLI(.). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(*) DIMENSION INEWLI(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='N2 ' C IINDE2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'IND2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDIND2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDIND2') 51 FORMAT('***** AT THE BEGINNING OF EDIND2--') WRITE(ICOUT,71)NUMCOL CALL EDWRST('EDIND2') 71 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,72)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDIND2') 72 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,73)NUMCNL CALL EDWRST('EDIND2') 73 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,74)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDIND2') 74 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,81)IINDEC CALL EDWRST('EDIND2') 81 FORMAT('IINDEC = ',I8) 90 CONTINUE C C ************************************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST NON-BLANK CHARACTER IN IOLDLI(.) ** C ************************************************************ C I2=0 IF(NUMCOL.LE.0)GOTO1190 DO1100I=1,NUMCOL I2=I IF(IOLDLI(I2).NE.' ')GOTO1190 1100 CONTINUE I2=NUMCOL+1 1190 CONTINUE IFIRST=I2 C C ******************************** C ** STEP 2-- ** C ** BLANK OUT THE NEW STRING ** C ******************************** C NUMCNL=1 DO1500I=1,240 INEWLI(I)=' ' 1500 CONTINUE C C ************************************** C ** STEP 3-- ** C ** FORM THE NEW (INDENTED) STRING ** C ************************************** C INEW=1 IF(IFIRST.LE.0)GOTO1690 IF(IFIRST.GT.NUMCOL)GOTO1690 IINDE2=IINDEC IF(IINDE2.LE.0)IINDE2=1 INEW=IINDE2-1 DO1600IOLD=IFIRST,NUMCOL INEW=INEW+1 IF(INEW.LT.1)GOTO1600 IF(INEW.GT.240)GOTO1600 INEWLI(INEW)=IOLDLI(IOLD) 1600 CONTINUE 1690 CONTINUE NUMCNL=INEW C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'IND2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDIND2') WRITE(ICOUT,9011) CALL EDWRST('EDIND2') 9011 FORMAT('***** AT THE END OF EDIND2--') WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDIND2') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDIND2') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDIND2') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDIND2') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)IINDEC,IINDE2 CALL EDWRST('EDIND2') 9041 FORMAT('IINDEC,IINDE2 = ',2I8) 9090 CONTINUE C RETURN END SUBROUTINE EDINDE C C PURPOSE--INDENT CURRENT LINE C (AND NEXT IARG2-1 LINES) C IARG1 SPACES C SYNTAX--INDENT C WHERE = NUMBER OF SPACES (DEFAULT = 5) C AND = NUMBER OF LINES (DEFAULT = 1) C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(240) DIMENSION INEWLI(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='DE ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INDE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDINDE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDINDE') 51 FORMAT('***** AT THE BEGINNING OF EDINDE--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE INDENTED. ** C ************************************ C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ICURLN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ICURLN GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) ISTART=ICURLN ISTOP=ISTART+IARG1-1 GOTO1190 C 1120 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) IARG2=NUMLIN+1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) ISTART=IARG1 ISTOP=IARG2 GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ******************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES TO BE INDENTED ** C ******************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART-1 2100 CONTINUE ILINE=ILINE+1 IF(ILINE.LE.ISTOP)GOTO2910 ILINE=ISTOP GOTO2900 2910 CONTINUE ICURLN=ILINE IF(ILINE.LT.1)GOTO2100 IF(ILINE.GT.NUMLIN)GOTO2900 C C ***************************** C ** STEP 22-- ** C ** COPY THE OLD LINE ** C ***************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 DO2200J=J1,J2 I=I+1 IOLDLI(I)=ICHA(J) 2200 CONTINUE NUMCOL=I C C *********************************** C ** STEP 23-- ** C ** APPLY THE DESIRED INDENTING ** C ** TO THE TARGET LINE, ** C ** SO AS TO CREATE ** C ** A NEW LINE. ** C *********************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDIND2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C *************************************** C ** STEP 24-- ** C ** DETERMINE IF ROOM EXISTS IN THE ** C ** MAIN INTERNAL CHARACTER ARRAY ** C ** FOR THE NEW INDENTED LINE. ** C *************************************** C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH9=NUMCHA+NUMCNL CALL EDCHSI(NUMCH9) IF(IERROR.EQ.'YES')GOTO9000 C 2450 CONTINUE IF(ILINE.LT.1)GOTO2460 IF(ILINE.GT.NUMLIN)GOTO2470 GOTO2490 C 2460 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2461) CALL EDWRST('EDINDE') ENDIF 2461 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2462) CALL EDWRST('EDINDE') ENDIF 2462 FORMAT(10X,'[TOP]') 2469 CONTINUE GOTO2100 C 2470 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2471) CALL EDWRST('EDINDE') ENDIF 2471 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2472) CALL EDWRST('EDINDE') ENDIF 2472 FORMAT(10X,'[BOTTOM]') 2479 CONTINUE GOTO9000 C 2490 CONTINUE C C *************************************** C ** STEP 25-- ** C ** UPDATE THE MAIN CHARACTER ARRAY ** C ** WITH THE NEW LINE. ** C *************************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INDE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J1=NUMCHA+1 N1=NUMCNL J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ILINE)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2500J=J1,J2 I=I+1 ICHA(J)=INEWLI(I) 2500 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 C IF(IFEESW.EQ.'OFF')GOTO2629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2621)(ICHA(J),J=J1,J2) CALL EDWRST('EDINDE') ENDIF 2621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2622)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDINDE') ENDIF 2622 FORMAT(I6,':',3X,230A1) 2629 CONTINUE C GOTO2100 C 2900 CONTINUE IF(ILINE.LE.NUMLIN)GOTO2919 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2911) CALL EDWRST('EDINDE') ENDIF 2911 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2912) CALL EDWRST('EDINDE') ENDIF 2912 FORMAT(10X,'[BOTTOM]') 2919 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INDE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDINDE') WRITE(ICOUT,9011) CALL EDWRST('EDINDE') 9011 FORMAT('***** AT THE END OF EDINDE--') WRITE(ICOUT,999) CALL EDWRST('EDINDE') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDINDE') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDINDE') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDINDE') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDINDE') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDINDE') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDINDE') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)ICURLN,ISTART,ISTOP CALL EDWRST('EDINDE') 9041 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9042)J1,N1,J2 CALL EDWRST('EDINDE') 9042 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDINDE') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDINFI(IFILE,IEXIST,ISUBN0,IERRFI) C C PURPOSE--INQUIRE ABOUT THE EXISTENCE OF A FILE C (BUT THERE MAY BE SOME SMALL DIFFERENCES C IN HOW THAT IS DONE FOR DIFFERENT COMPUTERS). C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JULY 1986. C C------------------------------------------------------------------------------ C CHARACTER*80 IFILE CHARACTER*4 IEXIST CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI C LOGICAL LEXIST C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='FI ' C IFOUND='YES' IERROR='NO' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'INFI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDINFI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDINFI') 51 FORMAT('*****AT THE BEGINNING OF EDINFI--') WRITE(ICOUT,52)IFILE CALL EDWRST('EDINFI') 52 FORMAT('IFILE = ',A80) WRITE(ICOUT,54)IEXIST CALL EDWRST('EDINFI') 54 FORMAT('IEXIST = ',A4) WRITE(ICOUT,55)ISUBN0 CALL EDWRST('EDINFI') 55 FORMAT('ISUBN0 = ',A4) WRITE(ICOUT,56)IERRFI CALL EDWRST('EDINFI') 56 FORMAT('IERRFI = ',A4) WRITE(ICOUT,61)IHOST1 CALL EDWRST('EDINFI') 61 FORMAT('IHOST1 = ',A4) 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** INQUIRE ABOUT THE EXISTENCE OF A FILE. ** C ******************************************************** C ISTEPN='1' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'INFI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IHOST1.EQ.'VAX')GOTO1100 GOTO1200 C 1100 CONTINUE INQUIRE(FILE=IFILE,EXIST=LEXIST) IEXIST='NO' IF(LEXIST)IEXIST='YES' GOTO9000 C 1200 CONTINUE INQUIRE(FILE=IFILE,EXIST=LEXIST) IEXIST='NO' IF(LEXIST)IEXIST='YES' GOTO9000 C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'INFI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDINFI') WRITE(ICOUT,9011) CALL EDWRST('EDINFI') 9011 FORMAT('*****AT THE END OF EDINFI--') WRITE(ICOUT,9012)IFILE CALL EDWRST('EDINFI') 9012 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IEXIST CALL EDWRST('EDINFI') 9014 FORMAT('IEXIST = ',A4) WRITE(ICOUT,9015)ISUBN0 CALL EDWRST('EDINFI') 9015 FORMAT('ISUBN0 = ',A4) WRITE(ICOUT,9016)IERRFI CALL EDWRST('EDINFI') 9016 FORMAT('IERRFI = ',A4) WRITE(ICOUT,9021)IHOST1 CALL EDWRST('EDINFI') 9021 FORMAT('IHOST1 = ',A4) 9090 CONTINUE RETURN END SUBROUTINE EDININ C C PURPOSE--WHILE IN INPUT MODE, INSERT A LINE OF TEXT C (IMMEDIATELY AFTER CURRENT LINE). C THE ENTIRE STRING IN IANS(.) WILL BE INSERTED. C IF NO STRING IS IN IANS(.), C THEN A BLANK LINE (CONSISTING OF 1 BLANK CHARACTER) C WILL BE INSERTED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='IN ' C IFOUND='YES' IERROR='NO' C IFIRBL=(-999) J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ININ')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDININ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDININ') 51 FORMAT('***** AT THE BEGINNING OF EDININ--') WRITE(ICOUT,52)IWIDTH CALL EDWRST('EDININ') 52 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,53)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDININ') 53 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 2-- ** C ** DETERMINE THE STRING TO BE INSERTED ** C ******************************************* C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ININ') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTRIN(1)=' ' NUMCST=1 C IF(IWIDTH.LE.0)GOTO1190 DO1130I=1,IWIDTH ISTRIN(I)=IANS(I) IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ININ')THEN WRITE(ICOUT,1131)I,IWIDTH,NUMCST,IANS(I),ISTRIN(I) CALL EDWRST('EDININ') ENDIF 1131 FORMAT('I,IWIDTH,NUMCST,IANS(I),ISTRIN(I) = ',3I8,2X,A1,2X,A1) 1130 CONTINUE NUMCST=IWIDTH GOTO1190 C 1190 CONTINUE IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ININ')THEN WRITE(ICOUT,1191)NUMCST,(ISTRIN(I),I=1,40) CALL EDWRST('EDININ') ENDIF 1191 FORMAT('NUMCST,(ISTRIN(I),I=1,20) = ',I8,2X,80A1) C C **************************** C ** STEP 3-- ** C ** INSERT THE LINE. ** C **************************** C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ININ') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH2=NUMCHA+NUMCST CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C 1550 CONTINUE IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURLN+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO1569 IF(NUMLIN.LE.0)GOTO1569 IF(ICURLP.GT.NUMLIN)GOTO1569 DO1560ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 1560 CONTINUE 1569 CONTINUE C J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO1570J=J1,J2 I=I+1 ICHA(J)=ISTRIN(I) 1570 CONTINUE 1579 CONTINUE ICURLN=ICURLP NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ININ')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDININ') WRITE(ICOUT,9011) CALL EDWRST('EDININ') 9011 FORMAT('***** AT THE END OF EDININ--') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDININ') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDININ') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDININ') 9014 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDININ') 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9016)IFIRBL CALL EDWRST('EDININ') 9016 FORMAT('IFIRBL = ',I8) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDININ') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDININ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDINLI(ICNEWL,NCNEWL,ICURL2) C C PURPOSE--INSERT THE LINE IN ICNEWL C (WHICH CONSISTS OF NCNEWL CHARACTERS) C IMMEDIATELY AFTER LINE ICURL2 C (ICURL2 IS THE PSEUDO-CURRENT LINE NUMBER). C CAUTION--THE INPUT ARGUMENT ICURL2 MAY BE CHANGED C WITHIN THIS SUBROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICNEWL CHARACTER*1 ISTRIN CCCCC CHARACTER*4 IFOUST C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='LI ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INLI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDINLI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDINLI') 51 FORMAT('***** AT THE BEGINNING OF EDINLI--') WRITE(ICOUT,52)NCNEWL CALL EDWRST('EDINLI') 52 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,53)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDINLI') ENDIF 53 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) WRITE(ICOUT,54)ICURL2 CALL EDWRST('EDINLI') 54 FORMAT('ICURL2 = ',I8) WRITE(ICOUT,61)ITABC CALL EDWRST('EDINLI') 61 FORMAT('ITABC = ',I8) WRITE(ICOUT,62)ICURL2,NUMLIN CALL EDWRST('EDINLI') 62 FORMAT('ICURL2,NUMLIN = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************** C ** STEP 10-- ** C ** SAVE THE CURRENT POINTERS ** C ** (FOR POSSIBLE LATER USE ** C ** BY THE UNDO COMMAND) ** C ********************************** C ISTEPN='10' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INLI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSACP C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE STRING TO BE INSERTED ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INLI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC CALL EDEXST(ISTRIN,NUMCST,IFOUST) CCCCC IFOUST='YES' IF(NCNEWL.LE.0)GOTO1111 DO1110I=1,NCNEWL ISTRIN(I)=ICNEWL(I:I) 1110 CONTINUE 1111 CONTINUE NUMCST=NCNEWL C ITABM1=ITABC-1 IF(ITABM1.LE.0)GOTO1290 C IF(NUMCST.LE.0)GOTO1190 DO1120I=1,NUMCST IREV=NUMCST-I+1 IREV2=IREV+ITABM1 ISTRIN(IREV2)=ISTRIN(IREV) 1120 CONTINUE 1190 CONTINUE C DO1200I=1,ITABM1 ISTRIN(I)=' ' 1200 CONTINUE C 1290 CONTINUE NUMCST=NUMCST+ITABM1 C C **************************** C ** STEP 12-- ** C ** INSERT THE LINE. ** C **************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INLI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH2=NUMCHA+NUMCST CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C 1550 CONTINUE IF(ICURL2.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURL2+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO1569 IF(NUMLIN.LE.0)GOTO1569 IF(ICURLP.GT.NUMLIN)GOTO1569 DO1560ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 1560 CONTINUE 1569 CONTINUE C J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO1570J=J1,J2 I=I+1 ICHA(J)=ISTRIN(I) 1570 CONTINUE 1579 CONTINUE ICURL2=ICURLP NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INLI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDINLI') WRITE(ICOUT,9011) CALL EDWRST('EDINLI') 9011 FORMAT('***** AT THE END OF EDINLI--') WRITE(ICOUT,9012)NCNEWL CALL EDWRST('EDINLI') 9012 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,9013)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDINLI') ENDIF 9013 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) WRITE(ICOUT,9014)ICURL2 CALL EDWRST('EDINLI') 9014 FORMAT('ICURL2 = ',I8) WRITE(ICOUT,9021)NUMCST CALL EDWRST('EDINLI') 9021 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9022)(ISTRIN(I),I=1,100) CALL EDWRST('EDINLI') 9022 FORMAT('(ISTRIN(I),I=1,100) = ',100A1) WRITE(ICOUT,9031)J1,N1,J2 CALL EDWRST('EDINLI') 9031 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9032)NUMCST,ITABC,ITABM1 CALL EDWRST('EDINLI') 9032 FORMAT('NUMCST,ITABC,ITABM1 = ',3I8) WRITE(ICOUT,9033)ICURL2,NUMLIN CALL EDWRST('EDINLI') 9033 FORMAT('ICURL2,NUMLIN = ',2I8) WRITE(ICOUT,999) CALL EDWRST('EDINLI') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDINPU C C PURPOSE--CHANGE TO INPUT MODE (FROM EDIT MODE) C C DATE--JANUARY 24,1985 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDIN' ISUBN2='PU ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INPU')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDINPU') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDINPU') 51 FORMAT('*****AT THE BEGINNING OF EDINPU--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IMODE='INPU' C CCCCC IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDINPU') ENDIF 1151 FORMAT('YOU HAVE JUST ENTERED INPUT MODE') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDINPU') ENDIF 1152 FORMAT(10X,'YOU HAVE JUST ENTERED INPUT MODE') 1159 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INPU')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDINPU') WRITE(ICOUT,9011) CALL EDWRST('EDINPU') 9011 FORMAT('*****AT THE END OF EDINPU--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDINSE C C PURPOSE--INSERT 1 LINE OF TEXT (AFTER CURRENT LINE). C THE STRING WHICH FOLLOWS THE INSERT COMMAND C WILL BE INSERTED. C IF NO STRING FOLLOWS THE INSERT COMMAND, C THEN A BLANK LINE (CONSISTING OF 1 BLANK CHARACTER) C WILL BE INSERTED. C COMMAND SYNTAX--INSERT C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDIN' ISUBN2='SE ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDINSE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDINSE') 51 FORMAT('***** AT THE BEGINNING OF EDINSE--') WRITE(ICOUT,52)ITABC CALL EDWRST('EDINSE') 52 FORMAT('ITABC = ',I8) WRITE(ICOUT,53)ICURLN,NUMLIN CALL EDWRST('EDINSE') 53 FORMAT('ICURLN,NUMLIN = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************** C ** STEP 10-- ** C ** SAVE THE CURRENT POINTERS ** C ** (FOR POSSIBLE LATER USE ** C ** BY THE UNDO COMMAND) ** C ********************************** C ISTEPN='10' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DELE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSACP C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE STRING TO BE INSERTED ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INSE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) C ITABM1=ITABC-1 IF(ITABM1.LE.0)GOTO1290 C IF(NUMCST.LE.0)GOTO1190 DO1100I=1,NUMCST IREV=NUMCST-I+1 IREV2=IREV+ITABM1 ISTRIN(IREV2)=ISTRIN(IREV) 1100 CONTINUE 1190 CONTINUE C DO1200I=1,ITABM1 ISTRIN(I)=' ' 1200 CONTINUE C 1290 CONTINUE NUMCST=NUMCST+ITABM1 C C **************************** C ** STEP 12-- ** C ** INSERT THE LINE. ** C **************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'INSE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH2=NUMCHA+NUMCST CALL EDCHSI(NUMCH2) IF(IERROR.EQ.'YES')GOTO9000 C 1550 CONTINUE IF(ICURLN.GT.NUMLIN)ICURLN=NUMLIN ICURLP=ICURLN+1 NUMLP1=NUMLIN+1 NUMRP1=NUMROW+1 C IHOLD1=IPOINT(ICURLP) IPOINT(ICURLP)=NUMRP1 C IF(ICURLP.LE.0)GOTO1569 IF(NUMLIN.LE.0)GOTO1569 IF(ICURLP.GT.NUMLIN)GOTO1569 DO1560ILINE=ICURLP,NUMLIN ILINEP=ILINE+1 IHOLD2=IPOINT(ILINEP) IPOINT(ILINEP)=IHOLD1 IHOLD1=IHOLD2 1560 CONTINUE 1569 CONTINUE C J1=NUMCHA+1 N1=NUMCST J2=J1+(N1-1) C IROW=NUMRP1 ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO1570J=J1,J2 I=I+1 ICHA(J)=ISTRIN(I) 1570 CONTINUE 1579 CONTINUE ICURLN=ICURLP NUMLIN=NUMLP1 NUMROW=NUMRP1 NUMCHA=J2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDINSE') WRITE(ICOUT,9011) CALL EDWRST('EDINSE') 9011 FORMAT('***** AT THE END OF EDINSE--') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDINSE') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDINSE') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDINSE') 9014 FORMAT('NUMCST = ',I8) WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDINSE') 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDINSE') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)NUMCST,ITABC,ITABM1 CALL EDWRST('EDINSE') 9018 FORMAT('NUMCST,ITABC,ITABM1 = ',3I8) WRITE(ICOUT,9019)ICURLN,NUMLIN CALL EDWRST('EDINSE') 9019 FORMAT('ICURLN,NUMLIN = ',2I8) WRITE(ICOUT,999) CALL EDWRST('EDINSE') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDJUST(ICNEWL,NCNEWL,ICOLL1,ICOLL2) C C PURPOSE--TAKE THE TEXT IN COLUMNS ICOLL1 TO ICOLL2 C OF ICNEWL AND MAKE IT HAVE SPECIFIED JUSTIFICATION C (AS DEFINED BY THE COMMON VARIABLE IJUST)-- C LEFT (THE DEFAULT) C BOTH C RIGHT C FORTRAN C THE 240-CHARACTER VARIABLE ICNEWL C CONSISTS OF NCNEWL CHARACTERS. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICNEWL CHARACTER*240 ICNEW2 CHARACTER*240 ICWORD CHARACTER*4 IFOUWO C CHARACTER*4 ICASFO C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDJU' ISUBN2='ST ' C CALL EDZERO(ICNEW2,NCNEW2) NUMTRB=(-999) NUMWOR=(-999) NUMGAP=(-999) IRATIO=(-999) IREM=(-999) IREM2=(-999) C ICASFO='-999' NUMBEB=(-999) ICNB=(-999) NUMCLA=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'JUST')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDJUST') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDJUST') 51 FORMAT('***** AT THE BEGINNING OF EDJUST--') WRITE(ICOUT,52)IJUST CALL EDWRST('EDJUST') 52 FORMAT('IJUST = ',A4) WRITE(ICOUT,53)NCNEWL,ICOLL1,ICOLL2 CALL EDWRST('EDJUST') 53 FORMAT('NCNEWL,ICOLL1,ICOLL2 = ',3I8) WRITE(ICOUT,54)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDJUST') 54 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) 90 CONTINUE C C *********************************************** C ** STEP 10-- ** C ** BRANCH TO THE SPECIFIED CASE-- ** C *********************************************** C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IJUST.EQ.'LEFT')GOTO9000 IF(IJUST.EQ.'RIGH')GOTO2000 IF(IJUST.EQ.'BOTH')GOTO3000 IF(IJUST.EQ.'FORT')GOTO4000 GOTO9000 C C *********************************************** C ** STEP 20-- ** C ** TREAT THE RIGHT JUSTIFICATION CASE ** C *********************************************** C 2000 CONTINUE C ISTEPN='20' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C *********************************************** C ** STEP 21-- ** C ** DETERMINE THE NUMBER OF TRAILING BLANKS ** C *********************************************** C 2100 CONTINUE C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J=0 DO2110I=ICOLL1,ICOLL2 J=J+1 IREV=ICOLL2-I+ICOLL1 IF(ICNEWL(IREV:IREV).NE.' ')GOTO2120 2110 CONTINUE GOTO9000 2120 CONTINUE NUMTRB=J-1 NUMBEG=(ICOLL2-ICOLL1+1)-NUMTRB IF(NUMTRB.LE.0)GOTO9000 C C ******************************************* C ** STEP 22-- ** C ** FORM THE NEW LINE ** C ******************************************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDZERO(ICNEW2,NCNEW2) DO2210I=1,NUMBEG IP=I+NUMTRB ICNEW2(IP:IP)=ICNEWL(I:I) 2210 CONTINUE NCNEW2=IP C C **************************************************** C ** STEP 23-- ** C ** COPY THE SECOND NEW LINE BACK INTO THE FIRST ** C **************************************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C DO2300I=ICOLL1,ICOLL2 ICNEWL(I:I)=ICNEW2(I:I) 2300 CONTINUE NCNEWL=NCNEW2 GOTO9000 C C *********************************************** C ** STEP 30-- ** C ** TREAT THE BOTH JUSTIFICATION CASE ** C *********************************************** C 3000 CONTINUE C ISTEPN='30' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C *********************************************** C ** STEP 31-- ** C ** DETERMINE THE NUMBER OF TRAILING BLANKS ** C *********************************************** C 3100 CONTINUE C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J=0 DO3110I=ICOLL1,ICOLL2 J=J+1 IREV=ICOLL2-I+ICOLL1 IF(ICNEWL(IREV:IREV).NE.' ')GOTO3120 3110 CONTINUE GOTO9000 3120 CONTINUE NUMTRB=J-1 IF(NUMTRB.LE.0)GOTO9000 C C ******************************************* C ** STEP 32-- ** C ** DETERMINE THE NUMBER OF WORDS ** C ******************************************* C ISTEPN='32' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IC1=ICOLL1 IC2=ICOLL2 IC3=0 IC4=IC2 C NUMWOR=0 DO3200IW=1,NCNEWL C IF(IW.GE.2)IC1=IC4+1 IF(IC1.GT.IC2)GOTO3290 CALL EDZERO(ICWORD,NCWORD) CALL EDEXWO(ICNEWL,NCNEWL,IC1,IC2,IC3,IC4, 1ICWORD,NCWORD,IFOUWO) IF(IFOUWO.EQ.'NO')GOTO3290 NUMWOR=NUMWOR+1 C 3200 CONTINUE 3290 CONTINUE C C ******************************************* C ** STEP 33-- ** C ** DETERMINE THE NUMBER OF GAPS ** C ** AND THE NUMBER OF ADDITIONAL ** C ** BLANKS PER GAP. ** C ******************************************* C ISTEPN='33' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMGAP=NUMWOR-1 IRATIO=NUMTRB/NUMGAP IREM=NUMTRB-IRATIO*NUMGAP C C ******************************************* C ** STEP 34-- ** C ** FORM THE NEW LINE ** C ******************************************* C ISTEPN='34' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IREM2=IREM J=ICOLL1-1 C IC1=ICOLL1 IC2=ICOLL2 IC3=0 IC4=IC2 C DO3400IW=1,NUMWOR C IF(IW.GE.2)IC1=IC4+1 IF(IC1.GT.IC2)GOTO3490 CALL EDZERO(ICWORD,NCWORD) CALL EDEXWO(ICNEWL,NCNEWL,IC1,IC2,IC3,IC4, 1ICWORD,NCWORD,IFOUWO) IF(IFOUWO.EQ.'NO')GOTO3490 C DO3410I=IC3,IC4 J=J+1 ICNEW2(J:J)=ICNEWL(I:I) 3410 CONTINUE C IF(IW.EQ.NUMWOR)GOTO3490 IC4P=IC4+1 IF(IC4P.GT.ICOLL2)GOTO3425 DO3420I=IC4P,ICOLL2 IF(ICNEWL(I:I).NE.' ')GOTO3425 J=J+1 ICNEW2(J:J)=ICNEWL(I:I) 3420 CONTINUE 3425 CONTINUE C IF(IRATIO.LE.0)GOTO3439 DO3430I=1,IRATIO J=J+1 ICNEW2(J:J)=' ' 3430 CONTINUE 3439 CONTINUE C IF(IREM2.LE.0)GOTO3449 J=J+1 ICNEW2(J:J)=' ' IREM2=IREM2-1 3449 CONTINUE C 3400 CONTINUE 3490 CONTINUE NCNEW2=J C C **************************************************** C ** STEP 35-- ** C ** COPY THE SECOND NEW LINE BACK INTO THE FIRST ** C **************************************************** C ISTEPN='35' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C DO3500I=ICOLL1,ICOLL2 ICNEWL(I:I)=ICNEW2(I:I) 3500 CONTINUE NCNEWL=NCNEW2 GOTO9000 C C *********************************************** C ** STEP 40-- ** C ** TREAT THE FORTRAN JUSTIFICATION CASE ** C *********************************************** C 4000 CONTINUE C ISTEPN='40' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C *********************************************** C ** STEP 41-- ** C ** DETERMINE THE NUMBER OF LEADING BLANKS ** C *********************************************** C 4100 CONTINUE C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J=0 DO4110I=ICOLL1,ICOLL2 J=J+1 IF(ICNEWL(I:I).NE.' ')GOTO4120 4110 CONTINUE GOTO9000 4120 CONTINUE NUMBEB=J-1 C C ******************************************* C ** STEP 42-- ** C ** DETERMINE THE NATURE OF THE LINE-- ** C ** 1) IS IT A USUAL FORTRAN LINE? C ** 2) IS IT A COMMENT LINE? C ** 3) IS IT A STATEMENT LABEL? C ** 4) IS IT A CONTINUATION LINE? C ******************************************* C ISTEPN='42' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICNB=NUMBEB+1 ICNBP1=ICNB+1 ICNBP4=ICNB+4 C ICASFO='REGU' C IF(NCNEWL.LE.ICNB.AND.ICNEWL(ICNB:ICNB).EQ.'C')ICASFO='COMM' IF(NCNEWL.GT.ICNB.AND.ICNEWL(ICNB:ICNB).EQ.'C'.AND. 1 ICNEWL(ICNBP1:ICNBP1).EQ.' ')ICASFO='COMM' IF(NCNEWL.GT.ICNB.AND.ICNEWL(ICNB:ICNB).EQ.'C'.AND. 1 ICNEWL(ICNBP1:ICNBP1).EQ.'-')ICASFO='COMM' IF(NCNEWL.GT.ICNB.AND.ICNEWL(ICNB:ICNB).EQ.'C'.AND. 1 ICNEWL(ICNBP1:ICNBP4).EQ.'CCCC')ICASFO='COMM' C IF(ICNEWL(ICNB:ICNB).EQ.'&')ICASFO='CONT' C IF(ICNEWL(ICNB:ICNB).EQ.'1')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'2')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'3')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'4')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'5')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'6')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'7')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'8')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'9')ICASFO='LABE' IF(ICNEWL(ICNB:ICNB).EQ.'0')ICASFO='LABE' C IF(ICASFO.EQ.'LABE')GOTO4210 GOTO4290 4210 CONTINUE J=0 DO4211I=ICNB,ICOLL2 J=J+1 IF(ICNEWL(I:I).EQ.' ')GOTO4212 4211 CONTINUE NUMCLA=J GOTO4290 4212 CONTINUE NUMCLA=J-1 GOTO4290 4290 CONTINUE C C ******************************************* C ** STEP 43-- ** C ** FORM THE NEW LINE ** C ******************************************* C ISTEPN='43' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDZERO(ICNEW2,NCNEW2) IMIN=NUMBEB+1 IMAX=ICOLL2 IF(IMIN.GT.IMAX)GOTO9000 DO4310I=IMIN,IMAX IP=I+7-1 IF(ICASFO.EQ.'COMM'.AND.I.EQ.1)IP=I+1-1 IF(ICASFO.EQ.'COMM'.AND.I.GE.2)IP=I+5-1 IF(ICASFO.EQ.'COMM'.AND.I.GE.2.AND.ICNEWL(2:5).EQ.'----')IP=I+1-1 IF(ICASFO.EQ.'COMM'.AND.I.GE.2.AND.ICNEWL(2:5).EQ.'CCCC')IP=I+1-1 IF(ICASFO.EQ.'CONT')IP=I+6-1 IF(ICASFO.EQ.'LABE')IP=I+(6-NUMCLA)-1 IF(IP.GT.ICOLL2)GOTO4320 ICNEW2(IP:IP)=ICNEWL(I:I) 4310 CONTINUE NCNEW2=IP GOTO4390 C 4320 CONTINUE NCNEW2=IP-1 GOTO4390 C 4390 CONTINUE C C **************************************************** C ** STEP 44-- ** C ** COPY THE SECOND NEW LINE BACK INTO THE FIRST ** C **************************************************** C ISTEPN='44' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'JUST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C DO4400I=ICOLL1,ICOLL2 ICNEWL(I:I)=ICNEW2(I:I) 4400 CONTINUE NCNEWL=NCNEW2 GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'JUST')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDJUST') WRITE(ICOUT,9011) CALL EDWRST('EDJUST') 9011 FORMAT('***** AT THE END OF EDJUST--') WRITE(ICOUT,9012)IJUST CALL EDWRST('EDJUST') 9012 FORMAT('IJUST = ',A4) WRITE(ICOUT,9013)NCNEWL,ICOLL1,ICOLL2 CALL EDWRST('EDJUST') 9013 FORMAT('NCNEWL,ICOLL1,ICOLL2 = ',3I8) WRITE(ICOUT,9014)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDJUST') 9014 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) WRITE(ICOUT,9015)NUMTRB,NUMWOR,NUMGAP,IRATIO,IREM,IREM2 CALL EDWRST('EDJUST') 9015 FORMAT('NUMTRB,NUMWOR,NUMGAP,IRATIO,IREM,IREM2 = ',6I8) WRITE(ICOUT,9016)ICASFO,NUMBEB,ICNB,NUMCLA CALL EDWRST('EDJUST') 9016 FORMAT('ICASFO,NUMBEB,ICNB,NUMCLA = ',A4,3I8) 9090 CONTINUE C RETURN END SUBROUTINE EDLAST C C PURPOSE--GO TO THE LAST LINE OF THE FILE C C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLA' ISUBN2='ST ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LAST')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLASTX') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLASTX') 51 FORMAT('***** AT THE BEGINNING OF EDLAST--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO LINE 1 ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LAST') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=NUMLIN IF(ILINE.LE.0)GOTO1150 C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121)(ICHA(J),J=J1,J2) CALL EDWRST('EDLASTX') ENDIF 1121 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDLASTX') ENDIF 1122 FORMAT(I6,':',3X,230A1) 1129 CONTINUE GOTO1190 C 1150 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDLASTX') ENDIF 1151 FORMAT('THE FILE IS EMPTY--THERE IS NO LAST LINE.') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDLASTX') ENDIF 1152 FORMAT(10X,'THE FILE IS EMPTY--THERE IS NO LAST LINE.') 1159 CONTINUE GOTO1190 C 1190 CONTINUE C ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LAST')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLASTX') WRITE(ICOUT,9011) CALL EDWRST('EDLASTX') 9011 FORMAT('***** AT THE END OF EDLAST--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLB C C PURPOSE--LOCATE (BACKWARDS) THE PREVIOUS OCCURRANCE OF A STRING C (START THE SEARCH WITH THE PREVIOUS LINE) C NOTE-- C LB ABC WILL LOCATE BACKWARDS ABC IF IN ANY COLUMN C COMMAND SYNTAX--LB C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.6 C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 IHIT C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLB' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IHIT='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOCA')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLB ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLB ') 51 FORMAT('***** AT THE BEGINNING OF EDLB--') WRITE(ICOUT,52)IALL CALL EDWRST('EDLB ') 52 FORMAT('IALL = ',A4) WRITE(ICOUT,54)NUMARG,IWIDTH CALL EDWRST('EDLB ') 54 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLB ') ENDIF 55 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,56)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLB ') 56 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE FOUND ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) IF(IFOUST.EQ.'YES')GOTO1190 C NUMCST=NUMCLS IF(NUMCLS.LE.0)GOTO1159 DO1155I=1,NUMCLS ISTRIN(I)=ILOCST(I) 1155 CONTINUE 1159 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 2-- ** C ** IF THE STRING IS NEW, ** C ** COPY THE STRING INTO ILOCST(.) ** C ** FOR FUTURE USE BY SUBSEQUENT ** C ** LOCATE COMMANDS. ** C ************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFOUST.EQ.'NO')GOTO1290 NUMCLS=NUMCST IF(NUMCST.LE.0)GOTO1290 DO1210I=1,NUMCST ILOCST(I)=ISTRIN(I) 1210 CONTINUE 1290 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLM=ICURLN-1 C ISTART=1 ISTOP=ICURLM C C **************************** C ** STEP 4-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTOP.LE.0)ISTOP=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP ILINRV=ISTOP-ILINE+ISTART IROW=IPOINT(ILINRV) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOC2(ISTRIN,NUMCST,J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1520 GOTO1510 C 1520 CONTINUE ICURLN=ILINRV IF(IFEESW.EQ.'OFF')GOTO1529 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDLB ') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINRV,(ICHA(J),J=J1,J2) CALL EDWRST('EDLB ') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1529 CONTINUE IF(IALL.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=0 IF(IFEESW.EQ.'OFF')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDLB ') ENDIF 1551 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDLB ') ENDIF 1552 FORMAT(10X,'[TOP]') 1559 CONTINUE C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOCA')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLB ') WRITE(ICOUT,9011) CALL EDWRST('EDLB ') 9011 FORMAT('***** AT THE END OF EDLB--') WRITE(ICOUT,9015)NUMARG,IWIDTH CALL EDWRST('EDLB ') 9015 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9016)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLB ') ENDIF 9016 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDLB ') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,ICURLN CALL EDWRST('EDLB ') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',2I8,2X,A4,I8) WRITE(ICOUT,9019)IALL,IFOUST CALL EDWRST('EDLB ') 9019 FORMAT('IALL,IFOUST = ',A4,2X,A4) WRITE(ICOUT,9020)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLB ') 9020 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDLB ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLIME C C PURPOSE--LIST THE CONTENTS OF THE MESSAGE FILE C (THIS IS DONE AT SIGN-ON TO THE EDITOR). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*80 IREC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLI' ISUBN2='ME ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LIME')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLIME') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLIME') 51 FORMAT('***** AT THE BEGINNING OF EDLIME--') WRITE(ICOUT,52)IBUGE2,ISUBRO CALL EDWRST('EDLIME') 52 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,53)IMESNU CALL EDWRST('EDLIME') 53 FORMAT('IMESNU = ',I8) WRITE(ICOUT,54)IMESNA CALL EDWRST('EDLIME') 54 FORMAT('IMESNA = ',A80) WRITE(ICOUT,55)IMESST CALL EDWRST('EDLIME') 55 FORMAT('IMESST = ',A12) WRITE(ICOUT,56)IMESFO CALL EDWRST('EDLIME') 56 FORMAT('IMESFO = ',A12) WRITE(ICOUT,57)IMESAC CALL EDWRST('EDLIME') 57 FORMAT('IMESAC = ',A12) WRITE(ICOUT,58)IMESRW CALL EDWRST('EDLIME') 58 FORMAT('IMESRW = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDLIME') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE IS TO BE LISTED ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IFILE=IMESNA ISTAT=IMESST IOUNIT=IMESNU IFORM=IMESFO IACCES=IMESAC IREWR=IMESRW ISUBN0='LIME' IERRFI='NO' C C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO9000 REWIND IOUNIT C C ****************************** C ** STEP 21-- ** C ** READ IN A FILE AND ** C ** WRITE IT OUT (LIST IT) ** C ****************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICOUNT=0 DO2100IDUMMY=1,100000 C NUMCRE=80 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,2105,END=2190)IREC 2105 FORMAT(A80) ICOUNT=ICOUNT+1 C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2106)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIME') 2106 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2107)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIME') 2107 FORMAT('NUMCRE = ',I8) C DO2200I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO2290 2200 CONTINUE IREV=0 2290 CONTINUE NUMCRE=IREV C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2296)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIME') 2296 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2297)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIME') 2297 FORMAT('NUMCRE = ',I8) C WRITE(ICOUT,2311)(IREC(I:I),I=1,NUMCRE) CALL EDWRST('EDLIME') 2311 FORMAT(230A1) C 2100 CONTINUE 2190 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC IF(ICOUNT.LE.0)WRITE(ICOUT,2191) CCCCC CALL EDWRST('EDLIME') C2191 FORMAT('[THE FILE IS EMPTY]') C C ********************** C ** STEP 31-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LIME')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLIME') WRITE(ICOUT,9011) CALL EDWRST('EDLIME') 9011 FORMAT('***** AT THE END OF EDLIME--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDLIME') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDLIME') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDLIME') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)ICOUNT CALL EDWRST('EDLIME') 9016 FORMAT('ICOUNT = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDLIME') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLINE C C PURPOSE--LIST THE CONTENTS OF THE NEWS FILE C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*80 IREC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLI' ISUBN2='ME ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LIME')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLINE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLINE') 51 FORMAT('***** AT THE BEGINNING OF EDLINE--') WRITE(ICOUT,52)IBUGE2,ISUBRO CALL EDWRST('EDLINE') 52 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,53)INEWNU CALL EDWRST('EDLINE') 53 FORMAT('INEWNU = ',I8) WRITE(ICOUT,54)INEWNA CALL EDWRST('EDLINE') 54 FORMAT('INEWNA = ',A80) WRITE(ICOUT,55)INEWST CALL EDWRST('EDLINE') 55 FORMAT('INEWST = ',A12) WRITE(ICOUT,56)INEWFO CALL EDWRST('EDLINE') 56 FORMAT('INEWFO = ',A12) WRITE(ICOUT,57)INEWAC CALL EDWRST('EDLINE') 57 FORMAT('INEWAC = ',A12) WRITE(ICOUT,58)INEWRW CALL EDWRST('EDLINE') 58 FORMAT('INEWRW = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDLINE') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE IS TO BE LISTED ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IFILE=INEWNA ISTAT=INEWST IOUNIT=INEWNU IFORM=INEWFO IACCES=INEWAC IREWR=INEWRW ISUBN0='LIME' IERRFI='NO' C C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO9000 REWIND IOUNIT C C ****************************** C ** STEP 21-- ** C ** READ IN A FILE AND ** C ** WRITE IT OUT (LIST IT) ** C ****************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICOUNT=0 DO2100IDUMMY=1,100000 C NUMCRE=80 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,2105,END=2190)IREC 2105 FORMAT(A80) ICOUNT=ICOUNT+1 C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2106)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLINE') 2106 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2107)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLINE') 2107 FORMAT('NUMCRE = ',I8) C DO2200I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO2290 2200 CONTINUE IREV=0 2290 CONTINUE NUMCRE=IREV C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2296)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLINE') 2296 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2297)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLINE') 2297 FORMAT('NUMCRE = ',I8) C WRITE(ICOUT,2311)(IREC(I:I),I=1,NUMCRE) CALL EDWRST('EDLINE') 2311 FORMAT(230A1) C 2100 CONTINUE 2190 CONTINUE CCCCC WRITE(ICOUT,999) CCCCC IF(ICOUNT.LE.0)WRITE(ICOUT,2191) CCCCC CALL EDWRST('EDLINE') C2191 FORMAT('[THE FILE IS EMPTY]') C C ********************** C ** STEP 31-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LIME') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LIME')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLINE') WRITE(ICOUT,9011) CALL EDWRST('EDLINE') 9011 FORMAT('***** AT THE END OF EDLINE--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDLINE') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDLINE') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDLINE') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)ICOUNT CALL EDWRST('EDLINE') 9016 FORMAT('ICOUNT = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDLINE') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLIST C C PURPOSE--LIST (BUT DO NOT INSERT OR EXECUTE) C THE CONTENTS OF A FILE C NOTE--IF NO ARGUMENTS GIVEN, C THE THE DEFAULT LIST FILE WILL BE LISTED. C --IF 1 ARGUMENT GIVEN (PRESUMEDLY A FILE NAME), C THEN THAT FILE WILL BE LISTED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*80 IREC CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLI' ISUBN2='ST ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLIST') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLIST') 51 FORMAT('***** AT THE BEGINNING OF EDLIST--') WRITE(ICOUT,53)ILISNU CALL EDWRST('EDLIST') 53 FORMAT('ILISNU = ',I8) WRITE(ICOUT,54)ILISNA CALL EDWRST('EDLIST') 54 FORMAT('ILISNA = ',A80) WRITE(ICOUT,55)ILISST CALL EDWRST('EDLIST') 55 FORMAT('ILISST = ',A12) WRITE(ICOUT,56)ILISFO CALL EDWRST('EDLIST') 56 FORMAT('ILISFO = ',A12) WRITE(ICOUT,57)ILISAC CALL EDWRST('EDLIST') 57 FORMAT('ILISAC = ',A12) WRITE(ICOUT,58)ILISRW CALL EDWRST('EDLIST') 58 FORMAT('ILISRW = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDLIST') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT THE IS TO BE LISTED ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE ISTAT='UNKNOWN' GOTO1190 C 1120 CONTINUE IFILE=ILISNA ISTAT=ILISST GOTO1190 C 1190 CONTINUE IOUNIT=ILISNU IFORM=ILISFO IACCES=ILISAC IREWR=ILISRW ISUBN0='LIST' IERRFI='NO' C C **************************** C ** STEP 12-- ** C ** WRITE OUT A MESSAGE ** C ** IDENTIFYING THE FILE ** C **************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL EDWRST('EDLIST') WRITE(ICOUT,1205)IFILE CALL EDWRST('EDLIST') 1205 FORMAT(10X,'FILE = ',A80) WRITE(ICOUT,999) CALL EDWRST('EDLIST') C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO9000 REWIND IOUNIT C C ****************************** C ** STEP 21-- ** C ** READ IN A FILE AND ** C ** WRITE IT OUT (LIST IT) ** C ****************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICOUNT=0 DO2100IDUMMY=1,100000 C NUMCRE=80 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,2105,END=2190)IREC 2105 FORMAT(A80) ICOUNT=ICOUNT+1 C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2106)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIST') 2106 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2107)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIST') 2107 FORMAT('NUMCRE = ',I8) C DO2200I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO2290 2200 CONTINUE IREV=0 2290 CONTINUE NUMCRE=IREV C IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2296)IREC IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIST') 2296 FORMAT('IREC = ',A80) IF(IBUGE2.EQ.'ON')WRITE(ICOUT,2297)NUMCRE IF(IBUGE2.EQ.'ON')CALL EDWRST('EDLIST') 2297 FORMAT('NUMCRE = ',I8) C WRITE(ICOUT,2311)ICOUNT,(IREC(I:I),I=1,NUMCRE) CALL EDWRST('EDLIST') 2311 FORMAT(I6,':',3X,230A1) C 2100 CONTINUE 2190 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDLIST') IF(ICOUNT.LE.0)WRITE(ICOUT,2191) IF(ICOUNT.LE.0)CALL EDWRST('EDLIST') 2191 FORMAT('[THE FILE IS EMPTY]') C C ********************** C ** STEP 31-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLIST') WRITE(ICOUT,9011) CALL EDWRST('EDLIST') 9011 FORMAT('***** AT THE END OF EDLIST--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDLIST') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDLIST') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDLIST') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)ICOUNT CALL EDWRST('EDLIST') 9016 FORMAT('ICOUNT = ',I8) WRITE(ICOUT,999) CALL EDWRST('EDLIST') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOBL C C PURPOSE--LOCATE THE NEXT OCCURRANCE OF A BLANK C (START THE SEARCH WITH THE NEXT LINE) C NOTE-- C COMMAND SYNTAX--LBL C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.3 C ORIGINAL VERSION--FEBRUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 IHIT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='BL ' C IFOUND='YES' IERROR='NO' C IHIT='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOBL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOBL') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOBL') 51 FORMAT('***** AT THE BEGINNING OF EDLOBL--') WRITE(ICOUT,52)IALL CALL EDWRST('EDLOBL') 52 FORMAT('IALL = ',A4) WRITE(ICOUT,54)NUMARG,IWIDTH CALL EDWRST('EDLOBL') 54 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOBL') ENDIF 55 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,56)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOBL') 56 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOBL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLP=ICURLN+1 C ISTART=ICURLP ISTOP=NUMLIN C C **************************** C ** STEP 4-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOBL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOB2(J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1520 GOTO1510 C 1520 CONTINUE ICURLN=ILINE IF(IFEESW.EQ.'OFF')GOTO1529 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOBL') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDLOBL') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1529 CONTINUE IF(IALL.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=NUMLIN+1 IF(IFEESW.EQ.'OFF')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDLOBL') ENDIF 1551 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDLOBL') ENDIF 1552 FORMAT(10X,'[BOTTOM]') 1559 CONTINUE C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOBL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOBL') WRITE(ICOUT,9011) CALL EDWRST('EDLOBL') 9011 FORMAT('***** AT THE END OF EDLOBL--') WRITE(ICOUT,9015)NUMARG,IWIDTH CALL EDWRST('EDLOBL') 9015 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9016)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOBL') ENDIF 9016 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDLOBL') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,ICURLN CALL EDWRST('EDLOBL') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',2I8,2X,A4,I8) WRITE(ICOUT,9019)IALL,IFOUND CALL EDWRST('EDLOBL') 9019 FORMAT('IALL,IFOUND = ',A4,2X,A4) WRITE(ICOUT,9020)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOBL') 9020 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDLOBL') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOB2(J1,J2,IHIT) C C PURPOSE--SCAN ICHA(.) BETWEEN C ELEMENTS J1 AND J2 (INCLUSIVE) C AND DETERMINE IF ALL BLANK. C IF SO, THEN SET IHIT TO 'YES' C IF NO, THEN SET IHIT TO 'NO' C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 IHIT C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='B2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOB2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOB2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOB2') 51 FORMAT('***** AT THE BEGINNING OF EDLOB2--') WRITE(ICOUT,56)J1,J2 CALL EDWRST('EDLOB2') 56 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,57)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOB2') 57 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,999) CALL EDWRST('EDLOB2') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' C K1=(J1-1)+ILLIM1 K2=(J1-1)+ILLIM2 IF(K1.LT.J1.OR.K1.GT.J2)K1=J1 IF(K2.LT.J1.OR.K2.GT.J2)K2=J2 IF(K1.GT.K2)GOTO1110 DO1100J=K1,K2 IF(ICHA(J).EQ.' ')GOTO1100 GOTO1120 1100 CONTINUE 1110 CONTINUE IHIT='YES' GOTO9000 1120 CONTINUE IHIT='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOB2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOB2') WRITE(ICOUT,9011) CALL EDWRST('EDLOB2') 9011 FORMAT('***** AT THE END OF EDLOB2--') WRITE(ICOUT,9016)J1,J2,ILLIM1,ILLIM2,K1,K2 CALL EDWRST('EDLOB2') 9016 FORMAT('J1,J2,ILLIM1,ILLIM2,K1,K2 = ',6I8) WRITE(ICOUT,9017)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOB2') 9017 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,9018)IHIT CALL EDWRST('EDLOB2') 9018 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDLOB2') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOCA C C PURPOSE--LOCATE THE NEXT OCCURRANCE OF A STRING C (START THE SEARCH WITH THE NEXT LINE) C NOTE-- C LOCATE ABC WILL LOCATE ABC IF IN ANY COLUMN C FIND ABC WILL LOCATE ABC ONLY IF IN COLUMNS 1, 2, AND 3 C COMMAND SYNTAX--LOCATE C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 IHIT C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='CA ' C IFOUND='YES' IERROR='NO' C IHIT='NO' LOCATE='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOCA')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOCA') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOCA') 51 FORMAT('***** AT THE BEGINNING OF EDLOCA--') WRITE(ICOUT,52)IALL CALL EDWRST('EDLOCA') 52 FORMAT('IALL = ',A4) WRITE(ICOUT,54)NUMARG,IWIDTH CALL EDWRST('EDLOCA') 54 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOCA') ENDIF 55 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,56)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOCA') 56 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE FOUND ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) LOCATE=IFOUST IF(IFOUST.EQ.'YES')GOTO1190 C NUMCST=NUMCLS IF(NUMCLS.LE.0)GOTO1159 DO1155I=1,NUMCLS ISTRIN(I)=ILOCST(I) 1155 CONTINUE 1159 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 2-- ** C ** IF THE STRING IS NEW, ** C ** COPY THE STRING INTO ILOCST(.) ** C ** FOR FUTURE USE BY SUBSEQUENT ** C ** LOCATE COMMANDS. ** C ************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFOUST.EQ.'NO')GOTO1290 NUMCLS=NUMCST IF(NUMCST.LE.0)GOTO1290 DO1210I=1,NUMCST ILOCST(I)=ISTRIN(I) 1210 CONTINUE 1290 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLP=ICURLN+1 C ISTART=ICURLP ISTOP=NUMLIN C C **************************** C ** STEP 4-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOCA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOC2(ISTRIN,NUMCST,J1,J2,IHIT) CCCCC THE FOLLOWING LINE WAS ADDED MAY 1993 LOCATE=IHIT IF(IHIT.EQ.'YES')GOTO1520 GOTO1510 C 1520 CONTINUE ICURLN=ILINE IF(IFEESW.EQ.'OFF')GOTO1529 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOCA') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDLOCA') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1529 CONTINUE IF(IALL.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=NUMLIN+1 IF(IFEESW.EQ.'OFF')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDLOCA') ENDIF 1551 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDLOCA') ENDIF 1552 FORMAT(10X,'[BOTTOM]') 1559 CONTINUE C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOCA')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOCA') WRITE(ICOUT,9011) CALL EDWRST('EDLOCA') 9011 FORMAT('***** AT THE END OF EDLOCA--') WRITE(ICOUT,9015)NUMARG,IWIDTH CALL EDWRST('EDLOCA') 9015 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9016)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOCA') ENDIF 9016 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDLOCA') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,LOCATE,ICURLN CALL EDWRST('EDLOCA') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',2I8,2X,A4,2X,A4,I8) WRITE(ICOUT,9019)IALL,IFOUST,LOCATE CALL EDWRST('EDLOCA') 9019 FORMAT('IALL,IFOUST,LOCATE = ',A4,2X,A4,2X,A4) WRITE(ICOUT,9020)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOCA') 9020 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDLOCA') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOC2(ISTRIN,NUMCST,J1,J2,IHIT) C C PURPOSE--SCAN ICHA(.) BETWEEN C ELEMENTS J1 AND J2 (INCLUSIVE) C AND DETERMINE IF THE STRING IN ISTRIN(.) C IS CONTAINED THERIN. C IF SO, THEN SET IHIT TO 'YES' C IF NO, THEN SET IHIT TO 'NO' C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IHIT CHARACTER*1 ICHAUC C DIMENSION ISTRIN(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='C2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOC2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOC2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOC2') 51 FORMAT('***** AT THE BEGINNING OF EDLOC2--') WRITE(ICOUT,54)NUMCST CALL EDWRST('EDLOC2') 54 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,55)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDLOC2') ENDIF 55 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,56)J1,J2 CALL EDWRST('EDLOC2') 56 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,57)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOC2') 57 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,999) CALL EDWRST('EDLOC2') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' C IF(J1.GT.J2)GOTO9000 IF(NUMCST.LE.0)IHIT='YES' IF(NUMCST.LE.0)GOTO9000 C K1=(J1-1)+ILLIM1 K2=(J1-1)+ILLIM2 IF(K1.LT.J1.OR.K1.GT.J2)K1=J1 IF(K2.LT.J1.OR.K2.GT.J2)K2=J2 CCCCC DO1100J=J1,J2 DO1100J=K1,K2 DO1200I=1,NUMCST JPIM1=J+(I-1) IF(ISTRIN(I).EQ.IMASK)GOTO1200 IF(ICHA(JPIM1).EQ.ISTRIN(I))GOTO1200 CALL EDUPP1(ICHA(JPIM1),ICHAUC) IF(ICHAUC.EQ.ISTRIN(I))GOTO1200 CALL EDLOW1(ICHA(JPIM1),ICHAUC) IF(ICHAUC.EQ.ISTRIN(I))GOTO1200 GOTO1100 1200 CONTINUE IHIT='YES' GOTO9000 1100 CONTINUE IHIT='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOC2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOC2') WRITE(ICOUT,9011) CALL EDWRST('EDLOC2') 9011 FORMAT('***** AT THE END OF EDLOC2--') WRITE(ICOUT,9014)NUMCST CALL EDWRST('EDLOC2') 9014 FORMAT('NUMCST = ',I8) IF(NUMCST.GE.1)THEN WRITE(ICOUT,9015)(ISTRIN(I),I=1,NUMCST) CALL EDWRST('EDLOC2') ENDIF 9015 FORMAT('(ISTRIN(I),I=1,NUMCST) = ',110A1) WRITE(ICOUT,9016)J1,J2,ILLIM1,ILLIM2,K1,K2 CALL EDWRST('EDLOC2') 9016 FORMAT('J1,J2,ILLIM1,ILLIM2,K1,K2 = ',6I8) WRITE(ICOUT,9017)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOC2') 9017 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,9018)IHIT CALL EDWRST('EDLOC2') 9018 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDLOC2') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOPE C C PURPOSE--LOCATE THE NEXT OCCURRANCE OF A PERIOD (ONLY) C (START THE SEARCH WITH THE NEXT LINE) C NOTE-- C COMMAND SYNTAX--LPER C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.1 C ORIGINAL VERSION--DECEMBER 1988. C C--------------------------------------------------------------------- C CHARACTER*4 IHIT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='PE ' C IFOUND='YES' IERROR='NO' C IHIT='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOPE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOPE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOPE') 51 FORMAT('***** AT THE BEGINNING OF EDLOPE--') WRITE(ICOUT,52)IALL CALL EDWRST('EDLOPE') 52 FORMAT('IALL = ',A4) WRITE(ICOUT,54)NUMARG,IWIDTH CALL EDWRST('EDLOPE') 54 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,55)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOPE') ENDIF 55 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,56)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOPE') 56 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOPE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLP=ICURLN+1 C ISTART=ICURLP ISTOP=NUMLIN C C **************************** C ** STEP 4-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'LOPE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOP2(J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1520 GOTO1510 C 1520 CONTINUE ICURLN=ILINE IF(IFEESW.EQ.'OFF')GOTO1529 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOPE') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDLOPE') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1529 CONTINUE IF(IALL.EQ.'ON')GOTO1510 GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=NUMLIN+1 IF(IFEESW.EQ.'OFF')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDLOPE') ENDIF 1551 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDLOPE') ENDIF 1552 FORMAT(10X,'[BOTTOM]') 1559 CONTINUE C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOPE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOPE') WRITE(ICOUT,9011) CALL EDWRST('EDLOPE') 9011 FORMAT('***** AT THE END OF EDLOPE--') WRITE(ICOUT,9015)NUMARG,IWIDTH CALL EDWRST('EDLOPE') 9015 FORMAT('NUMARG,IWIDTH = ',2I8) IF(IWIDTH.GE.1)THEN WRITE(ICOUT,9016)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDLOPE') ENDIF 9016 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDLOPE') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,ICURLN CALL EDWRST('EDLOPE') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',2I8,2X,A4,I8) WRITE(ICOUT,9019)IALL,IFOUND CALL EDWRST('EDLOPE') 9019 FORMAT('IALL,IFOUND = ',A4,2X,A4) WRITE(ICOUT,9020)ICURLN,NUMLIN,NUMCLS CALL EDWRST('EDLOPE') 9020 FORMAT('ICURLN,NUMLIN,NUMCLS = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDLOPE') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOP2(J1,J2,IHIT) C C PURPOSE--SCAN ICHA(.) BETWEEN C ELEMENTS J1 AND J2 (INCLUSIVE) C AND DETERMINE IF ONLY A LEAD PERIOD. C IF SO, THEN SET IHIT TO 'YES' C IF NO, THEN SET IHIT TO 'NO' C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--89.1 C ORIGINAL VERSION--DECEMBER 1988. C C--------------------------------------------------------------------- C CHARACTER*4 IHIT C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLO' ISUBN2='P2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOP2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOP2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOP2') 51 FORMAT('***** AT THE BEGINNING OF EDLOP2--') WRITE(ICOUT,56)J1,J2 CALL EDWRST('EDLOP2') 56 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,57)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOP2') 57 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,999) CALL EDWRST('EDLOP2') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' C K1=(J1-1)+ILLIM1 K2=(J1-1)+ILLIM2 IF(K1.LT.J1.OR.K1.GT.J2)K1=J1 IF(K2.LT.J1.OR.K2.GT.J2)K2=J2 IF(K1.GT.K2)GOTO1110 IF(ICHA(K1).EQ.'.')GOTO1105 GOTO1120 1105 CONTINUE K1P1=K1+1 IF(K1P1.GT.K2)GOTO1110 DO1100J=K1P1,K2 IF(ICHA(J).EQ.' ')GOTO1100 GOTO1120 1100 CONTINUE 1110 CONTINUE IHIT='YES' GOTO9000 1120 CONTINUE IHIT='NO' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'LOP2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOP2') WRITE(ICOUT,9011) CALL EDWRST('EDLOP2') 9011 FORMAT('***** AT THE END OF EDLOP2--') WRITE(ICOUT,9016)J1,J2,ILLIM1,ILLIM2,K1,K2 CALL EDWRST('EDLOP2') 9016 FORMAT('J1,J2,ILLIM1,ILLIM2,K1,K2 = ',6I8) WRITE(ICOUT,9017)(ICHA(J),J=J1,J2) CALL EDWRST('EDLOP2') 9017 FORMAT('(ICHA(J),J=J1,J2) = ',100A1) WRITE(ICOUT,9018)IHIT CALL EDWRST('EDLOP2') 9018 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDLOP2') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDLOW1(IA1,IB1) C C PURPOSE--CONVERT 1-CHARACTER UPPER CASE ALPHABETIC (A TO Z) C ASCII WORD IA1 C TO LOWER CASE ASCII WORD IB1. C NOTE--IA1 AND IB1 ARE ASSUMED TO BE CHARACTER*1 C NOTE--IA1 AND IB1 MAY BE THE SAME VARIABLE IN THE CALLING ROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MAY 1982. C C--------------------------------------------------------------------- C CHARACTER*1 IA1 CHARACTER*1 IB1 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)---------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IF(IBUGMA.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDLOW1') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDLOW1') 51 FORMAT('***** AT THE BEGINNING OF EDLOW1--') WRITE(ICOUT,52)IA1 CALL EDWRST('EDLOW1') 52 FORMAT('IA1 = ',A1) 90 CONTINUE C C ******************************************************** C ** STEP 11-- C ** THE FOLLOWING CODE WILL CARRY OUT THE UPPER CASE C ** TO LOWER CASE CONVERSION FOR ALL COMPUTERS C ** WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES C ** USE OF THE ANSI FORTRAN 77 INTRINSIC FUNCTIONS C ** 1) ICHAR (FOR ASCII CHARACTER TO ASCII NUMERIC CO C ** 2) CHAR (FOR ASCII NUMERIC TO ASCII CHARACTER CO C ******************************************************** C IB1=IA1 C IVALUE=ICHAR(IA1) IF(65.LE.IVALUE.AND.IVALUE.LE.90)GOTO1110 GOTO1190 C 1110 CONTINUE IVAL32=IVALUE+32 IB1=CHAR(IVAL32) GOTO1190 C 1190 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGMA.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDLOW1') WRITE(ICOUT,9011) CALL EDWRST('EDLOW1') 9011 FORMAT('***** AT THE END OF EDLOW1--') WRITE(ICOUT,9012)IA1,IVALUE,IVAL32,IB1 CALL EDWRST('EDLOW1') 9012 FORMAT('IA1,IVALUE,IVAL32,IB1 = ',A4,I8,I8,2X,A4) 9090 CONTINUE C RETURN END SUBROUTINE EDNEAT(ICOLL1,ICOLL2,IBLASW) C C PURPOSE--MAKE NEAT A CHUNK OF TEXT. C IF NO ARGUMENTS, THEN MAKE NEAT THE CURRENT (OR NEXT) PARAGRAPH. C IF 1 ARGUMENT , THEN MAKE NEAT THE CURRENT LINE C + NEXT (N-1) LINES; C IF 2 ARGUMENTS, THEN MAKE NEAT LINES N1 TO N2. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*4 IHIT CHARACTER*4 IBLASW CHARACTER*4 IADDED C CHARACTER*4 IFEES2 C CHARACTER*240 ICLINE CHARACTER*240 ICWORD CHARACTER*240 ICNEWL C CHARACTER*4 IFOUWO C CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDNE' ISUBN2='AT ' C IFOUND='YES' IERROR='NO' C IEOF='NO' IARG1=(-999) IARG2=(-999) J=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'NEAT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDNEAT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDNEAT') 51 FORMAT('*****AT THE BEGINNING OF EDNEAT--') WRITE(ICOUT,52)IPRISW,ICURLN CALL EDWRST('EDNEAT') 52 FORMAT('IPRISW,ICURLN = ',A4,I8) WRITE(ICOUT,53)ICOLL1,ICOLL2,IBLASW,IJUST CALL EDWRST('EDNEAT') 53 FORMAT('ICOLL1,ICOLL2,IBLASW,IJUST = ',2I8,2X,A4,2X,A4) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************************* C ** STEP 11-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE OPERATED ON. ** C ** FOR THE NO-ARGUMENT CASE-- ** C ** IF CURRENT LINE IS NON-BLANK, START WITH IT, ** C ** ELSE START WITH NEXT NON-BLANK LINE. ** C ** AFTER FINDING THE START LINE, ** C ** STOP ON THE LINE BEFORE THE NEXT BLANK LINE. ** C ******************************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEAT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ISTART C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE I2=1 IMIN=ICURLN IF(IMIN.LE.0)IMIN=1 IMAX=NUMLIN IF(IMAX.LE.0)IMAX=1 IF(IMIN.GT.IMAX)GOTO1102 DO1101I=IMIN,IMAX I2=I IROW=IPOINT(I) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOB2(J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1101 GOTO1102 1101 CONTINUE 1102 CONTINUE ISTART=I2 C I2=ISTART IMIN=ISTART IF(IMIN.LE.0)IMIN=1 IMAX=NUMLIN IF(IMAX.LE.0)IMAX=1 IF(IMIN.GT.IMAX)GOTO1107 DO1106I=IMIN,IMAX I2=I IROW=IPOINT(I) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOB2(J1,J2,IHIT) IF(IHIT.EQ.'YES')GOTO1108 GOTO1106 1106 CONTINUE 1107 CONTINUE ISTOP=I2 GOTO1109 1108 CONTINUE ISTOP=I2-1 GOTO1109 1109 CONTINUE C IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEAT')THEN WRITE(ICOUT,1177)IMIN,IMAX,ISTART,ISTOP CALL EDWRST('EDNEAT') ENDIF 1177 FORMAT('IMIN,IMAX,ISTART,ISTOP = ',4I8) GOTO1190 C 1110 CONTINUE IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C ISTART=ICURLN ISTOP=ISTART+IARG1-1 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1120 CONTINUE IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C IARG2=1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) C ISTART=IARG1 IF(ISTART.LE.0)ISTART=1 ISTOP=IARG2 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1190 CONTINUE ICURL2=ISTOP ISTAR2=ICURL2 C C *********************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES. ** C *********************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEAT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLN=ISTART CALL EDZERO(ICNEWL,NCNEWL) NCNEWL=ICOLL1-1 C DO2100ILINE=ISTART,ISTOP C C ******************************************************* C ** STEP 22-- ** C ** OPERATE ON A GIVEN LINE-- ** C ** 1) EXTRACT THE LINE (PUT IT INTO ICLINE) ** C ** 2) LOOP THOUGH THE VARIOUS WORDS ** C ** 3) FOR EACH WORD-- ** C ** 5) IF THE NEWLY-CREATED LINE IS NOT FULL, ** C ** THEN ADD THE WORD TO IT; ** C ** 6) IF THE NEWLY-CREATED LINE IS FULL, ** C ** THEN APPEND THE LINE AFTER THE PARAGRAPH. ** C ** AND "ZERO-OUT" THE LINE FOR ANOTHER LINE. ** C ** NOTE--TREAT THE FORTRAN JUSTIFICATION CASE ** C ** IN A SPECIAL FASHION. ** C ******************************************************* C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(N1.LE.0)GOTO2100 J=J1-1 DO2200I=1,N1 J=J+1 ICLINE(I:I)=ICHA(J) 2200 CONTINUE NCLINE=N1 C IF(IJUST.EQ.'FORT')GOTO2210 GOTO2219 2210 CONTINUE DO2211I=1,NCLINE ICNEWL(I:I)=ICLINE(I:I) 2211 CONTINUE NCNEWL=NCLINE CALL EDJUST(ICNEWL,NCNEWL,ICOLL1,ICOLL2) CALL EDINLI(ICNEWL,NCNEWL,ICURL2) CALL EDZERO(ICNEWL,NCNEWL) NCNEWL=0 GOTO2100 2219 CONTINUE C IC1=ICOLL1 IC2=N1 IC3=0 IC4=IC2 C IF(ILINE.EQ.ISTART)GOTO2220 GOTO2250 2220 CONTINUE NCNEWL=ICOLL1-1 IF(NCNEWL.LE.0)GOTO2229 DO2221K=1,NCNEWL ICNEWL(K:K)=ICLINE(K:K) 2221 CONTINUE 2229 CONTINUE 2250 CONTINUE C DO2300IW=1,N1 C IF(IW.GE.2)IC1=IC4+1 IF(IC1.GT.IC2)GOTO2100 CALL EDZERO(ICWORD,NCWORD) CALL EDEXWO(ICLINE,NCLINE,IC1,IC2,IC3,IC4, 1ICWORD,NCWORD,IFOUWO) IF(IFOUWO.EQ.'YES')GOTO2310 GOTO2300 C 2310 CONTINUE CALL EDADWO(ICNEWL,NCNEWL,ICWORD,NCWORD, 1ICOLL1,ICOLL2,IBLASW,IADDED) C IF(IADDED.EQ.'YES')GOTO2300 CALL EDJUST(ICNEWL,NCNEWL,ICOLL1,ICOLL2) CCCCC WRITE(ICOUT,777)(ICNEWL(I:I),I=1,100) CC777 FORMAT('***** ICNEWL = ',100A1) CALL EDINLI(ICNEWL,NCNEWL,ICURL2) CALL EDZERO(ICNEWL,NCNEWL) NCNEWL=ICOLL1-1 C CALL EDADWO(ICNEWL,NCNEWL,ICWORD,NCWORD, 1ICOLL1,ICOLL2,IBLASW,IADDED) IF(IADDED.EQ.'YES')GOTO2300 WRITE(ICOUT,2321) CALL EDWRST('EDNEAT') 2321 FORMAT('***** ERROR IN EDNEAT--') WRITE(ICOUT,2322) CALL EDWRST('EDNEAT') 2322 FORMAT(' WORD IS TOO LONG TO BE ADDED') WRITE(ICOUT,2323) CALL EDWRST('EDNEAT') 2323 FORMAT(' (EVEN TO AN EMPTY NEW LINE)') WRITE(ICOUT,2324)NCNEWL CALL EDWRST('EDNEAT') 2324 FORMAT('NCNEWL = ',I8) IF(NCNEWL.GE.1)THEN WRITE(ICOUT,2325)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDNEAT') ENDIF 2325 FORMAT('(ICNEWL(I:I),I=1,NCNEWL) = ',100A1) WRITE(ICOUT,2326)NCWORD CALL EDWRST('EDNEAT') 2326 FORMAT('NCWORD = ',I8) IF(NCWORD.GE.1)THEN WRITE(ICOUT,2327)(ICWORD(I:I),I=1,100) CALL EDWRST('EDNEAT') ENDIF 2327 FORMAT('(ICWORD(I:I),I=1,NCWORD) = ',100A1) WRITE(ICOUT,2328)ICOLL1,ICOLL2,IBLASW,IADDED CALL EDWRST('EDNEAT') 2328 FORMAT('ICOLL1,ICOLL2,IBLASW,IADDED = ',2I8,2X,A4,2X,A4) GOTO2300 C 2300 CONTINUE 2100 CONTINUE IF(NCNEWL.GE.1)GOTO2450 GOTO2490 2450 CONTINUE IF(IJUST.EQ.'RIGH'.OR.IJUST.EQ.'FORT') 1CALL EDJUST(ICNEWL,NCNEWL,ICOLL1,ICOLL2) CALL EDINLI(ICNEWL,NCNEWL,ICURL2) 2490 CONTINUE CALL EDZERO(ICNEWL,NCNEWL) NCNEWL=ICOLL1-1 ISTOP2=ICURL2 C C *********************************************** C ** STEP 31-- ** C ** DELETE THE OLD (NON-NEAT) LINES. ** C *********************************************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEAT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IFEES2='OFF' DO3100ILINE=ISTART,ISTOP CALL EDDELI(ISTART,IFEES2) 3100 CONTINUE CCCCC IDELSW='OFF' CCCCC IDELLN='-999' C C *********************************************** C ** STEP 32-- ** C ** PRINT THE NEW (NEAT) LINES. ** C *********************************************** C ISTEPN='32' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEAT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC IDEL=ISTOP-ISTART IDEL=ISTOP-ISTART+1 ISTAR3=ISTAR2-IDEL ISTOP3=ISTOP2-IDEL CCCCC THE FOLLOWING 2 LINES WERE ADDED DECEMBER 1994 IF(ISTAR3.LE.0)ISTAR3=1 IF(ISTOP3.LT.ISTAR3)ISTOP3=ISTAR3 DO3200ILINE=ISTAR3,ISTOP3 IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(N1.LE.0)GOTO3200 J=J1-1 DO3210I=1,N1 J=J+1 ICNEWL(I:I)=ICHA(J) 3210 CONTINUE NCNEWL=N1 CALL EDWRLI(ICNEWL,NCNEWL,ILINE) 3200 CONTINUE CALL EDZERO(ICNEWL,NCNEWL) NCNEWL=ICOLL1-1 C ICURLN=ISTOP3 WHY NOT WORK??? CCCCC ICURLN=ISTOP3-1 ICURLN=ISTOP3 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'NEAT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDNEAT') WRITE(ICOUT,9011) CALL EDWRST('EDNEAT') 9011 FORMAT('*****AT THE END OF EDNEAT--') WRITE(ICOUT,9012)ICURLN,ISTART,ISTOP CALL EDWRST('EDNEAT') 9012 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9013)IPRISW CALL EDWRST('EDNEAT') 9013 FORMAT('IPRISW = ',A4) WRITE(ICOUT,9014)ISTART,ISTOP,ISTAR2,ISTOP2 CALL EDWRST('EDNEAT') 9014 FORMAT('ISTART,ISTOP,ISTAR2,ISTOP2 = ',4I8) WRITE(ICOUT,9015)ICOLL1,ICOLL2,IBLASW,IJUST CALL EDWRST('EDNEAT') 9015 FORMAT('ICOLL1,ICOLL2,IBLASW,IJUST = ',2I8,2X,A4,2X,A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDNEXT C C PURPOSE--GO TO NEXT K-TH LINE C C NOTE--IF NO ARGUMENTS, THEN GO TO NEXT LINE C IF 1 ARGUMENT, THEN GO TO NEXT K-TH LINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDNE' ISUBN2='XT ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'NEXT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDNEXT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDNEXT') 51 FORMAT('***** AT THE BEGINNING OF EDNEXT--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO TO NEXT K-TH LINE ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'NEXT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C K=1 IF(NUMARG.GE.1.AND.IARGT(1).EQ.'NUMB')K=IARG(1) C ILINE=ICURLN+K C IF(ILINE.LT.1)GOTO1110 IF(ILINE.GT.NUMLIN)GOTO1120 GOTO1130 C 1110 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1119 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1111) CALL EDWRST('EDNEXT') ENDIF 1111 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1112) CALL EDWRST('EDNEXT') ENDIF 1112 FORMAT(10X,'[TOP]') 1119 CONTINUE ILINE=0 GOTO1190 C 1120 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121) CALL EDWRST('EDNEXT') ENDIF 1121 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122) CALL EDWRST('EDNEXT') ENDIF 1122 FORMAT(10X,'[BOTTOM]') 1129 CONTINUE ILINE=NUMLIN+1 GOTO1190 C 1130 CONTINUE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1139 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1131)(ICHA(J),J=J1,J2) CALL EDWRST('EDNEXT') ENDIF 1131 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1132)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDNEXT') ENDIF 1132 FORMAT(I6,':',3X,230A1) 1139 CONTINUE GOTO1190 C 1190 CONTINUE ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'NEXT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDNEXT') WRITE(ICOUT,9011) CALL EDWRST('EDNEXT') 9011 FORMAT('***** AT THE END OF EDNEXT--') WRITE(ICOUT,9012)NUMARG,K,ICURLN,ILINE CALL EDWRST('EDNEXT') 9012 FORMAT('NUMARG,K,ICURLN,ILINE = ',4I8) WRITE(ICOUT,9013)IROW,J1,N1,J2 CALL EDWRST('EDNEXT') 9013 FORMAT('IROW,J1,N1,J2 = ',4I8) WRITE(ICOUT,9014)IFEESW,IPRISW,INUMSW CALL EDWRST('EDNEXT') 9014 FORMAT('IFEESW,IPRISW,INUMSW = ',A4,2X,A4,2X,A4) WRITE(ICOUT,9015)(ICHA(J),J=1,100) CALL EDWRST('EDNEXT') 9015 FORMAT('ICHA(J),J=1,100 =',100A1) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDOPEN C C PURPOSE--OPEN (BUT DO NOT WRITE TO PER SE) A FILE C NOTE--IF NO ARGUMENTS GIVEN, C THE THE DEFAULT PRINTER FILE WILL BE OPENED. C --IF 1 ARGUMENT GIVEN (PRESUMEDLY A FILE NAME), C THEN THAT FILE WILL BE OPENED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED --AUGUST 1992. USE DATAPLOT ROUTINE DPOPFI C (TO AVOID INSTALLERS HAVING TO C MODIFY ADDITIONAL FILES) C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CCCCC CHARACTER*80 IREC CHARACTER*1 ISTRIN CHARACTER*4 IFOUEX C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDLI' ISUBN2='ST ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDOPEN') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDOPEN') 51 FORMAT('***** AT THE BEGINNING OF EDOPEN--') WRITE(ICOUT,53)IOPENU CALL EDWRST('EDOPEN') 53 FORMAT('IOPENU = ',I8) WRITE(ICOUT,54)IOPENA CALL EDWRST('EDOPEN') 54 FORMAT('IOPENA = ',A80) WRITE(ICOUT,55)IOPEST CALL EDWRST('EDOPEN') 55 FORMAT('IOPEST = ',A12) WRITE(ICOUT,56)IOPEFO CALL EDWRST('EDOPEN') 56 FORMAT('IOPEFO = ',A12) WRITE(ICOUT,57)IOPEAC CALL EDWRST('EDOPEN') 57 FORMAT('IOPEAC = ',A12) WRITE(ICOUT,58)IOPERW CALL EDWRST('EDOPEN') 58 FORMAT('IOPERW = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDOPEN') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 11-- ** C ** DETERMINE THE NAME OF THE FILE ** C ** THAT IS TO BE OPENED ** C ** (IF NO NAME IS GIVEN, ** C ** THEN USE A DEFAULT FILE NAME). ** C ******************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUEX) IF(IFOUEX.EQ.'YES')GOTO1110 GOTO1120 C 1110 CONTINUE IFILE=' ' IF(NUMCST.LE.0)GOTO1119 DO1111I=1,NUMCST IFILE(I:I)=ISTRIN(I) 1111 CONTINUE 1119 CONTINUE ISTAT='UNKNOWN' GOTO1190 C 1120 CONTINUE IFILE=IOPENA ISTAT=IOPEST GOTO1190 C 1190 CONTINUE IOUNIT=IOPENU IFORM=IOPEFO IACCES=IOPEAC IREWR=IOPERW ISUBN0='OPEN' IERRFI='NO' C C **************************** C ** STEP 12-- ** C ** WRITE OUT A MESSAGE ** C ** IDENTIFYING THE FILE ** C **************************** C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL EDWRST('EDOPEN') WRITE(ICOUT,1205)IFILE CALL EDWRST('EDOPEN') 1205 FORMAT(10X,'FILE = ',A80) WRITE(ICOUT,999) CALL EDWRST('EDOPEN') C C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'ADD') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO9000 REWIND IOUNIT C CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ADD')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDOPEN') WRITE(ICOUT,9011) CALL EDWRST('EDOPEN') 9011 FORMAT('***** AT THE END OF EDOPEN--') WRITE(ICOUT,9013)IFILE CALL EDWRST('EDOPEN') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDOPEN') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDOPEN') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,999) CALL EDWRST('EDOPEN') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR, 1ISUBN0,IERRFI) C C PURPOSE--OPEN A FILE C (BUT THERE MAY BE SOME SMALL DIFFERENCES C IN HOW THAT IS DONE FOR DIFFERENT COMPUTERS). C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--NOVEMBER 1985. C C------------------------------------------------------------------------------ C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CCCCC CHARACTER*12 ICC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDOP' ISUBN2='FI ' C IFOUND='YES' IERROR='NO' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'OPFI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDOPFI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDOPFI') 51 FORMAT('***** AT THE BEGINNING OF EDOPFI--') WRITE(ICOUT,52)IBUGFI,ISUBRO CALL EDWRST('EDOPFI') 52 FORMAT('IBUGFI,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,53)IOUNIT CALL EDWRST('EDOPFI') 53 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,54)IFILE CALL EDWRST('EDOPFI') 54 FORMAT('IFILE = ',A80) WRITE(ICOUT,55)ISTAT CALL EDWRST('EDOPFI') 55 FORMAT('ISTAT = ',A12) WRITE(ICOUT,56)IFORM CALL EDWRST('EDOPFI') 56 FORMAT('IFORM = ',A12) WRITE(ICOUT,57)IACCES CALL EDWRST('EDOPFI') 57 FORMAT('IACCES = ',A12) WRITE(ICOUT,58)IREWR CALL EDWRST('EDOPFI') 58 FORMAT('IREWR = ',A12) WRITE(ICOUT,59)ISUBN0 CALL EDWRST('EDOPFI') 59 FORMAT('ISUBN0 = ',A4) WRITE(ICOUT,60)IERRFI CALL EDWRST('EDOPFI') 60 FORMAT('IERRFI = ',A4) WRITE(ICOUT,61)IHOST1 CALL EDWRST('EDOPFI') 61 FORMAT('IHOST1 = ',A4) 90 CONTINUE C C ******************************************************** C ** STEP 1-- ** C ** OPEN A FILE. ** C ** NOTE--ON THE VAX ** C ** (AND PROBABLY MOST OTHER COMPUTERS), ** C ** IF YOU HAVE THE READONLY ARGUMENT, ** C ** THEN THE ONLY ACCEPTABLE STATUS IS 'OLD'-- ** C ** A STATUS OF 'UNKNOWN' OR 'NEW' WILL ** C ** RESULT IN THE FILE NOT BEING OPENED ** C ** EVEN THOUGH THE FILE MAY EXIST. ** C ******************************************************** C ISTEPN='1' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'OPFI') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IHOST1.EQ.'VAX')GOTO1100 IF(IHOST1.EQ.'HONE')GOTO1300 IF(IHOST1.EQ.'IBM-')GOTO1400 GOTO1200 C 1100 CONTINUE CCCCC IF(IREWR.EQ.'READONLY') CCCCC1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS='OLD',FORM=IFORM, CCCCC1ERR=5100,ACCESS=IACCES,CARRIAGE CONTROL='LIST',READONLY) CCCCC IF(IREWR.NE.'READONLY') CCCCC1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM=IFORM, CCCCC1ERR=5100,ACCESS=IACCES,CARRIAGE CONTROL='LIST') GOTO9000 C 1200 CONTINUE IF(IREWR.EQ.'READONLY') 1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS='OLD',FORM=IFORM, 1ERR=5100) IF(IREWR.NE.'READONLY') 1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM=IFORM, 1ERR=5100) GOTO9000 C 1300 CONTINUE CCCCC IF(IREWR.EQ.'READONLY') CCCCC1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS='OLD',FORM=IFORM, CCCCC1MODE="IN",ERR=5100) CCCCC IF(IREWR.NE.'READONLY') CCCCC1OPEN(UNIT=IOUNIT,FILE=IFILE,FORM=IFORM, CCCCC1ERR=5100) GOTO9000 C 1400 CONTINUE IF(IREWR.EQ.'READONLY') 1OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS='OLD',FORM=IFORM, 1ERR=5100) IF(IREWR.NE.'READONLY') 1OPEN(UNIT=IOUNIT,FILE=IFILE,FORM=IFORM, 1ERR=5100) GOTO9000 C 5100 CONTINUE IERRFI='YES' WRITE(ICOUT,999) CALL EDWRST('EDOPFI') WRITE(ICOUT,5101) CALL EDWRST('EDOPFI') 5101 FORMAT('***** ERROR IN EDOPFI--') WRITE(ICOUT,5102) CALL EDWRST('EDOPFI') 5102 FORMAT('ERROR IN ATTEMPTING TO OPEN A FILE.') WRITE(ICOUT,5103)IOUNIT CALL EDWRST('EDOPFI') 5103 FORMAT('I/O UNIT = ',I8) WRITE(ICOUT,5104)IFILE CALL EDWRST('EDOPFI') 5104 FORMAT('FILE NAME = ',A80) WRITE(ICOUT,5105)ISTAT CALL EDWRST('EDOPFI') 5105 FORMAT('FILE STATUS = ',A12) WRITE(ICOUT,5106)IFORM CALL EDWRST('EDOPFI') 5106 FORMAT('FILE FORMAT = ',A12) WRITE(ICOUT,5107)IACCES CALL EDWRST('EDOPFI') 5107 FORMAT('FILE ACCESS = ',A12) WRITE(ICOUT,5108)IREWR CALL EDWRST('EDOPFI') 5108 FORMAT('FILE READ/WRITE SETTING = ',A12) WRITE(ICOUT,5109)ISUBN0 CALL EDWRST('EDOPFI') 5109 FORMAT('PREVIOUS (= CALLING) SUBROUTINE = ',A4) WRITE(ICOUT,5110)IHOST1 CALL EDWRST('EDOPFI') 5110 FORMAT('HOST COMPUTER = ',A4) GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'OPFI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDOPFI') WRITE(ICOUT,9011) CALL EDWRST('EDOPFI') 9011 FORMAT('***** AT THE END OF EDOPFI--') WRITE(ICOUT,9012)IBUGFI,ISUBRO CALL EDWRST('EDOPFI') 9012 FORMAT('IBUGFI,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,9013)IOUNIT CALL EDWRST('EDOPFI') 9013 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9014)IFILE CALL EDWRST('EDOPFI') 9014 FORMAT('IFILE = ',A80) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDOPFI') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)IFORM CALL EDWRST('EDOPFI') 9016 FORMAT('IFORM = ',A12) WRITE(ICOUT,9017)IACCES CALL EDWRST('EDOPFI') 9017 FORMAT('IACCES = ',A12) WRITE(ICOUT,9018)IREWR CALL EDWRST('EDOPFI') 9018 FORMAT('IREWR = ',A12) WRITE(ICOUT,9019)ISUBN0 CALL EDWRST('EDOPFI') 9019 FORMAT('ISUBN0 = ',A4) WRITE(ICOUT,9020)IERRFI CALL EDWRST('EDOPFI') 9020 FORMAT('IERRFI = ',A4) WRITE(ICOUT,9021)IHOST1 CALL EDWRST('EDOPFI') 9021 FORMAT('IHOST1 = ',A4) 9090 CONTINUE C RETURN END SUBROUTINE EDOPPR C C PURPOSE--OPEN THE PRINTER C (FOR THE IBM-PC PRINTER, C OPEN THE PRINTER "FILE") C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDAC' ISUBN2='PR ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'ACPR')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDOPPR') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDOPPR') 51 FORMAT('***** AT THE BEGINNING OF EDOPPR--') 90 CONTINUE C NCOUT=1 ICOUT(1:1)=IDLEC ILOUT=(-1) CALL EDWRST('EDOPPR') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDOPPR') WRITE(ICOUT,9011) CALL EDWRST('EDOPPR') 9011 FORMAT('***** AT THE END OF EDOPPR--') 9090 CONTINUE C RETURN END SUBROUTINE EDPA C C PURPOSE--PRINT OUT ALL REMAINING LINES OF TEXT. C IF NO ARGUMENTS, THEN PRINT OUT CURRENT LINE C + ALL REMAINING LINES. C IF 1 ARGUMENT , THEN PRINT THAT LINE C + ALL REMAINING LINES. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPR' ISUBN2='IN ' C IFOUND='YES' IERROR='NO' C IEOF='NO' IARG1=(-999) J=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPA ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPA ') 51 FORMAT('***** AT THE BEGINNING OF EDPA--') WRITE(ICOUT,52)IPRISW,ICURLN CALL EDWRST('EDPA ') 52 FORMAT('IPRISW,ICURLN = ',A4,I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 2-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE PRINTED. ** C ************************************ C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=NUMLIN C IF(NUMARG.LE.0)GOTO1100 GOTO1110 C 1100 CONTINUE ISTART=ICURLN IF(ISTART.LE.0)ISTART=1 ISTOP=NUMLIN IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C ISTART=IARG1 IF(ISTART.LE.0)ISTART=1 ISTOP=NUMLIN IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1190 CONTINUE CCCCC IHOLD1=ISTART CCCCC IHOLD2=ISTOP CCCCC IF(IHOLD1.GT.IHOLD2)ISTART=ISTOP CCCCC IF(IHOLD1.GT.IHOLD2)ISTOP=ISTART C C *********************************************** C ** STEP 21-- ** C ** COPY OVER THE PRINTER "FILE" VARIABLES) ** C ** (IF CALLED FOR) ** C *********************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2190 C C IOUNIT=IPRINU IFILE=IPRINA ISTAT=IPRIST IFORM=IPRIFO IACCES=IPRIAC IREWR=IPRIRW ISUBN0='PRIN' IERRFI='NO' IF(IBUGE2.EQ.'OFF')GOTO2189 WRITE(ICOUT,999) CALL EDWRST('EDPA ') WRITE(ICOUT,2181) CALL EDWRST('EDPA ') 2181 FORMAT('***** FROM THE MIDDLE OF EDPA--') WRITE(ICOUT,2183)IFILE CALL EDWRST('EDPA ') 2183 FORMAT('IFILE = ',A80) WRITE(ICOUT,2184)IOUNIT CALL EDWRST('EDPA ') 2184 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,2185)ISTAT CALL EDWRST('EDPA ') 2185 FORMAT('ISTAT = ',A12) 2189 CONTINUE C 2190 CONTINUE C C ************************* C ** STEP 22-- ** C ** OPEN THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2290 C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C 2290 CONTINUE C C **************************** C ** STEP 31-- ** C ** PRINT OUT THE LINES. ** C **************************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO3150 DO3110ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) NCOUT=0 IF(J1.GT.J2)GOTO3129 DO3120J=J1,J2 NCOUT=NCOUT+1 ICOUT(NCOUT:NCOUT)=ICHA(J) 3120 CONTINUE 3129 CONTINUE ILOUT=ILINE CALL EDWRST('EDPA ') 3110 CONTINUE C 3150 CONTINUE IF(IEOF.EQ.'NO')GOTO3159 IF(IFEESW.EQ.'OFF')GOTO3159 ICOUT(1:12)='[BOTTOM]' NCOUT=12 ILOUT=(-999) CALL EDWRST('EDPA ') 3159 CONTINUE C ICURLN=ISTOP IF(IEOF.EQ.'YES')ICURLN=NUMLIN+1 C C ************************* C ** STEP 41-- ** C ** CLOSE THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO4190 C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPA ') WRITE(ICOUT,9011) CALL EDWRST('EDPA ') 9011 FORMAT('***** AT THE END OF EDPA--') WRITE(ICOUT,9012)ICURLN,ISTART,ISTOP CALL EDWRST('EDPA ') 9012 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9013)IPRISW CALL EDWRST('EDPA ') 9013 FORMAT('IPRISW = ',A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPERI C C PURPOSE--THIS IS A NULL SUBROUTINE C FOR THE . COMMAND C WHICH IS A NULL COMMENT COMMAND. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPE' ISUBN2='RI ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PERI')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPERI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPERI') 51 FORMAT('*****AT THE BEGINNING OF EDPERI--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PERI')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPERI') WRITE(ICOUT,9011) CALL EDWRST('EDPERI') 9011 FORMAT('*****AT THE END OF EDPERI--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPL C C PURPOSE--PRINT TEXT UNTIL LOCATE STRING C START WITH CURRENT LINE C STOP WITH NEXT LINE WITH SPECIFIED STRING C C IF NO ARGUMENTS, THEN PRINT TO END OF FILE C IF 1 ARGUMENT , THEN PRINT UNTIL LOCATE LINE WITH ARG1 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 ISTRIN CHARACTER*4 IFOUST CHARACTER*4 IHIT CHARACTER*4 IDONE C DIMENSION ISTRIN(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPL' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IHIT='NO' IDONE='NO' C J1=(-999) N1=(-999) J2=(-999) IMIN=(-999) IFIRBL=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPL ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPL ') 51 FORMAT('*****AT THE BEGINNING OF EDPL--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ******************************************* C ** STEP 1-- ** C ** DETERMINE THE STRING TO BE LOCATED ** C ******************************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDEXST(ISTRIN,NUMCST,IFOUST) IF(IFOUST.EQ.'YES')GOTO1190 C NUMCST=NUMCLS IF(NUMCLS.LE.0)GOTO1159 DO1155I=1,NUMCLS ISTRIN(I)=ILOCST(I) 1155 CONTINUE 1159 CONTINUE GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 2-- ** C ** IF THE STRING IS NEW, ** C ** COPY THE STRING INTO ILOCST(.) ** C ** FOR FUTURE USE BY SUBSEQUENT ** C ** LOCATE COMMANDS. ** C ************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFOUST.EQ.'NO')GOTO1290 NUMCLS=NUMCST IF(NUMCST.LE.0)GOTO1290 DO1210I=1,NUMCST ILOCST(I)=ISTRIN(I) 1210 CONTINUE 1290 CONTINUE C C ************************************ C ** STEP 3-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ************************************ C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=NUMLIN C C ********************************* C ** STEP 4-- ** C ** SCAN AND PRINT THE LINES. ** C ********************************* C ISTEPN='4' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IDONE='NO' IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO1550 C DO1510ILINE=ISTART,ISTOP C ICURLN=ILINE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDLOC2(ISTRIN,NUMCST,J1,J2,IHIT) IF(IHIT.EQ.'NO')GOTO1520 IF(ILINE.EQ.ISTART)GOTO1520 IDONE='YES' GOTO1520 C 1520 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDPL ') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDPL ') ENDIF 1522 FORMAT(I6,':',3X,230A1) IF(IDONE.EQ.'YES')GOTO1590 C 1510 CONTINUE C 1550 CONTINUE ICURLN=NUMLIN+1 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDPL ') ENDIF 1551 FORMAT('===BOTTOM===') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDPL ') ENDIF 1552 FORMAT(10X,'===BOTTOM===') 1559 CONTINUE GOTO1590 C 1590 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPL ') WRITE(ICOUT,9011) CALL EDWRST('EDPL ') 9011 FORMAT('*****AT THE END OF EDPL--') WRITE(ICOUT,9012)ICURLN,ISTART,ISTOP CALL EDWRST('EDPL ') 9012 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9016)IFIRBL,IMIN,IWIDTH CALL EDWRST('EDPL ') 9016 FORMAT('IFIRBL,IMIN,IWIDTH = ',3I8) WRITE(ICOUT,9017)J1,N1,J2 CALL EDWRST('EDPL ') 9017 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,9018)J1,J2,IHIT,ICURLN CALL EDWRST('EDPL ') 9018 FORMAT('J1,J2,IHIT,ICURLN = ',4I8) WRITE(ICOUT,9019)IFOUST CALL EDWRST('EDPL ') 9019 FORMAT('IFOUST = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDPL ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPP(IPPLIN,IPPOFF) C C PURPOSE--PRINT OUT A PAGEFUL OF TEXT-- C THAT IS, PRINT OUT FROM (AND INCLUDING) CURRENT LINE - IPPOFF C 1) AND THE NEXT IPPLIN LINES; OR C 2) DOWN TO A LINE WHICH STARTS WITH **S OR **s C (WHICHEVER COMES FIRST). C IF NO ARGUMENTS, THEN PRINT OUT CURRENT PAGE C IF 1 ARGUMENT , THEN PRINT ARG1 PAGES C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C UPDATED --DECEMBER 1988. ELIMINATE MULTI-PRINTING OF SAME PAGE C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 IHIT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPP' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PP')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPP ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPP ') 51 FORMAT('*****AT THE BEGINNING OF EDPP--') WRITE(ICOUT,52)IPRISW,IPRINU,IOUNIT,INUMSW CALL EDWRST('EDPP ') 52 FORMAT('IPRISW,IPRINU,IOUNIT,INUMSW = ',A4,I8,I8,2X,A4) WRITE(ICOUT,53)IPPLIN,IPPOFF CALL EDWRST('EDPP ') 53 FORMAT('IPPLIN,IPPOFF = ',2I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************* C ** STEP 11-- ** C ** DETERMINE THE NUMBER OF PAGES ** C ** TO BE PRINTED ** C ************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1100 GOTO1110 C 1100 CONTINUE NUMPAG=1 GOTO1190 C 1110 CONTINUE NUMPAG=100000 IF(IARGT(1).EQ.'NUMB')NUMPAG=IARG(1) IF(NUMPAG.LE.0)NUMPAG=1 GOTO1190 C 1190 CONTINUE C THE FOLLOWING FIX WAS INSERTED DECEMBER 1988 TO AVOID PP 50 C (FOR EXAMPLE) YIELDING 50 PRINTINGS OF THE SAME PAGE. NUMPAG=1 C C ************************************ C ** STEP 12-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SCANNED. ** C ** NOTE--IPPOFF IS USUALLY A NEGATIVE NUMBER ** C ************************************ C ISTEPN='12' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN+IPPOFF CCCCC ISTOP=NUMLIN ISTOP=ISTART+(IPPLIN-1) IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C C *********************************************** C ** STEP 21-- ** C ** COPY OVER THE PRINTER "FILE" VARIABLES) ** C ** (IF CALLED FOR) ** C *********************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2190 C IOUNIT=IPRINU IFILE=IPRINA ISTAT=IPRIST IFORM=IPRIFO IACCES=IPRIAC IREWR=IPRIRW ISUBN0='PP' IERRFI='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PP')GOTO2189 WRITE(ICOUT,999) CALL EDWRST('EDPP ') WRITE(ICOUT,2181) CALL EDWRST('EDPP ') 2181 FORMAT('***** FROM THE MIDDLE OF EDPP--') WRITE(ICOUT,2183)IFILE CALL EDWRST('EDPP ') 2183 FORMAT('IFILE = ',A80) WRITE(ICOUT,2184)IOUNIT CALL EDWRST('EDPP ') 2184 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,2185)ISTAT CALL EDWRST('EDPP ') 2185 FORMAT('ISTAT = ',A12) 2189 CONTINUE C 2190 CONTINUE C C ************************* C ** STEP 22-- ** C ** OPEN THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2290 C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED', CCCCC1ERR=2280) CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO2280 GOTO2290 C 2280 CONTINUE WRITE(ICOUT,2281) CALL EDWRST('EDPP ') 2281 FORMAT('***** ERROR IN EDPP--') WRITE(ICOUT,2282) CALL EDWRST('EDPP ') 2282 FORMAT(' FAILED IN ATTEMPTING TO OPEN THE PRINTER') IERROR='YES' GOTO9000 C 2290 CONTINUE C C **************************** C ** STEP 31-- ** C ** SCAN THE LINES. ** C **************************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO3150 C DO3100IPAGE=1,NUMPAG DO3110ILINE=ISTART,ISTOP C ICURLN=ILINE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) CALL EDPP2(J1,J2,IHIT) IF(IHIT.EQ.'NO')GOTO3120 IF(ILINE.EQ.ISTART)GOTO3110 GOTO3100 C 3120 CONTINUE IF(INUMSW.EQ.'ON')GOTO3121 GOTO3126 3121 CONTINUE WRITE(ICOUT,3122)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDPP ') 3122 FORMAT(I6,':',3X,230A1) IF(IPRISW.EQ.'ON')THEN WRITE(IOUNIT,3123)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDPP ') 3123 FORMAT(I6,':',3X,230A1) ENDIF GOTO3129 3126 CONTINUE WRITE(ICOUT,3127)(ICHA(J),J=J1,J2) CALL EDWRST('EDPP ') 3127 FORMAT(238A1) IF(IPRISW.EQ.'ON')THEN WRITE(IOUNIT,3128)(ICHA(J),J=J1,J2) 3128 FORMAT(238A1) ENDIF GOTO3129 3129 CONTINUE C 3110 CONTINUE 3100 CONTINUE GOTO3190 C 3150 CONTINUE ICURLN=NUMLIN+1 GOTO3190 C 3190 CONTINUE C C ************************* C ** STEP 41-- ** C ** CLOSE THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO4190 C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PP')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPP ') WRITE(ICOUT,9011) CALL EDWRST('EDPP ') 9011 FORMAT('*****AT THE END OF EDPP--') WRITE(ICOUT,9012)IPPLIN,IPPOFF CALL EDWRST('EDPP ') 9012 FORMAT('IPPLIN,IPPOFF = ',2I8) WRITE(ICOUT,9013)ICURLN,ISTART,ISTOP CALL EDWRST('EDPP ') 9013 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9014)IPRISW,IPRINU,IOUNIT,INUMSW CALL EDWRST('EDPP ') 9014 FORMAT('IPRISW,IPRINU,IOUNIT,INUMSW = ',A4,I8,I8,2X,A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPP2(J1,J2,IHIT) C C PURPOSE--SCAN ICHA(.) BETWEEN C ELEMENTS J1 AND J2 (INCLUSIVE) C AND DETERMINE IF THE STRINGS **NEW OR **new C OR **ERASE OR **erase C ARE CONTAINED THERIN IN COLUMNS 1 TO 5. C IF SO, THEN SET IHIT TO 'YES' C IF NO, THEN SET IHIT TO 'NO' C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*8 IC8 C CHARACTER*4 IHIT C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPP' ISUBN2='2 ' C K1=(-999) K2=(-999) K3=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PP2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPP2 ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPP2 ') 51 FORMAT('***** AT THE BEGINNING OF EDPP2--') WRITE(ICOUT,54)J1,J2 CALL EDWRST('EDPP2 ') 54 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,57)IHIT CALL EDWRST('EDPP2 ') 57 FORMAT('IHIT = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDPP2 ') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' C JDEL=J2-J1+1 IF(JDEL.LE.4)GOTO1110 C K1=J1 K2=J1+1 K3=J1+2 K4=J1+3 K5=J1+4 IC8(1:1)=ICHA(K1) IC8(2:2)=ICHA(K2) IC8(3:3)=ICHA(K3) IC8(4:4)=ICHA(K4) IC8(5:5)=ICHA(K5) IF(IC8(1:5).EQ.'**NEW')GOTO1120 IF(IC8(1:5).EQ.'**new')GOTO1120 IF(IC8(1:5).EQ.'**ERA')GOTO1120 IF(IC8(1:5).EQ.'**era')GOTO1120 GOTO1110 C 1110 CONTINUE IHIT='NO' GOTO1190 C 1120 CONTINUE IHIT='YES' GOTO1190 C 1190 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PP2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPP2 ') WRITE(ICOUT,9011) CALL EDWRST('EDPP2 ') 9011 FORMAT('***** AT THE END OF EDPP2--') WRITE(ICOUT,9013)J1,J2 CALL EDWRST('EDPP2 ') 9013 FORMAT('J1,J2 = ',2I8) WRITE(ICOUT,9014)K1,K2,K3 CALL EDWRST('EDPP2 ') 9014 FORMAT('K1,K2,K3 = ',3I8) WRITE(ICOUT,9017)IHIT CALL EDWRST('EDPP2 ') 9017 FORMAT('IHIT = ',A4) WRITE(ICOUT,9018)IC8 CALL EDWRST('EDPP2 ') 9018 FORMAT('IC8 = ',A8) WRITE(ICOUT,999) CALL EDWRST('EDPP2 ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPRIN C C PURPOSE--PRINT OUT LINES OF TEXT. C IF NO ARGUMENTS, THEN PRINT OUT CURRENT LINE. C IF 1 ARGUMENT , THEN PRINT CURRENT LINE C + NEXT (N-1) LINES; C THAT IS, PRINT RELATIVE. C IF 2 ARGUMENTS, THEN PRINT LINES N1 TO N2, C THAT IS, PRINT ABSOLUTE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPR' ISUBN2='IN ' C IFOUND='YES' IERROR='NO' C IEOF='NO' IARG1=(-999) IARG2=(-999) J=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPRIN') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPRIN') 51 FORMAT('*****AT THE BEGINNING OF EDPRIN--') WRITE(ICOUT,52)IPRISW,ICURLN CALL EDWRST('EDPRIN') 52 FORMAT('IPRISW,ICURLN = ',A4,I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 2-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE PRINTED. ** C ************************************ C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ISTART C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ISTART IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN GOTO1190 C 1110 CONTINUE CCCCC IARG1=NUMLIN+1 IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C ISTART=ICURLN ISTOP=ISTART+IARG1-1 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1120 CONTINUE CCCCC IARG1=NUMLIN+1 IARG1=1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C CCCCC IARG2=NUMLIN+1 IARG2=1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) C ISTART=IARG1 IF(ISTART.LE.0)ISTART=1 ISTOP=IARG2 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1190 CONTINUE CCCCC IHOLD1=ISTART CCCCC IHOLD2=ISTOP CCCCC IF(IHOLD1.GT.IHOLD2)ISTART=ISTOP CCCCC IF(IHOLD1.GT.IHOLD2)ISTOP=ISTART C C *********************************************** C ** STEP 21-- ** C ** COPY OVER THE PRINTER "FILE" VARIABLES) ** C ** (IF CALLED FOR) ** C *********************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2190 C IOUNIT=IPRINU IFILE=IPRINA ISTAT=IPRIST IFORM=IPRIFO IACCES=IPRIAC IREWR=IPRIRW ISUBN0='PRIN' IERRFI='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO2189 WRITE(ICOUT,999) CALL EDWRST('EDPRIN') WRITE(ICOUT,2181) CALL EDWRST('EDPRIN') 2181 FORMAT('***** FROM THE MIDDLE OF EDPRIN--') WRITE(ICOUT,2183)IFILE CALL EDWRST('EDPRIN') 2183 FORMAT('IFILE = ',A80) WRITE(ICOUT,2184)IOUNIT CALL EDWRST('EDPRIN') 2184 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,2185)ISTAT CALL EDWRST('EDPRIN') 2185 FORMAT('ISTAT = ',A12) 2189 CONTINUE C 2190 CONTINUE C C ************************* C ** STEP 22-- ** C ** OPEN THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2290 C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED', CCCCC1ERR=2280) CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO2280 GOTO2290 C 2280 CONTINUE WRITE(ICOUT,2281) CALL EDWRST('EDPRIN') 2281 FORMAT('***** ERROR IN EDPRIN--') WRITE(ICOUT,2282) CALL EDWRST('EDPRIN') 2282 FORMAT(' FAILED IN ATTEMPTING TO OPEN THE PRINTER') IERROR='YES' GOTO9000 C 2290 CONTINUE C C **************************** C ** STEP 31-- ** C ** PRINT OUT THE LINES. ** C **************************** C ISTEPN='31' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTART.GT.ISTOP)GOTO3150 DO3110ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) NCOUT=0 IF(J1.GT.J2)GOTO3129 DO3120J=J1,J2 NCOUT=NCOUT+1 ICOUT(NCOUT:NCOUT)=ICHA(J) 3120 CONTINUE 3129 CONTINUE ILOUT=ILINE CALL EDWRST('EDPRIN') 3110 CONTINUE C 3150 CONTINUE IF(IEOF.EQ.'NO')GOTO3159 IF(IFEESW.EQ.'OFF')GOTO3159 ICOUT(1:12)='[BOTTOM]' NCOUT=12 ILOUT=(-999) CALL EDWRST('EDPRIN') 3159 CONTINUE C ICURLN=ISTOP IF(IEOF.EQ.'YES')ICURLN=NUMLIN+1 C C ************************* C ** STEP 41-- ** C ** CLOSE THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO4190 C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPRIN') WRITE(ICOUT,9011) CALL EDWRST('EDPRIN') 9011 FORMAT('*****AT THE END OF EDPRIN--') WRITE(ICOUT,9012)ICURLN,ISTART,ISTOP CALL EDWRST('EDPRIN') 9012 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9013)IPRISW CALL EDWRST('EDPRIN') 9013 FORMAT('IPRISW = ',A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDPRNE C C PURPOSE--PRINT OUT LINES OF TEXT C (STARTING WITH THE NEXT LINE). C IF NO ARGUMENTS, THEN PRINT OUT NEXT LINE ONLY. C IF 1 ARGUMENT , THEN PRINT NEXT LINE C + NEXT (N-1) LINES; C THAT IS, PRINT RELATIVE. C IF 2 ARGUMENTS, THEN PRINT LINES N1 TO N2, C THAT IS, PRINT ABSOLUTE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 IEOF C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDPR' ISUBN2='NE ' C IFOUND='YES' IERROR='NO' C IEOF='NO' IARG1=(-999) IARG2=(-999) J=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRNE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDPRNE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDPRNE') 51 FORMAT('*****AT THE BEGINNING OF EDPRNE--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 2-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE PRINTED. ** C ************************************ C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRNE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLP=ICURLN+1 C ISTART=ICURLP ISTOP=ISTART IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLP ISTOP=ISTART GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C ISTART=ICURLP ISTOP=ISTART+IARG1-1 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1120 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) C IARG2=NUMLIN+1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) C ISTART=IARG1 IF(ISTART.LE.0)ISTART=1 ISTOP=IARG2 IF(ISTOP.GT.NUMLIN)IEOF='YES' IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN C GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD1.GT.IHOLD2)ISTART=ISTOP IF(IHOLD1.GT.IHOLD2)ISTOP=ISTART C C **************************** C ** STEP 3-- ** C ** PRINT OUT THE LINES. ** C **************************** C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRNE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ISTART.LE.0)ISTART=1 IF(ISTOP.GT.NUMLIN)ISTOP=NUMLIN IF(ISTART.GT.ISTOP)GOTO9000 DO1510ILINE=ISTART,ISTOP IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1521)(ICHA(J),J=J1,J2) CALL EDWRST('EDPRNE') ENDIF 1521 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1522)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDPRNE') ENDIF 1522 FORMAT(I6,':',3X,230A1) 1510 CONTINUE C 1550 CONTINUE IF(IEOF.EQ.'NO')GOTO1559 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1551) CALL EDWRST('EDPRNE') ENDIF 1551 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1552) CALL EDWRST('EDPRNE') ENDIF 1552 FORMAT(10X,'[BOTTOM]') 1559 CONTINUE C ICURLN=ISTOP GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRNE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDPRNE') WRITE(ICOUT,9011) CALL EDWRST('EDPRNE') 9011 FORMAT('*****AT THE END OF EDPRNE--') WRITE(ICOUT,9012)ICURLN,ICURLP,ISTART,ISTOP CALL EDWRST('EDPRNE') 9012 FORMAT('ICURLN,ICURLP,ISTART,ISTOP = ',4I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDREFW(ID) C C PURPOSE--LOAD (= READ) A FILE INTO THE WORKSPACE C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C UPDATED--JULY 1986. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 ID C CHARACTER*4 IEXIST C CCCCC CHARACTER*80 IREC CHARACTER*240 IREC C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDRE' ISUBN2='FW ' C CCCCC IBUGFI='ON' IFOUND='YES' IERROR='NO' C IEXIST='-999' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'REFW')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDREFW') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDREFW') 51 FORMAT('*****AT THE BEGINNING OF EDREFW--') WRITE(ICOUT,52)ID,IBUGFI,ISUBRO CALL EDWRST('EDREFW') 52 FORMAT('ID,IBUGFI,ISUBRO = ',A4,2X,A4,2X,A4) WRITE(ICOUT,999) CALL EDWRST('EDREFW') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************** C ** STEP 11-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='11' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'REFW') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ID.EQ.'ORIG')GOTO1110 IF(ID.EQ.'SAVE')GOTO1120 GOTO1120 C 1110 CONTINUE IOUNIT=IORINU IFILE=IORINA ISTAT=IORIST IFORM=IORIFO IACCES=IORIAC IREWR=IORIRW ISUBN0='REFW' IERRFI='NO' GOTO1190 C 1120 CONTINUE IOUNIT=ISAVNU IFILE=ISAVNA ISTAT=ISAVST IFORM=ISAVFO IACCES=ISAVAC IREWR=ISAVRW ISUBN0='REFW' IERRFI='NO' GOTO1190 C 1190 CONTINUE IF(IBUGFI.EQ.'OFF')GOTO1199 WRITE(ICOUT,1193)IFILE CALL EDWRST('EDREFW') 1193 FORMAT('IFILE = ',A80) WRITE(ICOUT,1194)IOUNIT CALL EDWRST('EDREFW') 1194 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,1195)ISTAT CALL EDWRST('EDREFW') 1195 FORMAT('ISTAT = ',A12) WRITE(ICOUT,1196)NUMLIN,NUMCHA CALL EDWRST('EDREFW') 1196 FORMAT('NUMLIN,NUMCHA = ',2I8) 1199 CONTINUE C C ********************* C ** STEP 12-- ** C ** INQUIRE AS TO ** C ** WHETHER THE ** C ** FILE EXISTS. ** C ********************* C ISTEPN='12' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'REFW') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDINFI(IFILE,IEXIST,ISUBN0,IERRFI) NUMCHA=0 NUMLIN=0 NUMROW=0 IF(IEXIST.EQ.'NO')GOTO9000 C C ********************* C ** STEP 13-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='13' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'REFW') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C C **************************************************** C ** STEP 14-- ** C ** READ A FILE INTO THE WORKSPACE ** C **************************************************** C ISTEPN='14' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'REFW') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCHA=0 NUMLIN=0 NUMROW=0 C ILINE=0 J1=0 J2=0 C DO1300IDUMMY=1,100000 CCCCC NUMCRE=80 NUMCRE=240 CCCCC THE FOLLOWING LINE WAS ADDED APRIL 1993 IREC=' ' READ(IOUNIT,1305,END=1390)IREC 1305 FORMAT(A238) C IF(IBUGFI.EQ.'ON')WRITE(ICOUT,1306)IREC IF(IBUGFI.EQ.'ON')CALL EDWRST('EDREFW') 1306 FORMAT('IREC = ',A230) IF(IBUGFI.EQ.'ON')WRITE(ICOUT,1307)NUMCRE IF(IBUGFI.EQ.'ON')CALL EDWRST('EDREFW') 1307 FORMAT('NUMCRE = ',I8) C DO1400I=1,NUMCRE IREV=NUMCRE-I+1 IF(IREC(IREV:IREV).NE.' ')GOTO1490 1400 CONTINUE IREV=0 1490 CONTINUE NUMCRE=IREV C IF(IBUGFI.EQ.'ON')WRITE(ICOUT,1495)IREC IF(IBUGFI.EQ.'ON')CALL EDWRST('EDREFW') 1495 FORMAT('IREC = ',A230) IF(IBUGFI.EQ.'ON')WRITE(ICOUT,1496)NUMCRE IF(IBUGFI.EQ.'ON')CALL EDWRST('EDREFW') 1496 FORMAT('NUMCRE = ',I8) C ILINE=ILINE+1 IF(ILINE.LE.MAXEDL)GOTO1519 IERROR='YES' WRITE(ICOUT,999) CALL EDWRST('EDREFW') WRITE(ICOUT,1511) CALL EDWRST('EDREFW') 1511 FORMAT('***** ERROR IN EDREFW--') WRITE(ICOUT,1512) CALL EDWRST('EDREFW') 1512 FORMAT(' THE FILE BEING EDITED HAS TOO MANY LINES.') WRITE(ICOUT,1513)ILINE,MAXEDL CALL EDWRST('EDREFW') 1513 FORMAT(' ILINE,MAXEDL = ',2I8) WRITE(ICOUT,1514) CALL EDWRST('EDREFW') 1514 FORMAT(' ONLY A PARTIAL READ WAS DONE.') ILINE=MAXEDL GOTO1390 1519 CONTINUE C IPOINT(ILINE)=ILINE J1=J2+1 N1=NUMCRE J2=J1+(N1-1) ILOCC1(ILINE)=J1 NUMCPL(ILINE)=N1 C K=0 IF(J2.LE.MAXEDC)GOTO1529 IERROR='YES' WRITE(ICOUT,999) CALL EDWRST('EDREFW') WRITE(ICOUT,1521) CALL EDWRST('EDREFW') 1521 FORMAT('***** ERROR IN EDREFW--') WRITE(ICOUT,1522) CALL EDWRST('EDREFW') 1522 FORMAT(' THE FILE BEING EDITED HAS TOO MANY CHARACTERS.') WRITE(ICOUT,1523)J2,MAXEDC CALL EDWRST('EDREFW') 1523 FORMAT(' J2,MAXEDC = ',2I8) WRITE(ICOUT,1524) CALL EDWRST('EDREFW') 1524 FORMAT(' ONLY A PARTIAL READ WAS DONE.') J2=MAXEDC GOTO1390 1529 CONTINUE C IF(J1.GT.J2)GOTO1590 DO1500J=J1,J2 K=K+1 ICHA(J)=IREC(K:K) 1500 CONTINUE 1590 CONTINUE C 1300 CONTINUE 1390 CONTINUE NUMCHA=J2 NUMLIN=ILINE NUMROW=ILINE C C ********************** C ** STEP 15-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='15' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'REFW') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'REFW')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDREFW') WRITE(ICOUT,9011) CALL EDWRST('EDREFW') 9011 FORMAT('*****AT THE END OF EDREFW--') WRITE(ICOUT,9012)ID,IEXIST CALL EDWRST('EDREFW') 9012 FORMAT('ID,IEXIST = ',A4,2X,A4) WRITE(ICOUT,9013)IFILE CALL EDWRST('EDREFW') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDREFW') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDREFW') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDREFW') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,999) CALL EDWRST('EDREFW') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDREST C C PURPOSE--RESTORE CURRENT DOCUMENT FROM THE SAVE FILE. C NOTE--NO ARGUMENTS ARE EXPECTED. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ID C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDRE' ISUBN2='ST ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDREST') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDREST') 51 FORMAT('***** AT THE BEGINNING OF EDREST--') WRITE(ICOUT,52)NUMLIN CALL EDWRST('EDREST') 52 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,53)ISAVNA CALL EDWRST('EDREST') 53 FORMAT('ISAVNA = ',A80) WRITE(ICOUT,54)ISAVST CALL EDWRST('EDREST') 54 FORMAT('ISAVST = ',A12) WRITE(ICOUT,55)ISAVNU CALL EDWRST('EDREST') 55 FORMAT('ISAVNU = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *************************************** C ** STEP 1-- ** C ** READ WORKSPACE FROM SAVE FILE ** C *************************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ID='SAVE' CALL EDREFW(ID) C C ****************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE ** C ****************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,1205) CALL EDWRST('EDREST') 1205 FORMAT('THE SAVED VERSION HAS BEEN RESTORED') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDREST') WRITE(ICOUT,9011) CALL EDWRST('EDREST') 9011 FORMAT('***** AT THE END OF EDREST--') WRITE(ICOUT,9012)NUMLIN CALL EDWRST('EDREST') 9012 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,9013)ISAVNA CALL EDWRST('EDREST') 9013 FORMAT('ISAVNA = ',A80) WRITE(ICOUT,9014)ISAVST CALL EDWRST('EDREST') 9014 FORMAT('ISAVST = ',A12) WRITE(ICOUT,9015)ISAVNU CALL EDWRST('EDREST') 9015 FORMAT('ISAVNU = ',I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSACP C C PURPOSE--SAVE CURRENT SETTINGS OF INTERNAL POINTERS C FOR POSSIBLE LATER USE C BY THE UNDO COMMAND C NOTE--NO ARGUMENTS ARE EXPECTED. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSA' ISUBN2='CP ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SACP')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSACP') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSACP') 51 FORMAT('*****AT THE BEGINNING OF EDSACP--') WRITE(ICOUT,52)IBUGE2,ISUBRO CALL EDWRST('EDSACP') 52 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,53)NUMLOL,NUMROL,NCHAOL,IOLDLN CALL EDWRST('EDSACP') 53 FORMAT('NUMLOL,NUMROL,NCHAOL,IOLDLN = ',4I8) WRITE(ICOUT,54)NUMLIN,NUMROW,NUMCHA,ICURLN CALL EDWRST('EDSACP') 54 FORMAT('NUMLIN,NUMROW,NUMCHA,ICURLN = ',4I8) IF(NUMLIN.LE.0)GOTO59 DO55I=1,NUMLIN CCCCC WRITE(ICOUT,56)I,IPOIOL(I),IPOINT(I) CCC56 FORMAT('I,IPOIOL(I),IPOINT(I) = ',3I8) 55 CONTINUE 59 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDSACP') IF(IBUGT1.EQ.'ON')CALL EDTRA1 IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** COPY THE CURRENT SETTINGS ** C ** ONTO THE OLD SETTINGS ** C ********************************* C NCHAOL=NUMCHA NUMLOL=NUMLIN NUMROL=NUMROW IOLDLN=ICURLN C IF(NUMLIN.LE.0)GOTO1190 DO1100I=1,NUMLIN IPOIOL(I)=IPOINT(I) 1100 CONTINUE 1190 CONTINUE C C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SACP')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSACP') WRITE(ICOUT,9011) CALL EDWRST('EDSACP') 9011 FORMAT('*****AT THE END OF EDSACP--') WRITE(ICOUT,9012)NUMLOL,NUMROL,NCHAOL,IOLDLN CALL EDWRST('EDSACP') 9012 FORMAT('NUMLOL,NUMROL,NCHAOL,IOLDLN = ',4I8) WRITE(ICOUT,9013)NUMLIN,NUMROW,NUMCHA,ICURLN CALL EDWRST('EDSACP') 9013 FORMAT('NUMLIN,NUMROW,NUMCHA,ICURLN = ',4I8) IF(NUMLIN.LE.0)GOTO9019 DO9015I=1,NUMLIN CCCCC WRITE(ICOUT,9016)I,IPOIOL(I),IPOINT(I) C9016 FORMAT('I,IPOIOL(I),IPOINT(I) = ',3I8) 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDSACP') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSAVE C C PURPOSE--SAVE CURRENT DOCUMENT ONTO THE SAVE FILE. C NOTE--NO ARGUMENTS ARE EXPECTED. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ID C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSA' ISUBN2='VE ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSAVE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSAVE') 51 FORMAT('***** AT THE BEGINNING OF EDSAVE--') WRITE(ICOUT,52)NUMLIN CALL EDWRST('EDSAVE') 52 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,53)ISAVNA CALL EDWRST('EDSAVE') 53 FORMAT('ISAVNA = ',A80) WRITE(ICOUT,54)ISAVST CALL EDWRST('EDSAVE') 54 FORMAT('ISAVST = ',A12) WRITE(ICOUT,55)ISAVNU CALL EDWRST('EDSAVE') 55 FORMAT('ISAVNU = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *************************************** C ** STEP 1-- ** C ** WRITE WORKSPACE OUT TO THE FILE ** C *************************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ID='SAVE' CALL EDWRWF(ID) C C ****************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE ** C ****************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SAVE') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,1205) CALL EDWRST('EDSAVE') 1205 FORMAT('THE CURRENT DOCUMENT HAS BEEN SAVED') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SAVE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSAVE') WRITE(ICOUT,9011) CALL EDWRST('EDSAVE') 9011 FORMAT('***** AT THE END OF EDSAVE--') WRITE(ICOUT,9012)NUMLIN CALL EDWRST('EDSAVE') 9012 FORMAT('NUMLIN = ',I8) WRITE(ICOUT,9013)ISAVNA CALL EDWRST('EDSAVE') 9013 FORMAT('ISAVNA = ',A80) WRITE(ICOUT,9014)ISAVST CALL EDWRST('EDSAVE') 9014 FORMAT('ISAVST = ',A12) WRITE(ICOUT,9015)ISAVNU CALL EDWRST('EDSAVE') 9015 FORMAT('ISAVNU = ',I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSCAL C C PURPOSE--WRITE OUT A SCALE LINE WHICH CONSISTS C OF NUMBERS WHICH INDICATE THE COLUMNS 1 TO 80. C IF NO ARGUMENTS, THEN WRITE OUT 1 TO 80 C IF 1 ARGUMENT, THEN WRITE OUT 1 TO N1 C IF 2 ARGUMENTS, THEN WRITE OUT N1 TO N2 C NOTE--ONLY THE 1 TO 80 SCALE WORKS NOW. C TO BE DONE--THE OTHER OPTIONS C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*240 ISTRIN C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSC' ISUBN2='AL ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SCAL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSCAL') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSCAL') 51 FORMAT('*****AT THE BEGINNING OF EDSCAL--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *********************************************** C ** STEP 2-- ** C ** DETERMINE THE RIGHT-MOST COLUMN ** C ** THAT THE SCALE IS TO BE PRINTED OUT TO. ** C *********************************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'PRIN') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=1 ISTOP=80 CCCCC IF(INUMSW.EQ.'ON')ISTOP=70 JANUARY 1989 IF(INUMSW.EQ.'ON')ISTOP=80 C IF(NUMARG.LE.0)GOTO1100 GOTO1110 C 1100 CONTINUE GOTO1190 C 1110 CONTINUE IF(IARGT(1).EQ.'NUMB')ISTOP=IARG(1) GOTO1190 C 1190 CONTINUE IF(ISTART.LE.1)ISTART=1 IF(ISTOP.GE.240)ISTOP=240 IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD1.GT.IHOLD2)ISTART=IHOLD2 IF(IHOLD1.GT.IHOLD2)ISTOP=IHOLD1 C C *************************** C ** STEP 3-- ** C ** PRINT OUT THE SCALE ** C *************************** C ISTRIN(1:40)='123456789.123456789.123456789.123456789.' ISTRIN(41:80)='123456789.123456789.123456789.123456789.' ISTRIN(81:120)='123456789.123456789.123456789.123456789.' CCCCC THE FOLLOWING LINE WAS FIXED APRIL 1990 CCCCC ISTRIN(121:132)='123456789.123456789.123456789.123456789.' ISTRIN(121:240)='123456789.123456789.123456789.123456789.' C IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1105)(ISTRIN(I:I),I=ISTART,ISTOP) CALL EDWRST('EDSCAL') ENDIF 1105 FORMAT(131A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1106)(ISTRIN(I:I),I=ISTART,ISTOP) CALL EDWRST('EDSCAL') ENDIF 1106 FORMAT(10X,121A1) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SCAL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSCAL') WRITE(ICOUT,9011) CALL EDWRST('EDSCAL') 9011 FORMAT('*****AT THE END OF EDSCAL--') WRITE(ICOUT,9012)IHOLD1,IHOLD2,ISTART,ISTOP CALL EDWRST('EDSCAL') 9012 FORMAT('IHOLD1,IHOLD2,ISTART,ISTOP = ',4I8) WRITE(ICOUT,999) CALL EDWRST('EDSCAL') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSELM(ILMARG) C C PURPOSE--SET THE LEFT MARGIN ON THE PRINTER C (FOR THE IBM-PC PRINTER, C SPACE OUT TO THE DESIRED COLUMN, C AND THEN SEND DOWN AN ESCAPE 9 ) C (ESCAPE = ASCII ESC = CHAR(27) ) C NOTE--THE INPUT ARGUMENT IS THE DESIRED COLUMN C NUMBER FOR THE LEFT MARGIN. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSE' ISUBN2='LM ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SELM')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSELM') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSELM') 51 FORMAT('***** AT THE BEGINNING OF EDSELM--') WRITE(ICOUT,52)ILMARG CALL EDWRST('EDSELM') 52 FORMAT('ILMARG = ',I8) 90 CONTINUE C CALL EDACPR C NSPACE=ILMARG-1 IF(NSPACE.LT.0)NSPACE=0 IF(NSPACE.GT.240)NSPACE=240 C NCOUT=0 IF(NSPACE.LE.0)GOTO1190 DO1100I=1,NSPACE NCOUT=NCOUT+1 ICOUT(NCOUT:NCOUT)=' ' 1100 CONTINUE 1190 CONTINUE C NCOUT=NCOUT+1 ICOUT(NCOUT:NCOUT)=IESCC C NCOUT=NCOUT+1 ICOUT(NCOUT:NCOUT)='9' C ILOUT=(-1) CALL EDWRST('EDSELM') C CALL EDDEPR C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'PRIN')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSELM') WRITE(ICOUT,9011) CALL EDWRST('EDSELM') 9011 FORMAT('***** AT THE END OF EDSELM--') WRITE(ICOUT,9012)ILMARG CALL EDWRST('EDSELM') 9012 FORMAT('ILMARG = ',I8) WRITE(ICOUT,9013)NCOUT,ILOUT CALL EDWRST('EDSELM') 9013 FORMAT('NCOUT,ILOUT = ',2I8) IF(NCOUT.LE.0)GOTO9019 DO9015I=1,NCOUT WRITE(ICOUT,9016)I,ICOUT(I:I) CALL EDWRST('EDSELM') 9016 FORMAT('I,ICOUT(I:I) = ',I8,2X,A1) 9015 CONTINUE 9019 CONTINUE C 9090 CONTINUE C RETURN END SUBROUTINE EDSERA C C PURPOSE--SET THE VARIABLE WHICH DEFINES C THE STRING WHICH WILL ERASE THE TERMINAL SCREEN C IF NO ARGUMENTS, THEN SET ICERAS TO DEFAULT (= ' ') C IF 1 ARGUMENT , THEN SET ICERAS TO IHARG1 C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSE' ISUBN2='RA ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SERA')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSERA') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSERA') 51 FORMAT('*****AT THE BEGINNING OF EDSERA--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************* C ** STEP 11-- ** C ** SET THE ERASE STRING ** C ************************************* C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SERA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMARG.LE.0)GOTO1100 GOTO1110 C 1100 CONTINUE ICERAS=' ' GOTO1190 C 1110 CONTINUE ICERAS=IHARG(1) GOTO1190 C 1190 CONTINUE C C *************************** C ** STEP 2-- ** C ** WRITE OUT A MESSAGE ** C ** (IF CALLED FOR) ** C *************************** C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SERA') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IFEESW.EQ.'OFF')GOTO1219 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1211)ICERAS CALL EDWRST('EDSERA') ENDIF 1211 FORMAT('ERASE STRING = ',A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1212)ICERAS CALL EDWRST('EDSERA') ENDIF 1212 FORMAT(10X,'ERASE STRING = ',A1) 1219 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SERA')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSERA') WRITE(ICOUT,9011) CALL EDWRST('EDSERA') 9011 FORMAT('*****AT THE END OF EDSERA--') WRITE(ICOUT,9012)ICERAS CALL EDWRST('EDSERA') 9012 FORMAT('ICERAS = ',A1) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSET(IMARK,ICOLL1,ICOLL2,ISHIFN,IPPLIN,IPPOFF,IERASW, 1ISEQNU,ILPOFF) C C PURPOSE--SET SYSTEM SWITCHES AND VARIABLES. C C DATE--JANUARY 24,1985 C C------------------------------------------------------------------------------- C CHARACTER*4 IERASW C CHARACTER*4 IHARGI CHARACTER*1 ICHAR1 CHARACTER*4 IHIT CHARACTER*8 IHTEM8 CHARACTER*20 IHTE20 C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDSE' ISUBN2='T ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SET')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSET ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSET ') 51 FORMAT('*****AT THE BEGINNING OF EDSET--') WRITE(ICOUT,53)ILPOFF CALL EDWRST('EDSET ') 53 FORMAT('ILPOFF = ',I8) WRITE(ICOUT,61)NUMARG,IHARG(1),IHARG(2) CALL EDWRST('EDSET ') 61 FORMAT('NUMARG,IHARG(1),IHARG(2) = ',I8,2X,A4,2X,A4) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C CCCCC IF(NUMARG.LE.1)IERROR='YES' CCCCC IF(NUMARG.LE.1)GOTO1000 CCCCC IF(NUMARG.LE.1)GOTO1000 C IF(IHARG(1).EQ.'IBUG')GOTO1100 IF(IHARG(1).EQ.'ISUB')GOTO2100 C IF(IHARG(1).EQ.'BEGI')GOTO3100 IF(IHARG(1).EQ.'END')GOTO3200 IF(IHARG(1).EQ.'COPY')GOTO3300 IF(IHARG(1).EQ.'MARK')GOTO3400 C IF(IHARG(1).EQ.'CHAN')GOTO4110 IF(IHARG(1).EQ.'FIND')GOTO4120 IF(IHARG(1).EQ.'LOCA')GOTO4130 IF(IHARG(1).EQ.'MARG')GOTO4140 IF(IHARG(1).EQ.'PRIN'.AND.IHARG2(1).EQ.'T ')GOTO4150 IF(IHARG(1).EQ.'PAGE')GOTO4160 C IF(IHARG(1).EQ.'SCRE'.AND.IHARG(2).EQ.'ROWS')GOTO4310 IF(IHARG(1).EQ.'SCRE'.AND.IHARG(2).EQ.'ROW')GOTO4310 IF(IHARG(1).EQ.'SCRE'.AND.IHARG(2).EQ.'COLU')GOTO4320 IF(IHARG(1).EQ.'SCRE'.AND.IHARG(2).EQ.'COL')GOTO4320 C IF(IHARG(1).EQ.'PRIN'.AND.IHARG(2).EQ.'ROWS')GOTO4410 IF(IHARG(1).EQ.'PRIN'.AND.IHARG(2).EQ.'ROW')GOTO4410 IF(IHARG(1).EQ.'PRIN'.AND.IHARG(2).EQ.'COLU')GOTO4420 IF(IHARG(1).EQ.'PRIN'.AND.IHARG(2).EQ.'COL')GOTO4420 C CCCCC THE FOLLOWING LINE WAS ADDED MAY 1993 IF(IHARG(1).EQ.'LOOP'.AND.IHARG(2).EQ.'COUN')GOTO4510 C IF(IHARG(1).EQ.'INDE')GOTO5110 IF(IHARG(1).EQ.'CENT')GOTO5120 IF(IHARG(1).EQ.'TRUN')GOTO5130 IF(IHARG(1).EQ.'TAB')GOTO5140 IF(IHARG(1).EQ.'NEAT')GOTO5150 IF(IHARG(1).EQ.'JUST')GOTO5160 IF(IHARG(1).EQ.'SHIF')GOTO5170 IF(IHARG(1).EQ.'PP'.AND.IHARG(2).EQ.'OFFS')GOTO5180 IF(IHARG(1).EQ.'PP')GOTO5190 IF(IHARG(1).EQ.'ERAS')GOTO5200 IF(IHARG(1).EQ.'SEQU')GOTO5210 IF(IHARG(1).EQ.'LP'.AND.IHARG(2).EQ.'OFFS')GOTO5220 C IF(IHARG(1).EQ.'FEED')GOTO6110 IF(IHARG(1).EQ.'NUMB')GOTO6120 IF(IHARG(1).EQ.'PRIN'.AND.IHARG2(1).EQ.'TER ')GOTO6130 IF(IHARG(1).EQ.'PROM')GOTO6140 IF(IHARG(1).EQ.'TRAC')GOTO6150 IF(IHARG(1).EQ.'ECHO')GOTO6160 C IF(IHARG(1).EQ.'MASK')GOTO6510 CCCCC IF(IHARG(1).EQ.'JUST')GOTO6520 IF(IHARG(1).EQ.'HORI')GOTO6530 IF(IHARG(1).EQ.'VERT')GOTO6540 IF(IHARG(1).EQ.'TRAN')GOTO6550 C IF(IHARG(1).EQ.'COMM')GOTO7100 C GOTO9000 C C ************************* C ** STEP 11-- ** C ** SET BUG VARIABLES ** C ************************* C 1000 CONTINUE WRITE(ICOUT,1011) CALL EDWRST('EDSET ') 1011 FORMAT(10X,'[AVAILABLE SETTINGS UNDER') WRITE(ICOUT,1012) CALL EDWRST('EDSET ') 1012 FORMAT(10X,' THE SET COMMAND-') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1021) CALL EDWRST('EDSET ') 1021 FORMAT(10X,' COPY (LIMITS)') WRITE(ICOUT,1022) CALL EDWRST('EDSET ') 1022 FORMAT(10X,' CHANGE (LIMITS)') WRITE(ICOUT,1023) CALL EDWRST('EDSET ') 1023 FORMAT(10X,' FIND (LIMITS)') WRITE(ICOUT,1024) CALL EDWRST('EDSET ') 1024 FORMAT(10X,' LOCATE (LIMITS)') WRITE(ICOUT,1025) CALL EDWRST('EDSET ') 1025 FORMAT(10X,' MARGIN (LIMITS)') WRITE(ICOUT,1026) CALL EDWRST('EDSET ') 1026 FORMAT(10X,' PAGE (LIMITS)') WRITE(ICOUT,1027) CALL EDWRST('EDSET ') 1027 FORMAT(10X,' PRINT (LIMITS)') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1031) CALL EDWRST('EDSET ') 1031 FORMAT(10X,' SCREEN ROWS') WRITE(ICOUT,1032) CALL EDWRST('EDSET ') 1032 FORMAT(10X,' SCREEN COLUMNS') WRITE(ICOUT,1033) CALL EDWRST('EDSET ') 1033 FORMAT(10X,' PRINTER ROWS') WRITE(ICOUT,1034) CALL EDWRST('EDSET ') 1034 FORMAT(10X,' PRINTER COLUMNS') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1041) CALL EDWRST('EDSET ') 1041 FORMAT(10X,' INDENTING (COLUMN)') WRITE(ICOUT,1042) CALL EDWRST('EDSET ') 1042 FORMAT(10X,' CENTERING (COLUMN)') WRITE(ICOUT,1043) CALL EDWRST('EDSET ') 1043 FORMAT(10X,' TRUNCATING (COLUMN)') WRITE(ICOUT,1044) CALL EDWRST('EDSET ') 1044 FORMAT(10X,' TABBING (COLUMN)') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1051) CALL EDWRST('EDSET ') 1051 FORMAT(10X,' FEEDBACK (SWITCH)') WRITE(ICOUT,1052) CALL EDWRST('EDSET ') 1052 FORMAT(10X,' (LINE) NUMBER (PRINTING) (SWITCH)') WRITE(ICOUT,1053) CALL EDWRST('EDSET ') 1053 FORMAT(10X,' PRINTER (SWITCH)') WRITE(ICOUT,1054) CALL EDWRST('EDSET ') 1054 FORMAT(10X,' PROMPT (PRINTING) (SWITCH)') WRITE(ICOUT,1055) CALL EDWRST('EDSET ') 1055 FORMAT(10X,' TRACE (SWITCH)') WRITE(ICOUT,1056) CALL EDWRST('EDSET ') 1056 FORMAT(10X,' ECHO (SWITCH)') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1061) CALL EDWRST('EDSET ') 1061 FORMAT(10X,' MASK (CHARACTER)') WRITE(ICOUT,1062) CALL EDWRST('EDSET ') 1062 FORMAT(10X,' JUSTIFICATION ') WRITE(ICOUT,1063) CALL EDWRST('EDSET ') 1063 FORMAT(10X,' HORIZONTAL SPACING ') WRITE(ICOUT,1064) CALL EDWRST('EDSET ') 1064 FORMAT(10X,' VERTICAL SPACING ') WRITE(ICOUT,1065) CALL EDWRST('EDSET ') 1065 FORMAT(10X,' TRANSLATION (TYPE) ') WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,1071) CALL EDWRST('EDSET ') 1071 FORMAT(10X,' (USER-DEFINED) COMMANDS') GOTO9000 1100 CONTINUE C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SET') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IHARG2(1).EQ.'ED')GOTO1110 IF(IHARG2(1).EQ.'E2')GOTO1120 IF(IHARG2(1).EQ.'E3')GOTO1130 IF(IHARG2(1).EQ.'TY')GOTO1140 IF(IHARG2(1).EQ.'FI')GOTO1150 IF(IHARG2(1).EQ.'T1')GOTO1160 IF(IHARG2(1).EQ.'T2')GOTO1170 IF(IHARG2(1).EQ.'WR')GOTO1180 IF(IHARG2(1).EQ.'MA')GOTO1190 IERROR='YES' GOTO9000 C 1110 CONTINUE IBUGED=IHARG(2) GOTO1900 C 1120 CONTINUE IBUGE2=IHARG(2) GOTO1900 C 1130 CONTINUE IBUGE3=IHARG(2) GOTO1900 C 1140 CONTINUE IBUGTY=IHARG(2) GOTO1900 C 1150 CONTINUE IBUGFI=IHARG(2) GOTO1900 C 1160 CONTINUE IBUGT1=IHARG(2) GOTO1900 C 1170 CONTINUE IBUGT2=IHARG(2) GOTO1900 C 1180 CONTINUE IBUGWR=IHARG(2) GOTO1900 C 1190 CONTINUE IBUGMA=IHARG(2) GOTO1900 C 1900 CONTINUE GOTO9000 C C ******************************** C ** STEP 21-- ** C ** SET SUBROUTINE VARIABLES ** C ******************************** C 2100 CONTINUE C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SET') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISUBRO=IHARG(2) GOTO9000 C C ******************************** C ** STEP 31-- ** C ** SET OTHER VARIABLES ** C ******************************** C 3100 CONTINUE IBLIM1=ICURLN IF(NUMARG.GE.2)IBLIM1=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,3111)IBLIM1 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 3111 FORMAT(10X,'[BEGINNING LINE NUMBER FOR COPY = ',I8,']') GOTO9000 C 3200 CONTINUE IBLIM2=ICURLN IF(NUMARG.GE.2)IBLIM2=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,3211)IBLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 3211 FORMAT(10X,'[END LINE NUMBER FOR COPY = ',I8,']') GOTO9000 C 3300 CONTINUE IBLIM1=ICURLN IBLIM2=ICURLN IF(NUMARG.GE.2)IBLIM1=IARG(2) IF(NUMARG.GE.3)IBLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,3311)IBLIM1,IBLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 3311 FORMAT(10X,'[LINE LIMITS FOR COPY COMMAND = ',2I8,']') GOTO9000 C 3400 CONTINUE IMARK=ICURLN IF(NUMARG.GE.2)IMARK=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,3411)IMARK IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 3411 FORMAT(10X,'[MARK SET AT LINE ',I8,']') GOTO9000 C 4110 CONTINUE IF(NUMARG.LE.1)ICLIM1=1 IF(NUMARG.LE.1)ICLIM2=240 IF(NUMARG.EQ.2)ICLIM1=IARG(2) IF(NUMARG.EQ.2)ICLIM2=240 IF(NUMARG.GE.3)ICLIM1=IARG(2) IF(NUMARG.GE.3)ICLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4111)ICLIM1,ICLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4111 FORMAT(10X,'[COLUMN LIMITS FOR CHANGE COMMAND = ',2I8,']') GOTO9000 C 4120 CONTINUE IFLIM1=IARG(2) IFLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4121)IFLIM1,IFLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4121 FORMAT(10X,'[COLUMN LIMITS FOR FIND COMMAND = ',2I8,']') GOTO9000 C 4130 CONTINUE ILLIM1=IARG(2) ILLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4131)ILLIM1,ILLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4131 FORMAT(10X,'[COLUMN LIMITS FOR LOCATE COMMAND = ',2I8,']') GOTO9000 C 4140 CONTINUE IMLIM1=IARG(2) IMLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4141)IMLIM1,IMLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4141 FORMAT(10X,'[COLUMN LIMITS FOR MARGIN COMMAND = ',2I8,']') GOTO9000 C 4150 CONTINUE IPLIM1=IARG(2) IPLIM2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4151)IPLIM1,IPLIM2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4151 FORMAT(10X,'[COLUMN LIMITS FOR PRINT COMMAND = ',2I8,']') GOTO9000 C 4160 CONTINUE IP2LI1=IARG(2) IP2LI2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4161)IP2LI1,IP2LI2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4161 FORMAT(10X,'[COLUMN LIMITS FOR PAGE COMMAND = ',2I8,']') GOTO9000 C 4310 CONTINUE ISCRO1=IARG(3) ISCRO2=IARG(4) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4311)ISCRO1,ISCRO2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4311 FORMAT(10X,'[SCREEN ROW LIMITS = ',2I8,']') GOTO9000 C 4320 CONTINUE ISCCO1=IARG(3) ISCCO2=IARG(4) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4321)ISCCO1,ISCCO2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4321 FORMAT(10X,'[SCREEN COLUMN LIMITS = ',2I8,']') GOTO9000 C 4410 CONTINUE IPRRO1=IARG(3) IPRRO2=IARG(4) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4411)IPRRO1,IPRRO2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4411 FORMAT(10X,'[(PRINT) ROW LIMITS = ',2I8,']') GOTO9000 C 4420 CONTINUE IPRCO1=IARG(3) IPRCO2=IARG(4) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4421)IPRCO1,IPRCO2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4421 FORMAT(10X,'[PRINTER COLUMN LIMITS = ',2I8,']') GOTO9000 C CCCCC THE FOLLOWING SECTION WAS ADDED MAY 1993 4510 CONTINUE LOOPCT=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,4511)LOOPCT IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 4511 FORMAT(10X,'[THE LOOP COUNTER HAS JUST BEEN SET TO ',I8,']') GOTO9000 C 5110 CONTINUE IINDEC=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5111)IINDEC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5111 FORMAT(10X,'[COLUMN FOR INDENT COMMAND = ',I8,']') GOTO9000 C 5120 CONTINUE ICENTC=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5121)ICENTC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5121 FORMAT(10X,'[COLUMN FOR CENTER COMMAND = ',I8,']') GOTO9000 C 5130 CONTINUE ITRUNC=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5131)ITRUNC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5131 FORMAT(10X,'[COLUMN FOR TRUNCATE COMMAND = ',I8,']') GOTO9000 C 5140 CONTINUE ITABC=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5141)ITABC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5141 FORMAT(10X,'[COLUMN FOR AUTO-TABBING = ',I8,']') GOTO9000 C 5150 CONTINUE IF(NUMARG.LE.1)ICOLL1=1 IF(NUMARG.LE.1)ICOLL2=50 IF(NUMARG.EQ.2)ICOLL1=1 IF(NUMARG.EQ.2)ICOLL2=IARG(2) IF(NUMARG.GE.3)ICOLL1=IARG(2) IF(NUMARG.GE.3)ICOLL2=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5151)ICOLL1,ICOLL2 IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5151 FORMAT(10X,'[COLUMNS FOR NEAT COMMAND = ',I8,I8,']') GOTO9000 C 5160 CONTINUE IF(NUMARG.LE.1)IJUST='LEFT' IF(NUMARG.GE.2)IJUST=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5161)IJUST IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5161 FORMAT(10X,'[SWITCH FOR SPACING (LEFT/BOTH) = ',A4,']') GOTO9000 C 5170 CONTINUE ISHIFN=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5171)ISHIFN IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5171 FORMAT(10X,'[NUMBER OF COLUMNS FOR SHIFT COMMAND = ',I8,']') GOTO9000 C 5180 CONTINUE IF(NUMARG.LE.1)IPPOFF=0 IF(NUMARG.EQ.2)IPPOFF=IARG(2) IF(NUMARG.GE.3)IPPOFF=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5181)IPPOFF IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5181 FORMAT(10X,'[OFFSET FOR PP COMMAND = ',I8,']') GOTO9000 C 5190 CONTINUE IF(NUMARG.LE.1)IPPLIN=50 IF(NUMARG.EQ.2)IPPLIN=IARG(2) IF(NUMARG.GE.3)IPPLIN=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5191)IPPLIN IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5191 FORMAT(10X,'[LINES FOR PP COMMAND = ',I8,']') GOTO9000 C 5200 CONTINUE IERASW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5201)IERASW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5201 FORMAT(10X,'[PRE-ERASE SWITCH FOR PP COMMAND = ',A4,']') GOTO9000 C 5210 CONTINUE ISEQNU=IARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5211)ISEQNU IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5211 FORMAT(10X,'[SEQUENCE NUMBER FOR LS COMMAND = ',I8,']') GOTO9000 C 5220 CONTINUE IF(NUMARG.LE.1)ILPOFF=0 IF(NUMARG.EQ.2)ILPOFF=IARG(2) IF(NUMARG.GE.3)ILPOFF=IARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,5221)ILPOFF IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 5221 FORMAT(10X,'[OFFSET FOR LP COMMAND = ',I8,']') GOTO9000 C 6110 CONTINUE IF(NUMARG.LE.1)IFEESW='ON' IF(NUMARG.GE.2)IFEESW=IHARG(2) CCCCC IF(IFEESW.EQ.'ON')WRITE(ICOUT,6111)IFEESW CCCCC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') C6111 FORMAT(10X,'[SWITCH FOR PRINTING FEEDBACK = ',A4,']') GOTO9000 C 6120 CONTINUE IF(NUMARG.LE.1)INUMSW='ON' IF(NUMARG.GE.2)INUMSW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6121)INUMSW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6121 FORMAT(10X,'[SWITCH FOR PRINTING LINE NUMBERS = ',A4,']') GOTO9000 C 6130 CONTINUE IF(NUMARG.LE.1)IPRISW='OFF' IF(NUMARG.GE.2)IPRISW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6131)IPRISW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6131 FORMAT(10X,'[SWITCH FOR PRINTER ON/OFF = ',A4,']') GOTO9000 C 6140 CONTINUE IF(NUMARG.LE.1)IPROSW='ON' IF(NUMARG.GE.2)IPROSW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6141)IPROSW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6141 FORMAT(10X,'[SWITCH FOR PRINTING PROMPT = ',A4,']') GOTO9000 C 6150 CONTINUE IF(NUMARG.LE.1)ITRASW='OFF' IF(NUMARG.GE.2)ITRASW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6151)ITRASW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6151 FORMAT(10X,'[SWITCH FOR TRACING = ',A4,']') GOTO9000 C 6160 CONTINUE IF(NUMARG.LE.1)IECHSW='OFF' IF(NUMARG.GE.2)IECHSW=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6161)IECHSW IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6161 FORMAT(10X,'[SWITCH FOR ECHOING COMMANDS = ',A4,']') GOTO9000 C 6510 CONTINUE IF(NUMARG.LE.1)IMASK=':' IF(NUMARG.GE.2)IMASK=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6511)IMASK IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6511 FORMAT(10X,'[MASK CHARACTER = ',A4,']') GOTO9000 C C6520 CONTINUE CCCCC IF(NUMARG.LE.1)IJUST='LEFT' CCCCC IF(NUMARG.GE.2)IJUST=IHARG(2) CCCCC IF(IFEESW.EQ.'ON')WRITE(ICOUT,6521)IJUST CCCCC IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') C6521 FORMAT(10X,'[JUSTIFICATION = ',A4,']') CCCCC GOTO9000 C 6530 CONTINUE IF(NUMARG.LE.2)ISPACH='EQUA' IF(NUMARG.GE.3)ISPACH=IHARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6531)ISPACH IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6531 FORMAT(10X,'[HORIZONTAL SPACING = ',A4,']') GOTO9000 C 6540 CONTINUE IF(NUMARG.LE.2)ISPACV='SING' IF(NUMARG.GE.3)ISPACV=IHARG(3) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6541)ISPACV IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6541 FORMAT(10X,'[VERTICAL SPACING = ',A4,']') GOTO9000 C 6550 CONTINUE IF(NUMARG.LE.1)ITRANS='NEAT' IF(NUMARG.GE.2)ITRANS=IHARG(2) IF(IFEESW.EQ.'ON')WRITE(ICOUT,6551)ITRANS IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 6551 FORMAT(10X,'[TRANSLATION TYPE = ',A4,']') GOTO9000 C 7100 CONTINUE IF(NUMCOM.LE.0)GOTO7118 DO7110I=1,NUMCOM IHTEM8=ICOM3(I) IF(IHARG(2).EQ.IHTEM8(1:4).AND.IHARG2(2).EQ.IHTEM8(5:8))GOTO7115 GOTO7110 7115 CONTINUE I2=I GOTO7119 7110 CONTINUE 7118 CONTINUE I2=NUMCOM+1 IHTEM8(1:4)=IHARG(2) IHTEM8(5:8)=IHARG2(2) ICOM3(I2)=IHTEM8 NUMCOM=I2 GOTO7119 7119 CONTINUE C IF(I2.LE.MAXCMN)GOTO7129 WRITE(ICOUT,7121) CALL EDWRST('EDSET ') 7121 FORMAT('***** ERROR IN EDSET--') WRITE(ICOUT,7122) CALL EDWRST('EDSET ') 7122 FORMAT(' TOO MANY USER-DEFINED COMMANDS.') WRITE(ICOUT,7123)I2 CALL EDWRST('EDSET ') 7123 FORMAT(' NUMBER OF COMMANDS = ',I8) WRITE(ICOUT,7124)MAXCMN CALL EDWRST('EDSET ') 7124 FORMAT(' MAXIMUM NUMBER OF COMMANDS = ',I8) IERROR='YES' GOTO9000 7129 CONTINUE C IHTE20=' ' J=0 IF(NUMARG.LE.2)GOTO7135 DO7130I=3,NUMARG IHARGI=IHARG(I) CALL EDTRNP(IHARGI,ICHAR1,IHIT) J=J+1 IF(IHIT.EQ.'YES')IHTE20(J:J)=ICHAR1 IF(IHIT.EQ.'NO')IHTE20(J:J)=IHARGI(1:1) 7130 CONTINUE 7135 CONTINUE ICOM4(I2)=IHTE20 NCCOM4(I2)=J 7139 CONTINUE C IF(I2.LE.0)GOTO7149 IF(NUMCOM.LE.0.OR.NUMCOM.GT.MAXCMN)GOTO7149 IF(IFEESW.EQ.'ON')WRITE(ICOUT,7141)ICOM3(I2),ICOM4(I2) IF(IFEESW.EQ.'ON')CALL EDWRST('EDSET ') 7141 FORMAT(10X,'[COMMAND ',A8,' = ',A20,' ]') 7149 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SET')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSET ') WRITE(ICOUT,9011) CALL EDWRST('EDSET ') 9011 FORMAT('*****AT THE END OF EDSET--') WRITE(ICOUT,9012)ICURLN CALL EDWRST('EDSET ') 9012 FORMAT('ICURLN = ',I8) WRITE(ICOUT,9013)ICLIM1,ICLIM2 CALL EDWRST('EDSET ') 9013 FORMAT('ICLIM1,ICLIM2 = ',2I8) WRITE(ICOUT,9014)I2,NUMCOM,MAXCMN CALL EDWRST('EDSET ') 9014 FORMAT('I2,NUMCOM,MAXCMN = ',3I8) WRITE(ICOUT,9015)IHARGI,ICHAR1,IHIT CALL EDWRST('EDSET ') 9015 FORMAT('IHARGI,ICHAR1,IHIT = ',A4,2X,A1,2X,A4) WRITE(ICOUT,9018)ITRANS CALL EDWRST('EDSET ') 9018 FORMAT('ITRANS = ',A4) WRITE(ICOUT,9019)ILPOFF CALL EDWRST('EDSET ') 9019 FORMAT('ILPOFF = ',I8) WRITE(ICOUT,9021)IFEESW,LOOPCT CALL EDWRST('EDSET ') 9021 FORMAT('IFEESW,LOOPCT = ',A4,I8) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSEUC C C PURPOSE--SEARCH FOR USER-DEFINE COMMANDS C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JUNE 1986. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*240 ICTEMP C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSE' ISUBN2='UC ' C IFOUND='NO' IERROR='NO' C CCCCC IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SEUC')GOTO90 IF(ISUBRO.NE.'SEUC')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSEUC') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSEUC') 51 FORMAT('***** AT THE BEGINNING OF EDSEUC--') WRITE(ICOUT,54)ICOM,ICOM2,NUMCOM CALL EDWRST('EDSEUC') 54 FORMAT('ICOM,ICOM2,NUMCOM = ',A4,2X,A4,I8) IF(NUMCOM.LE.0)GOTO69 DO60I=1,NUMCOM WRITE(ICOUT,999) CALL EDWRST('EDSEUC') WRITE(ICOUT,61)ICOM3(I),ICOM4(I),NCOM5(I) CALL EDWRST('EDSEUC') 61 FORMAT('ICOM3(I),ICOM4(I),NCOM5(I) = ',A4,2X,A4,I8) WRITE(ICOUT,62)ICOM5(I) CALL EDWRST('EDSEUC') 62 FORMAT('ICOM5(I) = ',A30) 60 CONTINUE 69 CONTINUE WRITE(ICOUT,72)IBUGE2,ISUBRO,IFOUND,IERROR CALL EDWRST('EDSEUC') 72 FORMAT('IBUGE2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,73)IPRISW,IPRINU CALL EDWRST('EDSEUC') 73 FORMAT('IPRISW,IPRINU = ',A4,I8) 90 CONTINUE C C ********************************************** C ** SEARCH FOR USER-DEFINED COMMANDS * C ********************************************** C NCTEMP=(-999) IF(NUMCOM.LE.0)GOTO9000 C DO1110I=1,NUMCOM I2=I IF(ICOM.EQ.ICOM3(I).AND.ICOM2.EQ.ICOM4(I))GOTO1119 1110 CONTINUE GOTO9000 1119 CONTINUE C C *********************************************** C ** STEP 21-- ** C ** COPY OVER THE PRINTER "FILE" VARIABLES) ** C ** (IF CALLED FOR) ** C *********************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SEUC') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2190 C IOUNIT=IPRINU IFILE=IPRINA ISTAT=IPRIST IFORM=IPRIFO IACCES=IPRIAC IREWR=IPRIRW ISUBN0='SEUC' IERRFI='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SEUC')GOTO2189 WRITE(ICOUT,999) CALL EDWRST('EDSEUC') WRITE(ICOUT,2181) CALL EDWRST('EDSEUC') 2181 FORMAT('***** FROM THE MIDDLE OF EDSEUC--') WRITE(ICOUT,2183)IFILE CALL EDWRST('EDSEUC') 2183 FORMAT('IFILE = ',A80) WRITE(ICOUT,2184)IOUNIT CALL EDWRST('EDSEUC') 2184 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,2185)ISTAT CALL EDWRST('EDSEUC') 2185 FORMAT('ISTAT = ',A12) 2189 CONTINUE C 2190 CONTINUE C C ************************* C ** STEP 22-- ** C ** OPEN THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SEUC') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO2290 C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED', CCCCC1ERR=2280) CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) IF(IERRFI.EQ.'YES')GOTO2280 GOTO2290 C 2280 CONTINUE WRITE(ICOUT,2281) CALL EDWRST('EDSEUC') 2281 FORMAT('***** ERROR IN EDSEUC--') WRITE(ICOUT,2282) CALL EDWRST('EDSEUC') 2282 FORMAT(' FAILED IN ATTEMPTING TO OPEN THE PRINTER') IERROR='YES' GOTO9000 C 2290 CONTINUE C C ********************************************** C ** STEP 31-- ** C ** WRITE OUT THE USER-DEFINED COMMAND ** C ********************************************** C NCTEMP=NCOM5(I2) IF(NCTEMP.LE.0)GOTO3129 ICTEMP(001:025)=' ' ICTEMP(026:050)=' ' ICTEMP(051:075)=' ' ICTEMP(076:100)=' ' ICTEMP(101:125)=' ' ICTEMP(126:240)=' ' ICTEMP(1:30)=ICOM5(I2) CCCCC IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SEUC') IF(ISUBRO.EQ.'SEUC')THEN WRITE(ICOUT,3121)I2,NCTEMP,ICTEMP(1:30) CALL EDWRST('EDSEUC') ENDIF 3121 FORMAT('I2,NCTEMP,ICTEMP(1:30) = ',2I8,2X,A30) IMAX=NCTEMP IF(IMAX.GT.238)IMAX=238 WRITE(ICOUT,3122)(ICTEMP(I:I),I=1,IMAX) CALL EDWRST('EDSEUC') 3122 FORMAT(238A1) IF(IPRISW.EQ.'ON')THEN WRITE(IOUNIT,3123)(ICTEMP(I:I),I=1,IMAX) CALL EDWRST('EDSEUC') 3123 FORMAT(238A1) ENDIF 3129 CONTINUE C IFOUND='YES' IERROR='NO' C C ************************* C ** STEP 41-- ** C ** CLOSE THE PRINTER ** C ** (IF CALLED FOR) ** C ************************* C ISTEPN='41' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SEUC') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IPRISW.EQ.'OFF')GOTO4190 C CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='OFF' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C 4190 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE CCCCC IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SEUC')GOTO9090 IF(ISUBRO.NE.'SEUC')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSEUC') WRITE(ICOUT,9011) CALL EDWRST('EDSEUC') 9011 FORMAT('***** AT THE END OF EDSEUC--') WRITE(ICOUT,9014)ICOM,ICOM2,NUMCOM CALL EDWRST('EDSEUC') 9014 FORMAT('ICOM,ICOM2,NUMCOM = ',A4,2X,A4,I8) IF(NUMCOM.LE.0)GOTO9029 DO9020I=1,NUMCOM WRITE(ICOUT,999) CALL EDWRST('EDSEUC') WRITE(ICOUT,9021)ICOM3(I),ICOM4(I),NCOM5(I) CALL EDWRST('EDSEUC') 9021 FORMAT('ICOM3(I),ICOM4(I),NCOM5(I) = ',A4,2X,A4,I8) WRITE(ICOUT,9022)ICOM5(I) CALL EDWRST('EDSEUC') 9022 FORMAT('ICOM5(I) = ',A30) 9020 CONTINUE 9029 CONTINUE WRITE(ICOUT,9031)I2,NCTEMP,ICTEMP(1:30) CALL EDWRST('EDSEUC') 9031 FORMAT('I2,NCTEMP,ICTEMP(1:30) = ',2I8,2X,A30) WRITE(ICOUT,9032)IMAX CALL EDWRST('EDSEUC') 9032 FORMAT('IMAX = ',I8) WRITE(ICOUT,9042)IBUGE2,ISUBRO,IFOUND,IERROR CALL EDWRST('EDSEUC') 9042 FORMAT('IBUGE2,ISUBRO,IFOUND,IERROR = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,9043)IPRISW,IPRINU,IOUNIT CALL EDWRST('EDSEUC') 9043 FORMAT('IPRISW,IPRINU,IOUNIT = ',A4,2I8) 9090 CONTINUE C RETURN END SUBROUTINE EDSHIF(ISHIFN) C C PURPOSE--SHIFT CURRENT LINE C (AND NEXT IARG1-1 LINES) C (OR SHIFT LINES IARG1 THROUGH IARG2) C COMMAND SYNTAX--SHIFT C SHIFT C SHIFT C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(240) DIMENSION INEWLI(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSH' ISUBN2='IF ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SHIF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSHIF') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSHIF') 51 FORMAT('***** AT THE BEGINNING OF EDSHIF--') WRITE(ICOUT,52)ISHIFN CALL EDWRST('EDSHIF') 52 FORMAT('ISHIFN = ',I8) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE SHIFTED . ** C ************************************ C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ICURLN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ICURLN GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) ISTART=ICURLN ISTOP=ISTART+IARG1-1 GOTO1190 C 1120 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) IARG2=NUMLIN+1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) ISTART=IARG1 ISTOP=IARG2 GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ******************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES TO BE SHIFTED ** C ******************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART-1 2100 CONTINUE ILINE=ILINE+1 IF(ILINE.LE.ISTOP)GOTO2910 ILINE=ISTOP GOTO2900 2910 CONTINUE ICURLN=ILINE IF(ILINE.LT.1)GOTO2100 IF(ILINE.GT.NUMLIN)GOTO2900 C C ***************************** C ** STEP 22-- ** C ** COPY THE OLD LINE ** C ***************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 DO2200J=J1,J2 I=I+1 IOLDLI(I)=ICHA(J) 2200 CONTINUE NUMCOL=I C C *********************************** C ** STEP 23-- ** C ** APPLY THE DESIRED SHIFTING ** C ** TO THE TARGET LINE, ** C ** SO AS TO CREATE ** C ** A NEW LINE. ** C *********************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDSHI2(ISHIFN,IOLDLI,NUMCOL,INEWLI,NUMCNL) C C *************************************** C ** STEP 24-- ** C ** DETERMINE IF ROOM EXISTS IN THE ** C ** MAIN INTERNAL CHARACTER ARRAY ** C ** FOR THE NEW SHIFTED LINE. ** C *************************************** C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH9=NUMCHA+NUMCNL CALL EDCHSI(NUMCH9) IF(IERROR.EQ.'YES')GOTO9000 C 2450 CONTINUE IF(ILINE.LT.1)GOTO2460 IF(ILINE.GT.NUMLIN)GOTO2470 GOTO2490 C 2460 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2461) CALL EDWRST('EDSHIF') ENDIF 2461 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2462) CALL EDWRST('EDSHIF') ENDIF 2462 FORMAT(10X,'[TOP]') 2469 CONTINUE GOTO2100 C 2470 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2471) CALL EDWRST('EDSHIF') ENDIF 2471 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2472) CALL EDWRST('EDSHIF') ENDIF 2472 FORMAT(10X,'[BOTTOM]') 2479 CONTINUE GOTO9000 C 2490 CONTINUE C C *************************************** C ** STEP 25-- ** C ** UPDATE THE MAIN CHARACTER ARRAY ** C ** WITH THE NEW LINE. ** C *************************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SHIF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J1=NUMCHA+1 N1=NUMCNL J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ILINE)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2500J=J1,J2 I=I+1 ICHA(J)=INEWLI(I) 2500 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 C IF(IFEESW.EQ.'OFF')GOTO2629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2621)(ICHA(J),J=J1,J2) CALL EDWRST('EDSHIF') ENDIF 2621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2622)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDSHIF') ENDIF 2622 FORMAT(I6,':',3X,230A1) 2629 CONTINUE C GOTO2100 C 2900 CONTINUE IF(ILINE.LE.NUMLIN)GOTO2919 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2911) CALL EDWRST('EDSHIF') ENDIF 2911 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2912) CALL EDWRST('EDSHIF') ENDIF 2912 FORMAT(10X,'[BOTTOM]') 2919 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SHIF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSHIF') WRITE(ICOUT,9011) CALL EDWRST('EDSHIF') 9011 FORMAT('***** AT THE END OF EDSHIF--') WRITE(ICOUT,999) CALL EDWRST('EDSHIF') WRITE(ICOUT,9012)ISHIFN CALL EDWRST('EDSHIF') 9012 FORMAT('ISHIFN = ',I8) WRITE(ICOUT,9013)IWIDTH CALL EDWRST('EDSHIF') 9013 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9014)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDSHIF') 9014 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDSHIF') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDSHIF') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDSHIF') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDSHIF') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)ICURLN,ISTART,ISTOP CALL EDWRST('EDSHIF') 9041 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9042)J1,N1,J2 CALL EDWRST('EDSHIF') 9042 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDSHIF') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSHI2(ISHIFN,IOLDLI,NUMCOL,INEWLI,NUMCNL) C C PURPOSE--SHIFT THE LINE IN IOLDLI(.) OVER ISHIFN SPACES. C THE SHIFTED LINE WILL BE PLACED IN INEWLI(.). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(*) DIMENSION INEWLI(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDSH' ISUBN2='I2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SHI2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSHI2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSHI2') 51 FORMAT('***** AT THE BEGINNING OF EDSHI2--') WRITE(ICOUT,52)ISHIFN CALL EDWRST('EDSHI2') 52 FORMAT('ISHIFN = ',I8) WRITE(ICOUT,71)NUMCOL CALL EDWRST('EDSHI2') 71 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,72)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDSHI2') 72 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,73)NUMCNL CALL EDWRST('EDSHI2') 73 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,74)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDSHI2') 74 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,81)ISHIFN CALL EDWRST('EDSHI2') 81 FORMAT('ISHIFN = ',I8) 90 CONTINUE C C ************************************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST NON-BLANK CHARACTER IN IOLDLI(.) ** C ************************************************************ C I2=0 IF(NUMCOL.LE.0)GOTO1190 DO1100I=1,NUMCOL I2=I IF(IOLDLI(I2).NE.' ')GOTO1190 1100 CONTINUE I2=NUMCOL+1 1190 CONTINUE IFIRST=I2 C C ******************************** C ** STEP 2-- ** C ** BLANK OUT THE NEW STRING ** C ******************************** C NUMCNL=1 DO1500I=1,240 INEWLI(I)=' ' 1500 CONTINUE C C ************************************** C ** STEP 3-- ** C ** FORM THE NEW (SHIFTED) STRING ** C ************************************** C IF(ISHIFN.LE.0)GOTO2100 IF(ISHIFN.EQ.0)GOTO2200 GOTO2300 C 2100 CONTINUE INEW=ISHIFN IF(NUMCOL.LE.0)GOTO2190 DO2110IOLD=1,NUMCOL INEW=INEW+1 IF(INEW.LE.0)GOTO2110 INEWLI(INEW)=IOLDLI(IOLD) 2110 CONTINUE 2190 CONTINUE IF(INEW.LE.0)INEW=0 NUMCNL=INEW GOTO2900 C 2200 CONTINUE INEW=0 IF(NUMCOL.LE.0)GOTO2290 DO2210IOLD=1,NUMCOL INEW=INEW+1 INEWLI(INEW)=IOLDLI(IOLD) 2210 CONTINUE 2290 CONTINUE NUMCNL=INEW GOTO2900 C 2300 CONTINUE INEW=ISHIFN IF(NUMCOL.LE.0)GOTO2390 DO2310IOLD=1,NUMCOL INEW=INEW+1 IF(INEW.GT.240)GOTO2390 INEWLI(INEW)=IOLDLI(IOLD) 2310 CONTINUE 2390 CONTINUE IF(INEW.GT.240)INEW=240 NUMCNL=INEW GOTO2900 C 2900 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SHI2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSHI2') WRITE(ICOUT,9011) CALL EDWRST('EDSHI2') 9011 FORMAT('***** AT THE END OF EDSHI2--') WRITE(ICOUT,9012)ISHIFN CALL EDWRST('EDSHI2') 9012 FORMAT('ISHIFN = ',I8) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDSHI2') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDSHI2') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDSHI2') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDSHI2') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) 9090 CONTINUE C RETURN END SUBROUTINE EDSHLE(ISHIFT) C C PURPOSE--SHIFT TO THE LEFT (ONLY) C THE IHARG,IHARG2,IARG,ARG, AND IARGT VECTORS C AND ADJUST THE VALUE OF NUMARG ACCORDINGLY. C THE ADJUSTMENT RESULTS IN C ALL ELEMENTS BEING SHIFTED C ISHIFT STEPS TO THE LEFT. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IERROR='NO' C IF(IBUGMA.EQ.'OFF'.AND.ISUBRO.NE.'SHLE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSHLE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSHLE') 51 FORMAT('***** AT THE BEGINNING OF EDSHLE--') WRITE(ICOUT,52)ISHIFT,NUMARG CALL EDWRST('EDSHLE') 52 FORMAT('ISHIFT,NUMARG = ',2I8) DO55I=1,NUMARG WRITE(ICOUT,56)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) CALL EDWRST('EDSHLE') 56 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) 55 CONTINUE 90 CONTINUE C IMIN=1 IMAX=NUMARG-ISHIFT DO100I=IMIN,IMAX IPSHIF=I+ISHIFT IHARG(I)=IHARG(IPSHIF) IHARG2(I)=IHARG2(IPSHIF) IARG(I)=IARG(IPSHIF) ARG(I)=ARG(IPSHIF) IARGT(I)=IARGT(IPSHIF) 100 CONTINUE NUMARG=IMAX GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGMA.EQ.'OFF'.AND.ISUBRO.NE.'SHLE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSHLE') WRITE(ICOUT,9011) CALL EDWRST('EDSHLE') 9011 FORMAT('***** AT THE END OF EDSHLE--') WRITE(ICOUT,9012)ISHIFT,NUMARG CALL EDWRST('EDSHLE') 9012 FORMAT('ISHIFT,NUMARG = ',2I8) WRITE(ICOUT,9013)IMIN,IMAX CALL EDWRST('EDSHLE') 9013 FORMAT('IMIN,IMAX = ',2I8) DO9015I=1,NUMARG WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) CALL EDWRST('EDSHLE') 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I8,2X,A4,A4,I8,E15.7,2X,A4) 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE EDSHOW C C PURPOSE--SHOW SYSTEM SWITCHES AND VARIABLES. C C DATE--OCTOBER 24,1985 C C------------------------------------------------------------------------------- C C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDSH' ISUBN2='OW ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SHOW')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSHOW') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSHOW') 51 FORMAT('*****AT THE BEGINNING OF EDSHOW--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IF(NUMARG.LE.0)IERROR='YES' IF(NUMARG.LE.0)GOTO9000 C IF(IHARG(1).EQ.'IBUG')GOTO1100 IF(IHARG(1).EQ.'ISUB')GOTO2100 C IF(IHARG(1).EQ.'FILE')GOTO3000 C IF(IHARG(1).EQ.'BEGI')GOTO3100 IF(IHARG(1).EQ.'END')GOTO3200 IF(IHARG(1).EQ.'COPY')GOTO3300 C IF(IHARG(1).EQ.'CHAN')GOTO4100 IF(IHARG(1).EQ.'FIND')GOTO4200 IF(IHARG(1).EQ.'LOCA')GOTO4300 IF(IHARG(1).EQ.'MARG')GOTO4400 IF(IHARG(1).EQ.'PAGE')GOTO4500 IF(IHARG(1).EQ.'PRIN'.AND.IHARG2(1).EQ.'T ')GOTO4600 IF(IHARG(1).EQ.'TAB')GOTO4700 C IF(IHARG(1).EQ.'INDE')GOTO5100 IF(IHARG(1).EQ.'CENT')GOTO5200 IF(IHARG(1).EQ.'TRUN')GOTO5300 C IF(IHARG(1).EQ.'FEED')GOTO6100 IF(IHARG(1).EQ.'NUMB')GOTO6200 IF(IHARG(1).EQ.'PRIN'.AND.IHARG2(1).EQ.'T ')GOTO6300 IF(IHARG(1).EQ.'PROM')GOTO6400 IF(IHARG(1).EQ.'TRAN')GOTO6500 C IF(IHARG(1).EQ.'COMM')GOTO7100 IF(IHARG(1).EQ.'INLI')GOTO7200 C IF(IHARG(1).EQ.'LIMI')GOTO8100 IF(IHARG(1).EQ.'SWIT')GOTO8300 C GOTO9000 C C ************************* C ** STEP 11-- ** C ** SET BUG VARIABLES ** C ************************* C 1100 CONTINUE C ISTEPN='11' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SET') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IHARG2(1).EQ.'ED')GOTO1110 IF(IHARG2(1).EQ.'E2')GOTO1120 IF(IHARG2(1).EQ.'E3')GOTO1130 IF(IHARG2(1).EQ.'TY')GOTO1140 IF(IHARG2(1).EQ.'FI')GOTO1150 IF(IHARG2(1).EQ.'T1')GOTO1160 IF(IHARG2(1).EQ.'T2')GOTO1170 IF(IHARG2(1).EQ.'WR')GOTO1180 IF(IHARG2(1).EQ.'MA')GOTO1190 IERROR='YES' GOTO9000 C 1110 CONTINUE IBUGED=IHARG(2) GOTO1900 C 1120 CONTINUE IBUGE2=IHARG(2) GOTO1900 C 1130 CONTINUE IBUGE3=IHARG(2) GOTO1900 C 1140 CONTINUE IBUGTY=IHARG(2) GOTO1900 C 1150 CONTINUE IBUGFI=IHARG(2) GOTO1900 C 1160 CONTINUE IBUGT1=IHARG(2) GOTO1900 C 1170 CONTINUE IBUGT2=IHARG(2) GOTO1900 C 1180 CONTINUE IBUGWR=IHARG(2) GOTO1900 C 1190 CONTINUE IBUGMA=IHARG(2) GOTO1900 C 1900 CONTINUE GOTO9000 C C ******************************** C ** STEP 21-- ** C ** SET SUBROUTINE VARIABLES ** C ******************************** C 2100 CONTINUE C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'SET') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISUBRO=IHARG(2) GOTO9000 C C ******************************** C ** STEP 31-- ** C ** SET OTHER VARIABLES ** C ******************************** C 3000 CONTINUE WRITE(ICOUT,3011)IORINA CALL EDWRST('EDSHOW') 3011 FORMAT(10X,'[FILE BEING EDITED = ',A80,']') GOTO9000 C 3100 CONTINUE WRITE(ICOUT,3111)IBLIM1 CALL EDWRST('EDSHOW') 3111 FORMAT(10X,'[BEGINNING LINE NUMBER FOR COPY = ',I8,']') GOTO9000 C 3200 CONTINUE WRITE(ICOUT,3211)IBLIM2 CALL EDWRST('EDSHOW') GOTO9000 3211 FORMAT(10X,'[END LINE NUMBER FOR COPY = ',I8,']') C 3300 CONTINUE WRITE(ICOUT,3311)IBLIM1,IBLIM2 CALL EDWRST('EDSHOW') 3311 FORMAT(10X,'[LINE LIMITS FOR COPY COMMAND = ',2I8,']') GOTO9000 C 4100 CONTINUE WRITE(ICOUT,4111)ICLIM1,ICLIM2 CALL EDWRST('EDSHOW') 4111 FORMAT(10X,'[COLUMN LIMITS FOR CHANGE COMMAND = ',2I8,']') GOTO9000 C 4200 CONTINUE WRITE(ICOUT,4211)IFLIM1,IFLIM2 CALL EDWRST('EDSHOW') 4211 FORMAT(10X,'[COLUMN LIMITS FOR FIND COMMAND = ',2I8,']') GOTO9000 C 4300 CONTINUE WRITE(ICOUT,4311)ILLIM1,ILLIM2 CALL EDWRST('EDSHOW') 4311 FORMAT(10X,'[COLUMN LIMITS FOR LOCATE COMMAND = ',2I8,']') GOTO9000 C 4400 CONTINUE WRITE(ICOUT,4411)IMLIM1,IMLIM2 CALL EDWRST('EDSHOW') 4411 FORMAT(10X,'[COLUMN LIMITS FOR MARGIN COMMAND = ',2I8,']') GOTO9000 C 4500 CONTINUE WRITE(ICOUT,4511)IP2LI1,IP2LI2 CALL EDWRST('EDSHOW') 4511 FORMAT(10X,'[COLUMN LIMITS FOR PAGE COMMAND = ',2I8,']') GOTO9000 C 4600 CONTINUE WRITE(ICOUT,4611)IPLIM1,IPLIM2 CALL EDWRST('EDSHOW') 4611 FORMAT(10X,'[COLUMN LIMITS FOR PRINT COMMAND = ',2I8,']') GOTO9000 C 4700 CONTINUE WRITE(ICOUT,4711)ITABC CALL EDWRST('EDSHOW') 4711 FORMAT(10X,'[COLUMN FOR AUTO-TABBING = ',I8,']') GOTO9000 C 5100 CONTINUE WRITE(ICOUT,5111)IINDEC CALL EDWRST('EDSHOW') 5111 FORMAT(10X,'[COLUMN FOR INDENT COMMAND = ',I8,']') GOTO9000 C 5200 CONTINUE WRITE(ICOUT,5211)ICENTC CALL EDWRST('EDSHOW') 5211 FORMAT(10X,'[COLUMN FOR CENTER COMMAND = ',I8,']') GOTO9000 C 5300 CONTINUE WRITE(ICOUT,5311)ITRUNC CALL EDWRST('EDSHOW') 5311 FORMAT(10X,'[COLUMN FOR TRUNCATE COMMAND = ',I8,']') GOTO9000 C 6100 CONTINUE WRITE(ICOUT,6111)IFEESW CALL EDWRST('EDSHOW') 6111 FORMAT(10X,'[SWITCH FOR PRINTING FEEDBACK = ',A4,']') GOTO9000 C 6200 CONTINUE WRITE(ICOUT,6211)IPRISW CALL EDWRST('EDSHOW') 6211 FORMAT(10X,'[SWITCH FOR PRINTING EDSHOWX = ',A4,']') GOTO9000 C 6300 CONTINUE WRITE(ICOUT,6311)INUMSW CALL EDWRST('EDSHOW') 6311 FORMAT(10X,'[SWITCH FOR PRINTING LINE NUMBERS = ',A4,']') GOTO9000 C 6400 CONTINUE WRITE(ICOUT,6411)IPROSW CALL EDWRST('EDSHOW') 6411 FORMAT(10X,'[SWITCH FOR PRINTING PROMPT = ',A4,']') GOTO9000 C 6500 CONTINUE WRITE(ICOUT,6511)ITRANS CALL EDWRST('EDSHOW') 6511 FORMAT(10X,'[SWITCH FOR TRANSLATION TYPE = ',A4,']') GOTO9000 C 7100 CONTINUE WRITE(ICOUT,7101)NUMCOM CALL EDWRST('EDSHOW') 7101 FORMAT(10X,'[NUMBER OF USER-DEFINED COMMANDS = ',I8,']') IF(NUMCOM.LE.0)GOTO7119 WRITE(ICOUT,7102) CALL EDWRST('EDSHOW') 7102 FORMAT(10X,'[-----------------------------------------',']') WRITE(ICOUT,7103) CALL EDWRST('EDSHOW') 7103 FORMAT(10X,'[COMMAND TRANSLATED STRING NUMB. OF CHAR.]') WRITE(ICOUT,7104) CALL EDWRST('EDSHOW') 7104 FORMAT(10X,'[-----------------------------------------',']') DO7110I=1,NUMCOM WRITE(ICOUT,7111)ICOM3(I),ICOM4(I),NCCOM4(I) CALL EDWRST('EDSHOW') 7111 FORMAT(10X,A8,5X,A20,5X,I8,']') 7110 CONTINUE WRITE(ICOUT,7112) CALL EDWRST('EDSHOW') 7112 FORMAT(10X,'[-----------------------------------------',']') 7119 CONTINUE GOTO9000 C 7200 CONTINUE GOTO9000 C 8100 CONTINUE WRITE(ICOUT,8111)IBLIM1,IBLIM2 CALL EDWRST('EDSHOW') 8111 FORMAT(10X,'[LINE LIMITS FOR COPY COMMAND = ',2I8,']') WRITE(ICOUT,8121)ICLIM1,ICLIM2 CALL EDWRST('EDSHOW') 8121 FORMAT(10X,'[COLUMN LIMITS FOR CHANGE COMMAND = ',2I8,']') WRITE(ICOUT,8131)IFLIM1,IFLIM2 CALL EDWRST('EDSHOW') 8131 FORMAT(10X,'[COLUMN LIMITS FOR FIND COMMAND = ',2I8,']') WRITE(ICOUT,8141)ILLIM1,ILLIM2 CALL EDWRST('EDSHOW') 8141 FORMAT(10X,'[COLUMN LIMITS FOR LOCATE COMMAND = ',2I8,']') WRITE(ICOUT,8151)IMLIM1,IMLIM2 CALL EDWRST('EDSHOW') 8151 FORMAT(10X,'[COLUMN LIMITS FOR MARGIN COMMAND = ',2I8,']') WRITE(ICOUT,8161)IP2LI1,IP2LI2 CALL EDWRST('EDSHOW') 8161 FORMAT(10X,'[COLUMN LIMITS FOR PAGE COMMAND = ',2I8,']') WRITE(ICOUT,8171)IPLIM1,IPLIM2 CALL EDWRST('EDSHOW') 8171 FORMAT(10X,'[COLUMN LIMITS FOR PRINT COMMAND = ',2I8,']') WRITE(ICOUT,8181)ITABC CALL EDWRST('EDSHOW') 8181 FORMAT(10X,'[COLUMN FOR AUTO-TABBING = ',I8,']') WRITE(ICOUT,8191)IINDEC CALL EDWRST('EDSHOW') 8191 FORMAT(10X,'[COLUMN FOR INDENT COMMAND = ',I8,']') WRITE(ICOUT,8201)ICENTC CALL EDWRST('EDSHOW') 8201 FORMAT(10X,'[COLUMN FOR CENTER COMMAND = ',I8,']') WRITE(ICOUT,8211)ITRUNC CALL EDWRST('EDSHOW') 8211 FORMAT(10X,'[COLUMN FOR TRUNCATE COMMAND = ',I8,']') GOTO9000 C 8300 CONTINUE WRITE(ICOUT,8311)IFEESW CALL EDWRST('EDSHOW') 8311 FORMAT(10X,'[SWITCH FOR PRINTING FEEDBACK = ',A4,']') WRITE(ICOUT,8321)IPRISW CALL EDWRST('EDSHOW') 8321 FORMAT(10X,'[SWITCH FOR PRINTING XXXX = ',A4,']') WRITE(ICOUT,8331)INUMSW CALL EDWRST('EDSHOW') 8331 FORMAT(10X,'[SWITCH FOR PRINTING LINE NUMBERS = ',A4,']') WRITE(ICOUT,8341)IPROSW CALL EDWRST('EDSHOW') 8341 FORMAT(10X,'[SWITCH FOR PRINTING PROMPT = ',A4,']') WRITE(ICOUT,8351)ITRANS CALL EDWRST('EDSHOW') 8351 FORMAT(10X,'[SWITCH FOR TRANSLATION TYPE = ',A4,']') GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'SET')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSHOW') WRITE(ICOUT,9011) CALL EDWRST('EDSHOW') 9011 FORMAT('*****AT THE END OF EDSET--') WRITE(ICOUT,9012)ICURLN CALL EDWRST('EDSHOW') 9012 FORMAT('ICURLN = ',I8) WRITE(ICOUT,9013)ICLIM1,ICLIM2 CALL EDWRST('EDSHOW') 9013 FORMAT('ICLIM1,ICLIM2 = ',2I8) WRITE(ICOUT,9014)ITRANS CALL EDWRST('EDSHOW') 9014 FORMAT('ITRANS = ',A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDSTAT C C PURPOSE--DUMP (= PRINT) STATUS OF CERTAIN VARIABLES C C DATE--JANUARY 24,1985 C C--------------------------------------------------------------- C CHARACTER*1 ICJUNK C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C ISUBN1='EDST' ISUBN2='AT ' C IFOUND='YES' IERROR='NO' C J1=(-999) J2=(-999) N1=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'STAT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDSTAT') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDSTAT') 51 FORMAT('***** AT THE BEGINNING OF EDSTAT--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** DUMP STATUS ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'STAT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C WRITE(ICOUT,999) CALL EDWRST('EDSTAT') IF(ICURLN.LT.1)GOTO1110 IF(ICURLN.GT.NUMLIN)GOTO1110 IROW=IPOINT(ICURLN) J1=ILOCC1(ICURLN) N1=NUMCPL(IROW) J2=J1+(N1-1) 1110 CONTINUE C IF(ICURLN.GE.1.AND.ICURLN.LE.NUMLIN)THEN WRITE(ICOUT,1121)(ICHA(J),J=J1,J2) CALL EDWRST('EDSTAT') ENDIF 1121 FORMAT('CURRENT LINE = ',80A1) WRITE(ICOUT,1122)ICURLN CALL EDWRST('EDSTAT') 1122 FORMAT('CURRENT LINE NUMBER = ',I8) WRITE(ICOUT,1123)J1 CALL EDWRST('EDSTAT') 1123 FORMAT('CURRENT START BYTE NUBMER = ',I8) WRITE(ICOUT,1124)J2 CALL EDWRST('EDSTAT') 1124 FORMAT('CURRENT STOP BYTE NUMBER = ',I8) IF(ICURLN.GE.1.AND.ICURLN.LE.NUMLIN)THEN WRITE(ICOUT,1125)N1 CALL EDWRST('EDSTAT') ENDIF 1125 FORMAT('LENGTH OF CURRENT LINE = ',I8) WRITE(ICOUT,1126)NUMLIN CALL EDWRST('EDSTAT') 1126 FORMAT('CURRENT TOTAL LINES = ',I8) WRITE(ICOUT,1127)NUMROW CALL EDWRST('EDSTAT') 1127 FORMAT('CURRENT WORKSPACE LINES = ',I8) WRITE(ICOUT,1128)MAXROW CALL EDWRST('EDSTAT') 1128 FORMAT('ALLOWABLE WORKSPACE LINES = ',I8) ANUMRO=NUMROW AMAXRO=MAXROW RATIO=ANUMRO/AMAXRO PRATIO=RATIO*100.0 WRITE(ICOUT,1131)PRATIO CALL EDWRST('EDSTAT') 1131 FORMAT('WORKSPACE LINES % FULL = ',F8.2,' %') C WRITE(ICOUT,1144)NUMCHA CALL EDWRST('EDSTAT') 1144 FORMAT('CURRENT TOTAL CHARS = ',I8) CCCCC WRITE(ICOUT,1145)NUMCH9 C1145 FORMAT('CURRENT WORKSPACE CHARS = ',I8) WRITE(ICOUT,1146)MAXEDC CALL EDWRST('EDSTAT') 1146 FORMAT('ALLOWABLE WORKSPACE CHARS = ',I8) ANUMCH=NUMCHA AMAXCH=MAXEDC RATIO=ANUMCH/AMAXCH PRATIO=RATIO*100.0 WRITE(ICOUT,1147)PRATIO CALL EDWRST('EDSTAT') 1147 FORMAT('WORKSPACE CHARS % FULL = ',F8.2,' %') WRITE(ICOUT,999) CALL EDWRST('EDSTAT') WRITE(ICOUT,1148) CALL EDWRST('EDSTAT') 1148 FORMAT(40X,'More: hit any key ...') READ(IRD,1149)ICJUNK 1149 FORMAT(A1) C WRITE(ICOUT,999) CALL EDWRST('EDSTAT') WRITE(ICOUT,1151)IMASK CALL EDWRST('EDSTAT') 1151 FORMAT('MASK CHARACTER = ',A1) WRITE(ICOUT,1152)IINFIN CALL EDWRST('EDSTAT') 1152 FORMAT('INFINITY CHARACTER = ',A1) WRITE(ICOUT,1153)IPROSW CALL EDWRST('EDSTAT') 1153 FORMAT('PROMPT = ',A4) WRITE(ICOUT,1154)IFEESW CALL EDWRST('EDSTAT') 1154 FORMAT('FEEDBACK = ',A4) WRITE(ICOUT,1155)INUMSW CALL EDWRST('EDSTAT') 1155 FORMAT('AUTO-NUMBERING = ',A4) WRITE(ICOUT,1156)ITRASW CALL EDWRST('EDSTAT') 1156 FORMAT('TRACE = ',A4) C WRITE(ICOUT,999) CALL EDWRST('EDSTAT') WRITE(ICOUT,1161)ICLIM1,ICLIM2 CALL EDWRST('EDSTAT') 1161 FORMAT('COLUMN LIMITS FOR CHANGE = ',2I8) WRITE(ICOUT,1162)IPLIM1,IPLIM2 CALL EDWRST('EDSTAT') 1162 FORMAT('COLUMN LIMITS FOR PRINT = ',2I8) WRITE(ICOUT,1163)IMLIM1,IMLIM2 CALL EDWRST('EDSTAT') 1163 FORMAT('COLUMN LIMITS FOR MARGIN = ',2I8) WRITE(ICOUT,1164)ITABC CALL EDWRST('EDSTAT') 1164 FORMAT('COLUMN FOR TAB = ',I8) WRITE(ICOUT,1165)ISCRO1,ISCRO2 CALL EDWRST('EDSTAT') 1165 FORMAT('SCREEN ROWS = ',2I8) WRITE(ICOUT,1166)ISCCO1,ISCCO2 CALL EDWRST('EDSTAT') 1166 FORMAT('SCREEN COLUMNS = ',2I8) WRITE(ICOUT,1167)IJUST CALL EDWRST('EDSTAT') 1167 FORMAT('JUSTIFICATION = ',A4) WRITE(ICOUT,1168)ISPACH,ISPACV CALL EDWRST('EDSTAT') 1168 FORMAT('SPACING = ',A4,2X,A4) CCCCC WRITE(ICOUT,1169)IFORMF C1169 FORMAT('FORM FEED CHARACTER STRING = ',A4) C WRITE(ICOUT,999) CALL EDWRST('EDSTAT') WRITE(ICOUT,1171)IBLIM1,IBLIM2 CALL EDWRST('EDSTAT') 1171 FORMAT('BLOCK LINE NUMBERS = ',2I8) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'STAT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDSTAT') WRITE(ICOUT,9011) CALL EDWRST('EDSTAT') 9011 FORMAT('***** AT THE END OF EDSTAT--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDTOP C C PURPOSE--GO TO TOP OF FILE C (= LINE 0 = "LINE" BEFORE TOPT VISIBLE LINE). C C NOTE--NO ARGUMENTS ARE EXPECTED OR PROCESSED. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------- C CHARACTER*4 ID C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDTO' ISUBN2='P ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TOP')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDTOP ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDTOP ') 51 FORMAT('***** AT THE BEGINNING OF EDTOP--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C *************************************** C ** STEP 1-- ** C ** WRITE WORKSPACE OUT TO THE FILE ** C *************************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'TOP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ID='SAVE' IF(IORINA.NE.ICOMNA.AND.IORINA.NE.ISAVNA) 1CALL EDWRWF(ID) C C ************************************************ C ** STEP 2-- ** C ** REWIND THE COMMAND-SAVE (= JOURNAL) FILE ** C ************************************************ C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'TOP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(IORINA.NE.ICOMNA.AND.IORINA.NE.ISAVNA) 1REWIND ICOMNU C C ************************* C ** STEP 3-- ** C ** GO TO LINE 0 ** C ************************* C ISTEPN='3' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'TOP') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=0 IF(IFEESW.EQ.'OFF')GOTO1159 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1151) CALL EDWRST('EDTOP ') ENDIF 1151 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1152) CALL EDWRST('EDTOP ') ENDIF 1152 FORMAT(10X,'[TOP]') 1159 CONTINUE ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TOP')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDTOP ') WRITE(ICOUT,9011) CALL EDWRST('EDTOP ') 9011 FORMAT('***** AT THE END OF EDTOP--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDTRA1 C C PURPOSE--PRINT TRACE/DEBUG INFORMATION AT THE BEGINNING C OF VARIOUS SUBROUTINES. C C DATE--JANUARY 19,1985 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C WRITE(ICOUT,52)IBUGE2,IFOUND,IERROR,IFEESW CALL EDWRST('EDTRA1') 52 FORMAT('IBUGE2,IFOUND,IERROR,IFEESW = ',A4,2X,A4,2X,A4,2X,A4) WRITE(ICOUT,53)IWIDTH CALL EDWRST('EDTRA1') 53 FORMAT('IWIDTH = ',I8) IF(IWIDTH.GE.1)WRITE(ICOUT,54)(IANS(I),I=1,IWIDTH) IF(IWIDTH.GE.1)CALL EDWRST('EDTRA1') 54 FORMAT('(IANS(I),I=1,IWIDTH) = ',80A1) WRITE(ICOUT,55)ICOM,ICOM2,ICOMT,ACOM,ICOMI CALL EDWRST('EDTRA1') 55 FORMAT('ICOM,ICOM2,ICOMT,ACOM,ICOMI = ', 1A4,2X,A4,2X,A4,E15.7,I8) WRITE(ICOUT,56)NUMARG CALL EDWRST('EDTRA1') 56 FORMAT('NUMARG = ',I8) IF(NUMARG.LE.0)GOTO59 DO57I=1,NUMARG WRITE(ICOUT,58)I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) CALL EDWRST('EDTRA1') 58 FORMAT('I,IHARG(I),IHARG2(I),IARGT(I),IARG(I),ARG(I) = ', 1I8,2X,A4,2X,A4,2X,A4,I8,E15.7) 57 CONTINUE 59 CONTINUE C WRITE(ICOUT,999) CALL EDWRST('EDTRA1') 999 FORMAT(1X) WRITE(ICOUT,61)ICURLN,IPRISW,IMODE CALL EDWRST('EDTRA1') 61 FORMAT('ICURLN,IPRISW,IMODE = ',I8,2X,A4,2X,A4) WRITE(ICOUT,62)IBLIM1,IBLIM2 CALL EDWRST('EDTRA1') 62 FORMAT('IBLIM1,IBLIM2 = ',2I8) WRITE(ICOUT,63)NUMLIN,MAXEDL CALL EDWRST('EDTRA1') 63 FORMAT('NUMLIN,MAXEDL = ',3I8) WRITE(ICOUT,64)NUMROW,MAXROW CALL EDWRST('EDTRA1') 64 FORMAT('NUMROW,MAXROW = ',3I8) DO65I=1,NUMROW WRITE(ICOUT,66)I,IPOINT(I),ILOCC1(I),NUMCPL(I) CALL EDWRST('EDTRA1') 66 FORMAT('I,IPOINT(I),ILOCC1(I),NUMCPL(I) = ',4I8) 65 CONTINUE C WRITE(ICOUT,999) CALL EDWRST('EDTRA1') WRITE(ICOUT,71)NUMCHA,MAXEDC CALL EDWRST('EDTRA1') 71 FORMAT('NUMCHA,MAXEDC = ',2I8) WRITE(ICOUT,72) CALL EDWRST('EDTRA1') 72 FORMAT('ICHA(.)--') IF(NUMCHA.GE.1)THEN WRITE(ICOUT,73)(ICHA(I),I=1,NUMCHA) CALL EDWRST('EDTRA1') ENDIF 73 FORMAT(50A1) C WRITE(ICOUT,81)IORINU,IORIST,IORINA CALL EDWRST('EDTRA1') 81 FORMAT('IORINU,IORIST,IORINA = ',I8,A12,A80) WRITE(ICOUT,82)ISAVNU,ISAVST,ISAVNA CALL EDWRST('EDTRA1') 82 FORMAT('ISAVNU,ISAVST,ISAVNA = ',I8,A12,A80) WRITE(ICOUT,83)IHELNU,IHELST,IHELNA CALL EDWRST('EDTRA1') 83 FORMAT('IHELNU,IHELST,IHELNA = ',I8,A12,A80) WRITE(ICOUT,84)ICOPNU,ICOPST,ICOPNA CALL EDWRST('EDTRA1') 84 FORMAT('ICOPNU,ICOPST,ICOPNA = ',I8,A12,A80) C WRITE(ICOUT,91)NCHH1,NCHH2,NCHH3,NCHH4,NCHH5 CALL EDWRST('EDTRA1') 91 FORMAT('NCHH1,NCHH2,NCHH3,NCHH4,NCHH5 = ',5I8) WRITE(ICOUT,92)NCHH6,NCHH8,NCHH9,NCHH10 CALL EDWRST('EDTRA1') 92 FORMAT('NCHH6,NCHH8,NCHH9,NCHH10 = ',4I8) IF(NCHH1.GE.1)THEN WRITE(ICOUT,93)(IHOLS1(I:I),I=1,NCHH1) CALL EDWRST('EDTRA1') ENDIF 93 FORMAT(80A1) IF(NCHH2.GE.1)THEN WRITE(ICOUT,93)(IHOLS2(I:I),I=1,NCHH2) CALL EDWRST('EDTRA1') ENDIF IF(NCHH3.GE.1)THEN WRITE(ICOUT,93)(IHOLS3(I:I),I=1,NCHH3) CALL EDWRST('EDTRA1') ENDIF IF(NCHH4.GE.1)THEN WRITE(ICOUT,93)(IHOLS4(I:I),I=1,NCHH4) CALL EDWRST('EDTRA1') ENDIF IF(NCHH5.GE.1)THEN WRITE(ICOUT,93)(IHOLS5(I:I),I=1,NCHH5) CALL EDWRST('EDTRA1') ENDIF IF(NCHH6.GE.1)THEN WRITE(ICOUT,93)(IHOLS6(I:I),I=1,NCHH6) CALL EDWRST('EDTRA1') ENDIF IF(NCHH7.GE.1)THEN WRITE(ICOUT,93)(IHOLS7(I:I),I=1,NCHH7) CALL EDWRST('EDTRA1') ENDIF IF(NCHH8.GE.1)THEN WRITE(ICOUT,93)(IHOLS8(I:I),I=1,NCHH8) CALL EDWRST('EDTRA1') ENDIF IF(NCHH9.GE.1)THEN WRITE(ICOUT,93)(IHOLS9(I:I),I=1,NCHH9) CALL EDWRST('EDTRA1') ENDIF IF(NCHH10.GE.1)THEN WRITE(ICOUT,93)(IHOL10(I:I),I=1,NCHH10) CALL EDWRST('EDTRA1') ENDIF CALL EDWRST('EDTRA1') WRITE(ICOUT,101)ICLIM1,ICLIM2 CALL EDWRST('EDTRA1') 101 FORMAT('ICLIM1,ICLIM2 = ',2I8) WRITE(ICOUT,102)IPLIM1,IPLIM2 CALL EDWRST('EDTRA1') 102 FORMAT('IPLIM1,IPLIM2 = ',2I8) WRITE(ICOUT,103)IMLIM1,IMLIM2 CALL EDWRST('EDTRA1') 103 FORMAT('IMLIM1,IMLIM2 = ',2I8) WRITE(ICOUT,104)ITABC CALL EDWRST('EDTRA1') 104 FORMAT('ITABC = ',I8) C WRITE(ICOUT,999) CALL EDWRST('EDTRA1') WRITE(ICOUT,111)NCOUT,ILOUT CALL EDWRST('EDTRA1') 111 FORMAT('NCOUT,ILOUT = ',2I8) WRITE(ICOUT,112)ICOUT CALL EDWRST('EDTRA1') 112 FORMAT('ICOUT = ',A230) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE EDTRA2 C C PURPOSE--PRINT TRACE/DEBUG INFORMATION AT THE END C OF VARIOUS SUBROUTINES. C C DATE--JANUARY 19,1985 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT------------------------------------------- C CALL EDTRA1 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE RETURN END SUBROUTINE EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C PURPOSE--PRINT OUT A TRACE LINE FOR DEBUGGING. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1984. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 ISTEPN CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C--------------------------------------------------------------------- C CCCCC CHARACTER*4 IFEESW CCCCC CHARACTER*4 IPRINT C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW CCCCC COMMON /PRINT/IFEESW,IPRINT C C-----START POINT----------------------------------------------------- C WRITE(ICOUT,105)ISTEPN,ISUBN1,ISUBN2 CALL EDWRST('EDTRA3') 105 FORMAT('TRACE AT STEP ',A4,' OF ',A4,A4) C RETURN END SUBROUTINE EDTRNP(IST4,IC1,IHIT) C C PURPOSE--EXAMINE THE INPUT ASCI SCRING IN IST4 C AND NOTE TO SEE IF IT IS ONE OF THE C MNEMONICS FOR THE FIRST 32 ASCII CHARACTERS. C IF IT IS , SET IHIT TO YES C AND OUTPUT (IN IC1) THE ACTUAL ASCII CHARACTER. C IF IT IS NOT, SET IHIT TO NO C AND DO NOTHING ELSE. C C NOTE--ACTUALLY, THE FIRST 33 CHARACTERS HAVE BEEN C INCLUDED (THE 33RD BEING A BLANK = A SPACE). C DATE--OCTOBER 20,1985 C C------------------------------------------------------------------------------- C CHARACTER*4 IST4 CHARACTER*1 IC1 CHARACTER*4 IHIT C CHARACTER*4 ITABNP C DIMENSION ITABNP(33) C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' INCLUDE 'DPCONP.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----DATA STATEMENTS------------------------------------- C DATA ITABNP( 1)/'SOH'/ DATA ITABNP( 2)/'STX'/ DATA ITABNP( 3)/'ETX'/ DATA ITABNP( 4)/'EOT'/ DATA ITABNP( 5)/'ENQ'/ DATA ITABNP( 6)/'ACK'/ DATA ITABNP( 7)/'BEL'/ DATA ITABNP( 8)/'BS'/ DATA ITABNP( 9)/'NUL'/ DATA ITABNP(10)/'LF'/ DATA ITABNP(11)/'VT'/ DATA ITABNP(12)/'FF'/ DATA ITABNP(13)/'CR'/ DATA ITABNP(14)/'SO'/ DATA ITABNP(15)/'SI'/ DATA ITABNP(16)/'DLE'/ DATA ITABNP(17)/'DC1'/ DATA ITABNP(18)/'DC2'/ DATA ITABNP(19)/'DC3'/ DATA ITABNP(20)/'DC4'/ DATA ITABNP(21)/'NAK'/ DATA ITABNP(22)/'SYN'/ DATA ITABNP(23)/'ETB'/ DATA ITABNP(24)/'CAN'/ DATA ITABNP(25)/'EM'/ DATA ITABNP(26)/'SUB'/ DATA ITABNP(27)/'ESC'/ DATA ITABNP(28)/'FS'/ DATA ITABNP(29)/'GS'/ DATA ITABNP(30)/'RS'/ DATA ITABNP(31)/'US'/ DATA ITABNP(32)/'BLAN'/ DATA ITABNP(33)/'NUL'/ C-----START POINT------------------------------------------- C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TRNP')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDTRNP') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDTRNP') 51 FORMAT('***** AT THE BEGINNING OF EDTRNP--') WRITE(ICOUT,52)IST4 CALL EDWRST('EDTRNP') 52 FORMAT('IST4 = ',A4) IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C IHIT='NO' IC1='-' DO1100I=1,33 IF(IST4.EQ.ITABNP(I))GOTO1150 GOTO1100 1150 CONTINUE IHIT='YES' IC1=CHAR(I) IF(I.EQ.33)IC1=CHAR(0) GOTO9000 1100 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TRNP')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDTRNP') WRITE(ICOUT,9011) CALL EDWRST('EDTRNP') 9011 FORMAT('***** AT THE END OF EDTRNP--') WRITE(ICOUT,9012)IST4,IHIT CALL EDWRST('EDTRNP') 9012 FORMAT('IST4,IHIT = ',A4,2X,A4) IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDTRUN C C PURPOSE--TRUNCATE CURRENT LINE C (AND NEXT IARG1-1 LINES) C SO AS TO BE BE TRUNCATED AT ITRUNC. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(240) DIMENSION INEWLI(240) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDCE' ISUBN2='NT ' C IFOUND='YES' IERROR='NO' C J1=(-999) N1=(-999) J2=(-999) C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CENT')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDTRUN') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDTRUN') 51 FORMAT('***** AT THE BEGINNING OF EDTRUN--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C C ************************************ C ** STEP 1-- ** C ** DETERMINE THE FIRST AND LAST ** C ** LINE NUMBERS TO BE TRUNCATED. ** C ************************************ C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ISTART=ICURLN ISTOP=ICURLN C IF(NUMARG.LE.0)GOTO1100 IF(NUMARG.EQ.1)GOTO1110 GOTO1120 C 1100 CONTINUE ISTART=ICURLN ISTOP=ICURLN GOTO1190 C 1110 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) ISTART=ICURLN ISTOP=ISTART+IARG1-1 GOTO1190 C 1120 CONTINUE IARG1=NUMLIN+1 IF(IARGT(1).EQ.'NUMB')IARG1=IARG(1) IARG2=NUMLIN+1 IF(IARGT(2).EQ.'NUMB')IARG2=IARG(2) ISTART=IARG1 ISTOP=IARG2 GOTO1190 C 1190 CONTINUE IHOLD1=ISTART IHOLD2=ISTOP IF(IHOLD2.LT.IHOLD1)ISTART=IHOLD2 IF(IHOLD2.LT.IHOLD1)ISTOP=IHOLD1 C C ******************************************** C ** STEP 21-- ** C ** LOOP THROUGH THE LINES TO BE TRUNCATED ** C ******************************************** C ISTEPN='21' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ILINE=ISTART-1 2100 CONTINUE ILINE=ILINE+1 IF(ILINE.LE.ISTOP)GOTO2910 ILINE=ISTOP GOTO2900 2910 CONTINUE ICURLN=ILINE IF(ILINE.LT.1)GOTO2100 IF(ILINE.GT.NUMLIN)GOTO2900 C C ***************************** C ** STEP 22-- ** C ** COPY THE OLD LINE ** C ***************************** C ISTEPN='22' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C I=0 DO2200J=J1,J2 I=I+1 IOLDLI(I)=ICHA(J) 2200 CONTINUE NUMCOL=I C C *********************************** C ** STEP 23-- ** C ** APPLY THE DESIRED CENTERING ** C ** TO THE TARGET LINE, ** C ** SO AS TO CREATE ** C ** A NEW LINE. ** C *********************************** C ISTEPN='23' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CALL EDTRU2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C *************************************** C ** STEP 24-- ** C ** DETERMINE IF ROOM EXISTS IN THE ** C ** MAIN INTERNAL CHARACTER ARRAY ** C ** FOR THE NEW TRUNCATED LINE. ** C *************************************** C ISTEPN='24' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMCH9=NUMCHA+NUMCNL CALL EDCHSI(NUMCH9) IF(IERROR.EQ.'YES')GOTO9000 C 2450 CONTINUE IF(ILINE.LT.1)GOTO2460 IF(ILINE.GT.NUMLIN)GOTO2470 GOTO2490 C 2460 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2461) CALL EDWRST('EDTRUN') ENDIF 2461 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2462) CALL EDWRST('EDTRUN') ENDIF 2462 FORMAT(10X,'[TOP]') 2469 CONTINUE GOTO2100 C 2470 CONTINUE IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2471) CALL EDWRST('EDTRUN') ENDIF 2471 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2472) CALL EDWRST('EDTRUN') ENDIF 2472 FORMAT(10X,'[BOTTOM]') 2479 CONTINUE GOTO9000 C 2490 CONTINUE C C *************************************** C ** STEP 25-- ** C ** UPDATE THE MAIN CHARACTER ARRAY ** C ** WITH THE NEW LINE. ** C *************************************** C ISTEPN='25' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'CENT') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C J1=NUMCHA+1 N1=NUMCNL J2=J1+(N1-1) C NUMRP1=NUMROW+1 IROW=NUMRP1 IPOINT(ILINE)=IROW ILOCC1(IROW)=J1 NUMCPL(IROW)=N1 C I=0 DO2500J=J1,J2 I=I+1 ICHA(J)=INEWLI(I) 2500 CONTINUE NUMROW=NUMRP1 NUMCHA=J2 C IF(IFEESW.EQ.'OFF')GOTO2629 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2621)(ICHA(J),J=J1,J2) CALL EDWRST('EDTRUN') ENDIF 2621 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2622)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDTRUN') ENDIF 2622 FORMAT(I6,':',3X,230A1) 2629 CONTINUE C GOTO2100 C 2900 CONTINUE IF(ILINE.LE.NUMLIN)GOTO2919 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,2911) CALL EDWRST('EDTRUN') ENDIF 2911 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,2912) CALL EDWRST('EDTRUN') ENDIF 2912 FORMAT(10X,'[BOTTOM]') 2919 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'CENT')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDTRUN') WRITE(ICOUT,9011) CALL EDWRST('EDTRUN') 9011 FORMAT('***** AT THE END OF EDTRUN--') WRITE(ICOUT,999) CALL EDWRST('EDTRUN') WRITE(ICOUT,9012)IWIDTH CALL EDWRST('EDTRUN') 9012 FORMAT('IWIDTH = ',I8) WRITE(ICOUT,9013)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDTRUN') 9013 FORMAT('(IANS(I),I=1,IWIDTH) = ',110A1) WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDTRUN') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDTRUN') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDTRUN') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDTRUN') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)ICURLN,ISTART,ISTOP CALL EDWRST('EDTRUN') 9041 FORMAT('ICURLN,ISTART,ISTOP = ',3I8) WRITE(ICOUT,9042)J1,N1,J2 CALL EDWRST('EDTRUN') 9042 FORMAT('J1,N1,J2 = ',3I8) WRITE(ICOUT,999) CALL EDWRST('EDTRUN') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDTRU2(IOLDLI,NUMCOL,INEWLI,NUMCNL) C C PURPOSE--TRUNCATE THE LINE IN IOLDLI(.). C THE TRUNCATED LINE WILL BE PLACED IN INEWLI(.). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*1 IOLDLI CHARACTER*1 INEWLI C DIMENSION IOLDLI(*) DIMENSION INEWLI(*) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDTR' ISUBN2='U2 ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TRU2')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDTRU2') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDTRU2') 51 FORMAT('***** AT THE BEGINNING OF EDTRU2--') WRITE(ICOUT,71)NUMCOL CALL EDWRST('EDTRU2') 71 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,72)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDTRU2') 72 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,73)NUMCNL CALL EDWRST('EDTRU2') 73 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,74)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDTRU2') 74 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,81)ITRUNC CALL EDWRST('EDTRU2') 81 FORMAT('ITRUNC = ',I8) 90 CONTINUE C C ************************************************************ C ** STEP 2-- ** C ** DETERMINE THE LAST NON-BLANK CHARACTER IN IOLDLI(.) ** C ************************************************************ C IREV=0 IF(NUMCOL.LE.0)GOTO1290 DO1200I=1,NUMCOL IREV=NUMCOL-I+1 IF(IOLDLI(IREV).NE.' ')GOTO1290 1200 CONTINUE IREV=0 1290 CONTINUE ILAST=IREV C C ****************************************************** C ** STEP 4-- ** C ** DETERMINE THE DESIRED TRUNCATION COLUMN OF THE NEW STRING * * C ****************************************************** C ITRUN2=ITRUNC C C ******************************** C ** STEP 5-- ** C ** BLANK OUT THE NEW STRING ** C ******************************** C NUMCNL=1 DO1500I=1,240 INEWLI(I)=' ' 1500 CONTINUE C C ************************************** C ** STEP 6-- ** C ** FORM THE NEW (TRUNCATED) STRING ** C ************************************** C INEW=0 IMAX=ILAST IF(ITRUN2.LT.IMAX)IMAX=ITRUN2 IF(IMAX.LE.0)GOTO1690 DO1600IOLD=1,IMAX INEW=IOLD INEWLI(INEW)=IOLDLI(IOLD) 1600 CONTINUE 1690 CONTINUE NUMCNL=INEW C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'TRU2')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDTRU2') WRITE(ICOUT,9011) CALL EDWRST('EDTRU2') 9011 FORMAT('***** AT THE END OF EDTRU2--') WRITE(ICOUT,9031)NUMCOL CALL EDWRST('EDTRU2') 9031 FORMAT('NUMCOL = ',I8) WRITE(ICOUT,9032)(IOLDLI(I),I=1,NUMCOL) CALL EDWRST('EDTRU2') 9032 FORMAT('(IOLDLI(I),I=1,NUMCOL) = ',110A1) WRITE(ICOUT,9033)NUMCNL CALL EDWRST('EDTRU2') 9033 FORMAT('NUMCNL = ',I8) WRITE(ICOUT,9034)(INEWLI(I),I=1,NUMCNL) CALL EDWRST('EDTRU2') 9034 FORMAT('(INEWLI(I),I=1,NUMCNL) = ',110A1) WRITE(ICOUT,9041)ILAST,ITRUNC,ITRUN2 CALL EDWRST('EDTRU2') 9041 FORMAT('ILAST,ITRUNC,ITRUN2 = ',3I8) 9090 CONTINUE C RETURN END SUBROUTINE EDTYPE(IHNAME,IHNAM2,IUSE,IVALUE,VALUE,NUMNAM) C C PURPOSE--TAKE THE COMPONENTS OF AN INPUT COMMAND LINE C AND COMPUTE HOLLERITH, INTEGER, AND FLOATING POINT C EQUIVALENTS FOR EACH COMPONENT. C INPUT ARGUMENTS--IANS (A HOLLERITH VECTOR) C --IWIDTH (AN INTEGER VARIABLE) C OUTPUT ARGUMENTS--ICOM (AN A4 HOLLERITH VALUE FOR COMMAND) C --ICOM2 (AN A4 HOLLERITH VALUE FOR COMMAND) C --IHARG (AN A4 HOLLERITH VECTOR) C --IHARG2 (AN A4 HOLLERITH VECTOR) C --IARG (AN INTEGER VECTOR) C --ARG (A FLOATING POINT VECTOR) C --NUMARG (AN INTEGER VARIABLE) C NOTE--A GIVEN ARGUMENT MAY END UP WITH C 3 DIFFERENT REPRESENTATIONS-- C HOLLERITH, INTEGER, AND FLOATING POINT. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--NOVEMBER 10, 1977. C UPDATED --MAY 1978. C UPDATED --OCTOBER 1978. C UPDATED --SEPTEMBER 1980. C UPDATED --NOVEMBER 1980. C UPDATED --AUGUST 1981. C UPDATED --OCTOBER 1981. C UPDATED --MAY 1982. C UPDATED --NOVEMBER 1982. C C-----CHARACTER STATEMENTS FOR NON-COMMON VARIABLES------------------- C CHARACTER*4 IHNAME CHARACTER*4 IHNAM2 CHARACTER*4 IUSE C CHARACTER*4 IFLUNK CHARACTER*1 IB CHARACTER*4 IANS1 CHARACTER*4 IANS2 CHARACTER*4 IH CHARACTER*4 IH2 C C--------------------------------------------------------------------- C DIMENSION IHNAME(*) DIMENSION IHNAM2(*) DIMENSION IUSE(*) DIMENSION IVALUE(*) DIMENSION VALUE(*) C DIMENSION ISTART(160) DIMENSION ISTOP(160) DIMENSION IB(160) C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDTY' ISUBN2='PE ' C IF(IBUGTY.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDTYPE') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDTYPE') 51 FORMAT('***** AT THE BEGINNING OF EDTYPE--') WRITE(ICOUT,52)IWIDTH CALL EDWRST('EDTYPE') 52 FORMAT('IWIDTH = ',I6) WRITE(ICOUT,53)(IANS(I),I=1,IWIDTH) CALL EDWRST('EDTYPE') 53 FORMAT('(IANS(.) = ',230A1) 90 CONTINUE C C ************************************************************ C ** DEFINE NUMASC = NUMBER OF ASCII CHARACTERS PER WORD. ** C ** THIS IS 4 REGARDLESS OF THE COMPUTER MAKE AND ** C ** REGARDLESS OF THE WORD SIZE. ** C ************************************************************ C NUMASC=4 C C ********************************** C ** STEP 1-- ** C ** INITIALIZE SOME VARIABLES. ** C ********************************** C ISTEPN='1' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICOM=' ' ICOM2=' ' ICOMT='NUMB' ICOMI=(-1) ACOM=(-1.0) DO110I=1,100 IHARG(I)=' ' IHARG2(I)=' ' IARGT(I)='NUMB' IARG(I)=(-1) ARG(I)=(-1.0) 110 CONTINUE NUMARG=(-1) C C *************************************************************** C ** STEP 2-- C ** SEPARATE IANS(.) INTO COMPONENTS WHERE C ** A COMPONENT IS DEFINED AS THAT SEPARATED BY 1 OR MORE BLANK C ** IN ADDITION, AN EQUAL SIGN (=), C ** A GREATER-THAN SIGN (>), AND A LESS-THAN SIGN (<) C ** ARE ALSO CONSIDERED AS A COMPONENT UNTO ITSELF C ** REGARDLESS OF WHETHER OR NOT C ** IT HAS PRECEEDING AND SUCCEEDING BLANKS. C ** FINALLY, A HYPHEN WHEN IMMEDIATELY PRECEDED C ** AND SUCCEEDED BY A NON-BLANK CHARACTER C ** WILL ALSO BE CONSIDERED AS A SEPARATOR C ** AND SO WILL NOT BE COPIED AS A CHARACTER. C ** HOWEVER, IF THERE IS A BLANK BEFORE OR AFTER THE HYPHEN C ** (AS IN DEFINING THE - AS A PLOT CHARACTER TYPE), C ** THEN THE HYPHEN WILL BE TREATED AND COPIED AS A SEPARATE C ** COMPONENT. C ** TREAT THE CASE WHERE THE ORIGINAL LINE IANS(.) WAS NON-EMPT C ** LOCATE THE START AND STOP COLUMNS FOR EACH 'WORD'. C *************************************************************** C ISTEPN='2' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMWD=0 DO300I=1,IWIDTH IM1=I-1 IM2=I-2 IP1=I+1 C IF(IANS(I).EQ.'=')GOTO350 IF(IANS(I).EQ.'>')GOTO350 IF(IANS(I).EQ.'<')GOTO350 IF(IANS(I).NE.' '.AND.I.LE.1)GOTO350 C IF(I.LE.1)GOTO360 IF(IANS(I).NE.' '.AND.IANS(IM1).EQ.' ')GOTO350 IF(IANS(I).NE.' '.AND.IANS(IM1).EQ.'=')GOTO350 IF(IANS(I).NE.' '.AND.IANS(IM1).EQ.'>')GOTO350 IF(IANS(I).NE.' '.AND.IANS(IM1).EQ.'<')GOTO350 C IF(I.LE.2)GOTO360 IF(IANS(I).NE.' '.AND.IANS(IM1).EQ.'-')GOTO340 GOTO360 C 340 CONTINUE IF(IANS(IM2).EQ.'=')GOTO360 IF(IANS(IM2).EQ.'-')GOTO355 IF(IANS(IM2).NE.' ')GOTO350 GOTO360 C 350 CONTINUE NUMWD=NUMWD+1 C 355 CONTINUE ISTART(NUMWD)=I C 360 CONTINUE IF(IANS(I).EQ.'=')GOTO370 IF(IANS(I).EQ.'>')GOTO370 IF(IANS(I).EQ.'<')GOTO370 IF(IANS(I).NE.' '.AND.I.GE.IWIDTH)GOTO370 C IF(I.GE.IWIDTH)GOTO390 IF(IANS(I).NE.' '.AND.IANS(IP1).EQ.' ')GOTO370 IF(IANS(I).NE.' '.AND.IANS(IP1).EQ.'=')GOTO370 IF(IANS(I).NE.' '.AND.IANS(IP1).EQ.'>')GOTO370 IF(IANS(I).NE.' '.AND.IANS(IP1).EQ.'<')GOTO370 IF(IANS(I).NE.' '.AND.IANS(IP1).EQ.'-')GOTO370 C GOTO390 C 370 CONTINUE ISTOP(NUMWD)=I C 390 CONTINUE IF(IBUGTY.EQ.'ON')THEN WRITE(ICOUT,391)NUMWD CALL EDWRST('EDTYPE') ENDIF 391 FORMAT('NUMWD = ',I8) IF(IBUGTY.EQ.'ON'.AND.NUMWD.GE.1)THEN WRITE(ICOUT,392)I,NUMWD,ISTART(NUMWD),ISTOP(NUMWD) CALL EDWRST('EDTYPE') ENDIF 392 FORMAT('I,NUMWD,ISTART(NUMWD),ISTOP(NUMWD) = ',4I8) 300 CONTINUE IF(NUMWD.LE.0)GOTO9000 C C *********************************************************** C ** STEP 3-- ** C ** CONVERT THE FIRST STRING TO A COMMAND ** C ** EXTRACT THE FIRST 4 CHARACTERS OF ** C ** THE COMMAND. PACK THESE 4 CHARACTERS ** C ** INTO THE HOLLERITH VARIABLE ICOM. ** C ** ONLY 4 CHARACTERS ARE RETAINED ** C ** REGARDLESS OF THE MAX NUMBER OF ** C ** CHARACTERS PER WORD ON A GIVEN ** C ** COMPUTER (E.G., EVEN THOUGH UNIVAC ** C ** COULD RETAIN 6 CHARACTERS PER WORD, ** C ** IT IS SUFFICIENT TO RETAIN ** C ** ONLY 4 CHARACTERS PER WORD--ON A UNIVAC ** C ** OR ANY OTHER COMPUTER. ** C ** OR ANY OTHER COMPUTER. ** C ** ALSO, IF THE NUMBER OF CHARACTERS ** C ** IN THE FIRST WORD IS 5 OR MORE, ** C ** THEN PACK CHARACTERS 5 THROUGH 8 ** C ** (OR CHARACTERS 5 THROUGH THE END OF THE WORD ** C ** IF THE END OF THE WORD IS BEFORE CHARACTER 8) ** C ** INTO THE 4-CHARACTER WORD ICOM2. ** C *********************************************************** C ISTEPN='3' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IWORD=1 IWID=ISTOP(IWORD)-ISTART(IWORD)+1 JMIN=ISTART(IWORD) JMAX=ISTOP(IWORD) I=0 DO800J=JMIN,JMAX I=I+1 IB(I)=IANS(J) 800 CONTINUE C IANS1=' ' IANS2=' ' IMAX=2*NUMASC IF(IWID.LT.IMAX)IMAX=IWID IF(IBUGTY.EQ.'ON')THEN WRITE(ICOUT,901)IMAX CALL EDWRST('EDTYPE') ENDIF 901 FORMAT('IMAX = ',I6) DO900I=1,IMAX IF(IB(I).EQ.' ')GOTO910 IM4=I-4 IF(I.LE.NUMASC)IANS1(I:I)=IB(I) IF(I.GT.NUMASC)IANS2(IM4:IM4)=IB(I) 900 CONTINUE 910 CONTINUE ICOM=IANS1 ICOM2=IANS2 C C ******************************************** C ** STEP 4-- ** C ** CONVERT STRINGS 2 THROUGH END ** C ** TO HOLLERITH A4 ARGUMENTS. ** C ** IF MORE THAN 8 CHARACTERS, ** C ** CONVERT ONLY THE FIRST 8 CHARACTERS ** C ** (REGARDLESS OF THE COMPUTER TYPE). ** C ******************************************** C ISTEPN='4' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMARG=NUMWD-1 IF(NUMWD.LE.1)GOTO1999 DO1000IWORD=2,NUMWD IWID=ISTOP(IWORD)-ISTART(IWORD)+1 C JMIN=ISTART(IWORD) JMAX=ISTOP(IWORD) I=0 DO1100J=JMIN,JMAX I=I+1 IB(I)=IANS(J) 1100 CONTINUE C IANS1=' ' IANS2=' ' IMAX=2*NUMASC IF(IWID.LT.IMAX)IMAX=IWID DO1200I=1,IMAX IF(IB(I).EQ.' ')GOTO1210 IM4=I-4 IF(I.LE.NUMASC)IANS1(I:I)=IB(I) IF(I.GT.NUMASC)IANS2(IM4:IM4)=IB(I) 1200 CONTINUE 1210 CONTINUE IWORM1=IWORD-1 IHARG(IWORM1)=IANS1 IHARG2(IWORM1)=IANS2 C 1000 CONTINUE 1999 CONTINUE C C ********************************************************** C ** STEP 5-- ** C ** CONVERT STRINGS 1 THROUGH END TO INTEGER ARGUMENTS ** C ********************************************************** C ISTEPN='5' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMWD.LE.0)GOTO2999 DO2000IWORD=1,NUMWD IWORM1=IWORD-1 C IF(IWORD.LE.1)GOTO2005 GOTO2006 C 2005 CONTINUE IH=ICOM IH2=ICOM2 GOTO2009 C 2006 CONTINUE IH=IHARG(IWORM1) IH2=IHARG2(IWORM1) GOTO2009 C 2009 CONTINUE IF(NUMNAM.LE.0)GOTO2040 DO2010INAME=1,NUMNAM IF(IH.EQ.IHNAME(INAME).AND.IH2.EQ.IHNAM2(INAME))GOTO2020 GOTO2010 2020 CONTINUE IF(IUSE(INAME).EQ.'P')GOTO2030 GOTO2040 2030 CONTINUE IARGT(IWORM1)='NUMB' IARG(IWORM1)=IVALUE(INAME) GOTO2000 2010 CONTINUE 2040 CONTINUE C IFLUNK='NO' IANS3=(-1) IWID=ISTOP(IWORD)-ISTART(IWORD)+1 JMIN=ISTART(IWORD) JMAX=ISTOP(IWORD) I=0 DO2100J=JMIN,JMAX I=I+1 IB(I)=IANS(J) 2100 CONTINUE C IDIG=0 ISIGN=0 IDECPT=0 ISUM=0 DO2700I=1,IWID IREV=IWID-I+1 IF(IB(IREV).EQ.' ')GOTO2700 IF(IB(IREV).EQ.'0')GOTO2710 IF(IB(IREV).EQ.'1')GOTO2711 IF(IB(IREV).EQ.'2')GOTO2712 IF(IB(IREV).EQ.'3')GOTO2713 IF(IB(IREV).EQ.'4')GOTO2714 IF(IB(IREV).EQ.'5')GOTO2715 IF(IB(IREV).EQ.'6')GOTO2716 IF(IB(IREV).EQ.'7')GOTO2717 IF(IB(IREV).EQ.'8')GOTO2718 IF(IB(IREV).EQ.'9')GOTO2719 IF(IB(IREV).EQ.'+')GOTO2720 IF(IB(IREV).EQ.'-')GOTO2721 IF(IB(IREV).EQ.'.')GOTO2722 IFLUNK='YES' GOTO2800 2710 ITERM=0 GOTO2725 2711 ITERM=1 GOTO2725 2712 ITERM=2 GOTO2725 2713 ITERM=3 GOTO2725 2714 ITERM=4 GOTO2725 2715 ITERM=5 GOTO2725 2716 ITERM=6 GOTO2725 2717 ITERM=7 GOTO2725 2718 ITERM=8 GOTO2725 2719 ITERM=9 GOTO2725 2720 ISIGN=ISIGN+1 GOTO2700 2721 ISIGN=ISIGN+1 ISUM=-ISUM GOTO2700 2722 IDECPT=IDECPT+1 IF(IDECPT.EQ.1.AND.IDIG.EQ.0)GOTO2700 GOTO2800 2725 IDIG=IDIG+1 ISUM=ISUM+ITERM*10 **(IDIG-1) 2700 CONTINUE IF(IDIG.LE.0)GOTO2800 IF(ISIGN.GE.2)GOTO2800 IANS3=ISUM 2800 CONTINUE IWORM1=IWORD-1 IF(IWORD.LE.1)ICOMI=IANS3 IF(IWORD.GE.2)IARG(IWORM1)=IANS3 IF(IWORD.LE.1.AND.IFLUNK.EQ.'YES')ICOMT='WORD' IF(IWORD.GE.2.AND.IFLUNK.EQ.'YES')IARGT(IWORM1)='WORD' 2000 CONTINUE 2999 CONTINUE C C *************************************************************** C ** STEP 6-- ** C ** CONVERT STRINGS 2 THROUGH N TO FLOATING POINT ARGUMENTS ** C *************************************************************** C ISTEPN='6' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C C ************************************************************ C ** STEP 6.1-- ** C ** FIRST OF ALL, LOCATE THE DECIMAL POINT (IF EXISTEPNT) ** C ************************************************************ C ISTEPN='6.1' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C AMIN=-1000000. AMAX=+1000000. NUMARG=NUMWD-1 CCCCC IF(NUMARG.LE.0)GOTO3999 IF(NUMWD.LE.0)GOTO3999 DO3000IWORD=1,NUMWD C IWORM1=IWORD-1 C IF(IWORD.LE.1)GOTO3005 GOTO3006 C 3005 CONTINUE IH=ICOM IH2=ICOM2 GOTO3009 C 3006 CONTINUE IH=IHARG(IWORM1) IH2=IHARG2(IWORM1) GOTO3009 C 3009 CONTINUE C IF(NUMNAM.LE.0)GOTO3040 DO3010INAME=1,NUMNAM IF(IH.EQ.IHNAME(INAME).AND.IH2.EQ.IHNAM2(INAME))GOTO3020 GOTO3010 3020 CONTINUE IF(IUSE(INAME).EQ.'P')GOTO3030 GOTO3040 3030 CONTINUE IF(IWORD.LE.1)ICOMT='NUMB' IF(IWORD.GE.2)IARGT(IWORM1)='NUMB' IF(IWORD.LE.1)ACOM=VALUE(INAME) IF(IWORD.GE.2)ARG(IWORM1)=VALUE(INAME) GOTO3000 3010 CONTINUE 3040 CONTINUE C IFLUNK='NO' ANS2=(-1.0) IWID=ISTOP(IWORD)-ISTART(IWORD)+1 JMIN=ISTART(IWORD) JMAX=ISTOP(IWORD) I=0 DO3050J=JMIN,JMAX I=I+1 IB(I)=IANS(J) 3050 CONTINUE C ILOC=0 IDECPT=0 DO3060I=1,IWID IF(IB(I).EQ.'.')ILOC=I IF(IB(I).EQ.'.')IDECPT=IDECPT+1 3060 CONTINUE IF(IDECPT.GE.2)GOTO3900 IF(IDECPT.EQ.1)GOTO3150 DO3100I=1,IWID IREV=IWID-I+1 IF(IB(IREV).EQ.' ')GOTO3100 IF(IB(IREV).EQ.'0')GOTO3110 IF(IB(IREV).EQ.'1')GOTO3110 IF(IB(IREV).EQ.'2')GOTO3110 IF(IB(IREV).EQ.'3')GOTO3110 IF(IB(IREV).EQ.'4')GOTO3110 IF(IB(IREV).EQ.'5')GOTO3110 IF(IB(IREV).EQ.'6')GOTO3110 IF(IB(IREV).EQ.'7')GOTO3110 IF(IB(IREV).EQ.'8')GOTO3110 IF(IB(IREV).EQ.'9')GOTO3110 IFLUNK='YES' IF(IB(IREV).EQ.'+')GOTO3900 IF(IB(IREV).EQ.'-')GOTO3900 GOTO3900 3100 CONTINUE IFLUNK='YES' GOTO3900 3110 ILOC=IREV+1 3150 CONTINUE IF(IBUGTY.NE.'OFF')THEN WRITE(ICOUT,3111)ILOC,IDECPT CALL EDWRST('EDTYPE') ENDIF 3111 FORMAT('ILOC = ',I8,' IDECPT = ',I8) C C ******************************************************* C ** STEP 6.2-- ** C ** SECONDLY, COMPUTE THE INTEGER PART OF THE VALUE ** C ******************************************************* C ISTEPN='6.2' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C SIGN=1.0 IDIGI=0 ISIGN=0 SUMI=0 ILOCM1=ILOC-1 IF(ILOCM1.LT.1)GOTO3250 DO3200I=1,ILOCM1 IREV=ILOCM1-I+1 IF(IB(IREV).EQ.' ')GOTO3200 IF(IB(IREV).EQ.'0')GOTO3210 IF(IB(IREV).EQ.'1')GOTO3211 IF(IB(IREV).EQ.'2')GOTO3232 IF(IB(IREV).EQ.'3')GOTO3213 IF(IB(IREV).EQ.'4')GOTO3214 IF(IB(IREV).EQ.'5')GOTO3215 IF(IB(IREV).EQ.'6')GOTO3216 IF(IB(IREV).EQ.'7')GOTO3217 IF(IB(IREV).EQ.'8')GOTO3218 IF(IB(IREV).EQ.'9')GOTO3219 IF(IB(IREV).EQ.'+')GOTO3220 IF(IB(IREV).EQ.'-')GOTO3221 IFLUNK='YES' GOTO3900 3210 ITERM=0 GOTO3225 3211 ITERM=1 GOTO3225 3232 ITERM=2 GOTO3225 3213 ITERM=3 GOTO3225 3214 ITERM=4 GOTO3225 3215 ITERM=5 GOTO3225 3216 ITERM=6 GOTO3225 3217 ITERM=7 GOTO3225 3218 ITERM=8 GOTO3225 3219 ITERM=9 GOTO3225 3220 ISIGN=ISIGN+1 GOTO3200 3221 ISIGN=ISIGN+1 SIGN=-SIGN GOTO3200 3225 IDIGI=IDIGI+1 TERM=ITERM IEXP=IDIGI-1 SUMI=SUMI+TERM*(10.0 **IEXP) 3200 CONTINUE 3250 CONTINUE IF(ISIGN.GE.2)GOTO3900 IF(IBUGTY.NE.'OFF')THEN WRITE(ICOUT,3255)IDIGI,SUMI CALL EDWRST('EDTYPE') ENDIF 3255 FORMAT('IDIGI = ',I8,' SUMI = ',F20.10) C C ****************************************************** C ** STEP 6.3-- ** C ** THIRDLY, COMPUTE THE DECIMAL PART OF THE VALUE ** C ****************************************************** C ISTEPN='6.3' IF(IBUGTY.EQ.'ON')CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IDIGD=0 SUMD=0.0 ILOCP1=ILOC+1 IF(ILOCP1.GT.IWID)GOTO3350 DO3300I=ILOCP1,IWID IF(IB(I).EQ.' ')GOTO3300 IF(IB(I).EQ.'0')GOTO3310 IF(IB(I).EQ.'1')GOTO3311 IF(IB(I).EQ.'2')GOTO3312 IF(IB(I).EQ.'3')GOTO3333 IF(IB(I).EQ.'4')GOTO3314 IF(IB(I).EQ.'5')GOTO3315 IF(IB(I).EQ.'6')GOTO3316 IF(IB(I).EQ.'7')GOTO3317 IF(IB(I).EQ.'8')GOTO3318 IF(IB(I).EQ.'9')GOTO3319 IFLUNK='YES' GOTO3900 3310 ITERM=0 GOTO3325 3311 ITERM=1 GOTO3325 3312 ITERM=2 GOTO3325 3333 ITERM=3 GOTO3325 3314 ITERM=4 GOTO3325 3315 ITERM=5 GOTO3325 3316 ITERM=6 GOTO3325 3317 ITERM=7 GOTO3325 3318 ITERM=8 GOTO3325 3319 ITERM=9 GOTO3325 3325 IDIGD=IDIGD+1 TERM=ITERM SUMD=SUMD+TERM/(10.0 **IDIGD) 3300 CONTINUE 3350 CONTINUE IF(IBUGTY.NE.'OFF')THEN WRITE(ICOUT,3355)IDIGD,SUMD CALL EDWRST('EDTYPE') ENDIF 3355 FORMAT('IDIGD = ',I8,' SUMD = ',F20.10) IDIGT=IDIGI+IDIGD IF(IDIGT.LE.0)GOTO3900 ANS2=SUMI+SUMD IF(SIGN.LT.0.0)ANS2=-ANS2 IWORM1=IWORD-1 IF(IWORD.LE.1)ACOM=ANS2 IF(IWORD.GE.2)ARG(IWORM1)=ANS2 IF(AMIN.LE.ANS2.AND.ANS2.LE.AMAX)GOTO3000 GOTO3900 C 3900 CONTINUE IWORM1=IWORD-1 CCCCC THE FOLLOWING 2 LINES WERE FIXED APRIL 1990 CCCCC BASED ON IBM-PC OTG COMPILER DIAGNOSTICS CCCCC ARG(IWORM1)=ANS2 CCCCC IF(IFLUNK.EQ.'YES')IARGT(IWORM1)='WORD' IF(IWORD.GE.2)ARG(IWORM1)=ANS2 IF(IWORD.GE.2.AND.IFLUNK.EQ.'YES')IARGT(IWORM1)='WORD' 3000 CONTINUE 3999 CONTINUE C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGTY.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDTYPE') WRITE(ICOUT,9011) CALL EDWRST('EDTYPE') 9011 FORMAT('***** AT THE END OF EDTYPE--') WRITE(ICOUT,9012)ICOM,ICOM2,ICOMT,ACOM,ICOMI CALL EDWRST('EDTYPE') 9012 FORMAT('ICOM,ICOM2,ICOMT,ACOM,ICOMI = ', 1A4,2X,A4,2X,A4,E15.7,I8) WRITE(ICOUT,9013)NUMARG CALL EDWRST('EDTYPE') 9013 FORMAT('NUMARG = ',I6) DO9015I=1,NUMARG WRITE(ICOUT,9016)I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) CALL EDWRST('EDTYPE') 9016 FORMAT('I,IHARG(I),IHARG2(I),IARG(I),ARG(I),IARGT(I) = ', 1I6,1X,A4,1X,A4,1X,I6,1X,E15.7,1X,A4) 9015 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE EDUNDO C C PURPOSE-UNDO THE LAST COMMAND. C RESTORE THE INTERNAL POINTERS TO THEIR SETTINGS C PRIOR TO THE LAST COMMAND. C NOTE--NO ARGUMENTS ARE EXPECTED. C SYNTAX--UNDO C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDUN' ISUBN2='DO ' C IFOUND='YES' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'UNDO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDUNDO') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDUNDO') 51 FORMAT('*****AT THE BEGINNING OF EDUNDO--') WRITE(ICOUT,52)IBUGE2,ISUBRO CALL EDWRST('EDUNDO') 52 FORMAT('IBUGE2,ISUBRO = ',A4,2X,A4) WRITE(ICOUT,53)NUMLOL,NUMROL,NCHAOL,IOLDLN CALL EDWRST('EDUNDO') 53 FORMAT('NUMLOL,NUMROL,NCHAOL,IOLDLN = ',4I8) WRITE(ICOUT,54)NUMLIN,NUMROW,NUMCHA,ICURLN CALL EDWRST('EDUNDO') 54 FORMAT('NUMLIN,NUMROW,NUMCHA,ICURLN = ',4I8) IF(NUMLIN.LE.0)GOTO59 DO55I=1,NUMLIN WRITE(ICOUT,56)I,IPOIOL(I),IPOINT(I) CALL EDWRST('EDUNDO') 56 FORMAT('I,IPOIOL(I),IPOINT(I) = ',3I8) 55 CONTINUE 59 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDUNDO') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ***************************** C ** STEP 1-- ** C ** COPY THE OLD POINTERS ** C ***************************** C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'UNDO') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C NUMLIN=NUMLOL ICURLN=IOLDLN NUMROW=NUMROL NUMCHA=NCHAOL C IF(NUMLIN.LE.0)GOTO1190 DO1100I=1,NUMLIN IPOINT(I)=IPOIOL(I) 1100 CONTINUE 1190 CONTINUE C C ************************* C ** STEP 2-- ** C ** GO TO TOP OF FILE ** C ************************* C ISTEPN='2' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'UNDO') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICURLN=0 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'UNDO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDUNDO') WRITE(ICOUT,9011) CALL EDWRST('EDUNDO') 9011 FORMAT('*****AT THE END OF EDUNDO--') WRITE(ICOUT,9012)NUMLOL,NUMROL,NCHAOL,IOLDLN CALL EDWRST('EDUNDO') 9012 FORMAT('NUMLOL,NUMROL,NCHAOL,IOLDLN = ',4I8) WRITE(ICOUT,9013)NUMLIN,NUMROW,NUMCHA,ICURLN CALL EDWRST('EDUNDO') 9013 FORMAT('NUMLIN,NUMROW,NUMCHA,ICURLN = ',4I8) IF(NUMLIN.LE.0)GOTO9019 DO9015I=1,NUMLIN WRITE(ICOUT,9016)I,IPOIOL(I),IPOINT(I) CALL EDWRST('EDUNDO') 9016 FORMAT('I,IPOIOL(I),IPOINT(I) = ',3I8) 9015 CONTINUE 9019 CONTINUE WRITE(ICOUT,999) CALL EDWRST('EDUNDO') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDUP C C PURPOSE--GO UP K LINES C C NOTE--IF NO ARGUMENTS, THEN GO UP 1 LINE C IF 1 ARGUMENT, THEN GO GO UP K LINES. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--85.1 C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDUP' ISUBN2=' ' C IFOUND='NO' IERROR='NO' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DO')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDUP ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDUP ') 51 FORMAT('***** AT THE BEGINNING OF EDUP--') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************* C ** STEP 1-- ** C ** GO UP K LINES ** C ** AND PRINT IT OUT. ** C ************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'DO') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C K=1 IF(NUMARG.GE.1.AND.IARGT(1).EQ.'NUMB')K=IARG(1) C ILINE=ICURLN-K C IF(ILINE.LT.1)GOTO1110 IF(ILINE.GT.NUMLIN)GOTO1120 GOTO1130 C 1110 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1119 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1111) CALL EDWRST('EDUP ') ENDIF 1111 FORMAT('[TOP]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1112) CALL EDWRST('EDUP ') ENDIF 1112 FORMAT(10X,'[TOP]') 1119 CONTINUE ILINE=0 GOTO1190 C 1120 CONTINUE IF(IFEESW.EQ.'OFF')GOTO1129 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1121) CALL EDWRST('EDUP ') ENDIF 1121 FORMAT('[BOTTOM]') IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1122) CALL EDWRST('EDUP ') ENDIF 1122 FORMAT(10X,'[BOTTOM]') 1129 CONTINUE ILINE=NUMLIN+1 GOTO1190 C 1130 CONTINUE IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) C IF(IFEESW.EQ.'OFF')GOTO1139 IF(IPRISW.EQ.'OFF'.AND.INUMSW.EQ.'OFF')THEN WRITE(ICOUT,1131)(ICHA(J),J=J1,J2) CALL EDWRST('EDUP ') ENDIF 1131 FORMAT(238A1) IF(IPRISW.EQ.'ON'.OR.INUMSW.EQ.'ON')THEN WRITE(ICOUT,1132)ILINE,(ICHA(J),J=J1,J2) CALL EDWRST('EDUP ') ENDIF 1132 FORMAT(I6,':',3X,230A1) 1139 CONTINUE GOTO1190 C 1190 CONTINUE ICURLN=ILINE IFOUND='YES' GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'DO')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDUP ') WRITE(ICOUT,9011) CALL EDWRST('EDUP ') 9011 FORMAT('***** AT THE END OF EDUP--') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDUPP1(IA1,IB1) C C PURPOSE--CONVERT 1-CHARACTER LOWER CASE ALPHABETIC (A TO Z) C ASCII WORD IA1 C TO UPPER CASE ASCII WORD IB1. C NOTE--IA1 AND IB1 ARE ASSUMED TO BE CHARACTER*1 C NOTE--IA1 AND IB1 MAY BE THE SAME VARIABLE IN THE CALLING ROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MAY 1982. C C--------------------------------------------------------------------- C CHARACTER*1 IA1 CHARACTER*1 IB1 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)---------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IF(IBUGMA.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDUPP1') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDUPP1') 51 FORMAT('***** AT THE BEGINNING OF EDUPP1--') WRITE(ICOUT,52)IA1 CALL EDWRST('EDUPP1') 52 FORMAT('IA1 = ',A1) 90 CONTINUE C C ******************************************************** C ** STEP 11-- C ** THE FOLLOWING CODE WILL CARRY OUT THE LOWER CASE C ** TO UPPER CASE CONVERSION FOR ALL COMPUTERS C ** WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES C ** USE OF THE ANSI FORTRAN 77 INTRINSIC FUNCTIONS C ** 1) ICHAR (FOR ASCII CHARACTER TO ASCII NUMERIC CO C ** 2) CHAR (FOR ASCII NUMERIC TO ASCII CHARACTER CO C ******************************************************** C IB1=IA1 C IVALUE=ICHAR(IA1) IF(97.LE.IVALUE.AND.IVALUE.LE.122)GOTO1110 GOTO1190 C 1110 CONTINUE IVAL32=IVALUE-32 IB1=CHAR(IVAL32) GOTO1190 C 1190 CONTINUE GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGMA.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDUPP1') WRITE(ICOUT,9011) CALL EDWRST('EDUPP1') 9011 FORMAT('***** AT THE END OF EDUPP1--') WRITE(ICOUT,9012)IA1,IVALUE,IVAL32,IB1 CALL EDWRST('EDUPP1') 9012 FORMAT('IA1,IVALUE,IVAL32,IB1 = ',A4,I8,I8,2X,A4) 9090 CONTINUE C RETURN END SUBROUTINE EDUPP4(IA4,IB4) C C PURPOSE--CONVERT 4-CHARACTER LOWER CASE ALPHABETIC (A TO Z) C ASCII WORD IA4 C TO UPPER CASE ASCII WORD IB4. C NOTE--IA4 AND IB4 ARE ASSUMED TO BE CHARACTER*4 C NOTE--IA4 AND IB4 MAY BE THE SAME VARIABLE IN THE CALLING ROUTINE. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--82/7 C ORIGINAL VERSION--JANUARY 1981. C UPDATED --MAY 1982. C C--------------------------------------------------------------------- C CHARACTER*4 IA4 CHARACTER*4 IB4 CHARACTER*1 IA1 CHARACTER*1 IB1 C CCCCC CHARACTER*4 ISUBN1 CCCCC CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)---------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IF(IBUGMA.EQ.'OFF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDUPP4') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDUPP4') 51 FORMAT('***** AT THE BEGINNING OF EDUPP4--') WRITE(ICOUT,52)IA4 CALL EDWRST('EDUPP4') 52 FORMAT('IA4 = ',A4) 90 CONTINUE C C ******************************************************** C ** STEP 11-- C ** THE FOLLOWING CODE WILL CARRY OUT THE LOWER CASE C ** TO UPPER CASE CONVERSION FOR ALL COMPUTERS C ** WITH AN ANSI 77 FORTRAN COMPILER--IT MAKES C ** USE OF THE ANSI FORTRAN 77 INTRINSIC FUNCTIONS C ** 1) ICHAR (FOR ASCII CHARACTER TO ASCII NUMERIC CO C ** 2) CHAR (FOR ASCII NUMERIC TO ASCII CHARACTER CO C ******************************************************** C IB4=IA4 C IA1=' ' IB1=' ' C DO1100I=1,4 C IA1=IA4(I:I) IVALUE=ICHAR(IA1) IF(97.LE.IVALUE.AND.IVALUE.LE.122)GOTO1110 GOTO1100 C 1110 CONTINUE IVAM32=IVALUE-32 IB1=CHAR(IVAM32) IB4(I:I)=IB1 GOTO1100 C 1100 CONTINUE C GOTO9000 C C ***************** C ** STEP 90-- ** C ** EXIT. ** C ***************** C 9000 CONTINUE IF(IBUGMA.EQ.'OFF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDUPP4') WRITE(ICOUT,9011) CALL EDWRST('EDUPP4') 9011 FORMAT('***** AT THE END OF EDUPP4--') WRITE(ICOUT,9012)IA4,IA1,IB1,IB4 CALL EDWRST('EDUPP4') 9012 FORMAT('IA4,IA1,IB1,IB4 = ',A4,2X,A1,2X,A1,2X,A4) 9090 CONTINUE C RETURN END SUBROUTINE EDWRGS(ICSTR,NCSTR,ISUBN0) C C PURPOSE--WRITE OUT THE NCSTR ELEMENTS OF THE C CHARACTER*238 STRING ICSTR(.:.) C OUT TO A GENERAL GRAPHICS DEVICE. C THE VALUE OF THE VARIABLE NCSTR C IS THE NUMBER OF ELEMENTS IN ICSTR(.:.) C TO BE WRITTEN OUT. C NOTE--ISUBN0 = NAME OF SUBROUTINE WHICH CALLED EDWRGS. C (AND THEREBY HAVE WALKBACK INFORMATION). C C WRITTEN BY--JAMES J. FILLIBEN C STATISTICAL ENGINEERING DIVISION C CENTER FOR APPLIED MATHEMATICS C NATIONAL BUREAU OF STANDARDS C WASHINGTON, D. C. 20234 C PHONE--301-921-3651 C NOTE--DATAPLOT IS A REGISTERED TRADEMARK C OF THE NATIONAL BUREAU OF STANDARDS. C THIS SUBROUTINE MAY NOT BE COPIED, EXTRACTED, C MODIFIED, OR OTHERWISE USED IN A CONTEXT C OUTSIDE OF THE DATAPLOT LANGUAGE/SYSTEM. C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--83.6 C ORIGINAL VERSION (AS A SEPARATE SUBROUTINE)--MAY 1983. C C-----NON-COMMON VARIABLES (GRAPHICS)------------------------------------------- C CHARACTER*238 ICSTR C CHARACTER*4 IMANUF C CHARACTER*4 ISUBN0 C CHARACTER*4 IBRANC C C-----COMMON---------------------------------------------------------- C INCLUDE 'DPCOHO.INC' INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)-------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C IERROR='NO' C IGUNIT=IPR C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'WRGS')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDWRGS') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDWRGS') 51 FORMAT('***** AT THE BEGINNING OF EDWRGS--') WRITE(ICOUT,52)ISUBN0 CALL EDWRST('EDWRGS') 52 FORMAT('ISUBN0 (NAME OF THE CALLING SUBROUTINE) = ',A4) WRITE(ICOUT,53)IGUNIT,IMANUF CALL EDWRST('EDWRGS') 53 FORMAT('IGUNIT,IMANUF = ',I8,2X,A4) WRITE(ICOUT,54)NCSTR CALL EDWRST('EDWRGS') 54 FORMAT('NCSTR = ',I8) IF(NCSTR.LE.0)GOTO57 DO55I=1,NCSTR IASCNE=ICHAR(ICSTR(I:I)) WRITE(ICOUT,56)I,ICSTR(I:I),IASCNE CALL EDWRST('EDWRGS') 56 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8) 55 CONTINUE 57 CONTINUE CCCCC WRITE(ICOUT,61)NUMTRA CCC61 FORMAT('NUMTRA = ',I8) CCCCC IF(NUMTRA.LE.0)GOTO69 CCCCC DO62I=1,NUMTRA CCCCC WRITE(ICOUT,63)I,NCTRA1(I),ICTRA1(I),NCTRA2(I),ICTRA2(I) CCC63 FORMAT('I,NCTRA1(I),ICTRA1(I),NCTRA2(I),ICTRA2(I) = ', CCCCC1I8,I8,2X,A30,I8,2X,A30) CCC62 CONTINUE CCC69 CONTINUE WRITE(ICOUT,79)IBUGE2,ISUBRO,IERROR CALL EDWRST('EDWRGS') 79 FORMAT('IBUGE2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) 90 CONTINUE C C ********************************************* C ** STEP 11-- ** C ** IF CALLED FOR, ** C ** CARRY OUT ANY SUB-STRING TRANSLATIONS ** C ********************************************* C CCCCC IF(NUMTRA.GE.1) CCCCC1CALL GRTRST(ICSTR,NCSTR, CCCCC1ICTRA1,NCTRA1,ICTRA2,NCTRA2,NUMTRA, CCCCC1IBUGE2,ISUBRO,IERROR) C C **************************** C ** STEP 21-- ** C ** WRITE OUT THE STRING ** C **************************** C IBRANC='NOWR' IF(1.LE.NCSTR.AND.NCSTR.LE.238)GOTO2100 GOTO2190 C 2100 CONTINUE IBRANC='WRIT' IF(IHOST1.EQ.'VAX'.AND.ICSTR(1:1).EQ.'$')GOTO2110 GOTO2120 C 2110 CONTINUE WRITE(IGUNIT,2111)(ICSTR(I:I),I=1,NCSTR) 2111 FORMAT(238A1) GOTO2190 C 2120 CONTINUE WRITE(IGUNIT,2121)(ICSTR(I:I),I=1,NCSTR) 2121 FORMAT(238A1) GOTO2190 C 2190 CONTINUE C C ******************************************* C ** STEP 31-- ** C ** IF CALLED FOR, ** C ** CALL THE LINE TRANSLATOR SUBROUTINE ** C ** WHICH CONVERTS A TEKTRONIX LINE ** C ** INTO A SET OF CALLS FOR ** C ** ANOTHER GRAPHICS DEVICE ** C ** (SEE SUBROUTINE GRTRTK). ** C ******************************************* C CCCCC IF(ITRANS.EQ.'ON')CALL GRTRTK(ICSTR,NCSTR) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'WRGS')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDWRGS') WRITE(ICOUT,9011) CALL EDWRST('EDWRGS') 9011 FORMAT('***** AT THE END OF EDWRGS--') WRITE(ICOUT,9012)IBRANC CALL EDWRST('EDWRGS') 9012 FORMAT('IBRANC = ',A4) WRITE(ICOUT,9013)IGUNIT,IMANUF CALL EDWRST('EDWRGS') 9013 FORMAT('IGUNIT,IMANUF = ',I8,2X,A4) WRITE(ICOUT,9014)NCSTR CALL EDWRST('EDWRGS') 9014 FORMAT('NCSTR = ',I8) IF(NCSTR.LE.0)GOTO9017 IF(NCSTR.LE.0)GOTO9017 DO9015I=1,NCSTR IASCNE=ICHAR(ICSTR(I:I)) WRITE(ICOUT,9016)I,ICSTR(I:I),IASCNE CALL EDWRST('EDWRGS') 9016 FORMAT('I,ICSTR(I:I),IASCNE = ',I8,2X,A1,I8) 9015 CONTINUE 9017 CONTINUE WRITE(ICOUT,9019)IBUGE2,ISUBRO,IERROR CALL EDWRST('EDWRGS') 9019 FORMAT('IBUGE2,ISUBRO,IERROR = ',A4,2X,A4,2X,A4) CCCCC WRITE(ICOUT,9021)NUMTRA C9021 FORMAT('NUMTRA = ',I8) CCCCC IF(NUMTRA.LE.0)GOTO9029 CCCCC DO9022I=1,NUMTRA CCCCC WRITE(ICOUT,9023)I,ICTRA1(I),NCTRA1(I),NCTRA2(I),ICTRA2(I) C9023 FORMAT('I,ICTRA1(I),NCTRA1(I),NCTRA2(I),ICTRA2(I) = ', CCCCC1I8,2X,A30,I8,2X,A30,I8) C9022 CONTINUE C9029 CONTINUE 9090 CONTINUE C RETURN END SUBROUTINE EDWRLI(ICNEWL,NCNEWL,ILINE) C C PURPOSE--WRITE OUT THE LINE CURRENTLY IN C THE 240-CHARACTER VARIABLE ICNEWL C (WHICH CONSISTS OF NCNEWL CHARACTERS, C AND HAS LINE NUMBER ILINE ). C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICNEWL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDWR' ISUBN2='LI ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDWRLI') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDWRLI') 51 FORMAT('***** AT THE BEGINNING OF EDNEAT--') WRITE(ICOUT,52)NCNEWL,ILINE CALL EDWRST('EDWRLI') 52 FORMAT('NCNEWL,ILINE = ',2I8) WRITE(ICOUT,53)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDWRLI') 53 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** WRITE OUT THE CHARACTER VARIABLE ** C **************************************** C DO1100I=1,240 ICOUT(I:I)=ICNEWL(I:I) 1100 CONTINUE NCOUT=NCNEWL ILOUT=ILINE CALL EDWRST('EDWRLI') C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDWRLI') WRITE(ICOUT,9011) CALL EDWRST('EDWRLI') 9011 FORMAT('***** AT THE END OF EDNEAT--') WRITE(ICOUT,9012)NCOUT,ILOUT CALL EDWRST('EDWRLI') 9012 FORMAT('NCOUT,ILOUT = ',2I8) WRITE(ICOUT,9013)(ICOUT(I:I),I=1,100) CALL EDWRST('EDWRLI') 9013 FORMAT('(ICOUT(I:I),I=1,100) = ',100A1) 9090 CONTINUE C RETURN END SUBROUTINE EDWRWF(ID) C C PURPOSE--DUMP (= WRITE) WORKSPACE TO A FILE C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C C--------------------------------------------------------------------- C CHARACTER*80 IFILE CHARACTER*12 ISTAT CHARACTER*12 IFORM CHARACTER*12 IACCES CHARACTER*12 IREWR CHARACTER*4 ISUBN0 CHARACTER*4 IERRFI CHARACTER*4 IENDFI CHARACTER*4 IREWIN C CHARACTER*4 ID C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDWR' ISUBN2='WF ' C ISUBN0='WRWF' C IFOUND='YES' IERROR='NO' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'WRWF')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDWRWF') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDWRWF') 51 FORMAT('*****AT THE BEGINNING OF EDWRWF--') WRITE(ICOUT,52)ID CALL EDWRST('EDWRWF') 52 FORMAT('ID = ',A4) WRITE(ICOUT,999) CALL EDWRST('EDWRWF') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ************************** C ** STEP 1-- ** C ** COPY OVER VARIABLES ** C ************************** C ISTEPN='1' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'WRWF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(ID.EQ.'ORIG')GOTO1110 IF(ID.EQ.'SAVE')GOTO1120 GOTO1120 C 1110 CONTINUE IOUNIT=IORINU IFILE=IORINA ISTAT=IORIST IFORM=IORIFO IACCES=IORIAC IREWR=IORIRW ISUBN0='WRWF' IERRFI='NO' GOTO1190 C 1120 CONTINUE IOUNIT=ISAVNU IFILE=ISAVNA ISTAT=ISAVST IFORM=ISAVFO IACCES=ISAVAC IREWR=ISAVRW ISUBN0='WRWF' IERRFI='NO' GOTO1190 C 1190 CONTINUE IF(IBUGFI.EQ.'OFF')GOTO1199 WRITE(ICOUT,1193)IFILE CALL EDWRST('EDWRWF') 1193 FORMAT('IFILE = ',A80) WRITE(ICOUT,1194)IOUNIT CALL EDWRST('EDWRWF') 1194 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,1195)ISTAT CALL EDWRST('EDWRWF') 1195 FORMAT('ISTAT = ',A12) WRITE(ICOUT,1196)NUMLIN,NUMCHA CALL EDWRST('EDWRWF') 1196 FORMAT('NUMLIN,NUMCHA = ',2I8) 1199 CONTINUE C C ********************* C ** STEP 2-- ** C ** OPEN THE FILE ** C ********************* C ISTEPN='2' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'WRWF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS=ISTAT,FORM='FORMATTED') CCCCC OPEN(UNIT=IOUNIT,FILE=IFILE,STATUS='NEW',FORM='FORMATTED') CALL EDOPFI(IOUNIT,IFILE,ISTAT,IFORM,IACCES,IREWR,ISUBN0,IERRFI) C C **************************************************** C ** STEP 3-- ** C ** WRITE WORKSPACE OUT TO THE FILE ** C **************************************************** C ISTEPN='3' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'WRWF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IF(NUMLIN.LE.0)GOTO1390 C DO1300ILINE=1,NUMLIN IROW=IPOINT(ILINE) J1=ILOCC1(IROW) N1=NUMCPL(IROW) J2=J1+(N1-1) WRITE(IOUNIT,1305)(ICHA(J),J=J1,J2) 1305 FORMAT(238A1) 1300 CONTINUE C 1390 CONTINUE C C ********************** C ** STEP 4-- ** C ** CLOSE THE FILE ** C ********************** C ISTEPN='4' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'WRWF') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C CCCCC ENDFILE IOUNIT CCCCC REWIND IOUNIT CCCCC CLOSE(UNIT=IOUNIT) IENDFI='ON' IREWIN='ON' CALL EDCLFI(IOUNIT,IENDFI,IREWIN) C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'WRWF')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDWRWF') WRITE(ICOUT,9011) CALL EDWRST('EDWRWF') 9011 FORMAT('*****AT THE END OF EDWRWF--') WRITE(ICOUT,9012)ID CALL EDWRST('EDWRWF') 9012 FORMAT('ID = ',A4) WRITE(ICOUT,9013)IFILE CALL EDWRST('EDWRWF') 9013 FORMAT('IFILE = ',A80) WRITE(ICOUT,9014)IOUNIT CALL EDWRST('EDWRWF') 9014 FORMAT('IOUNIT = ',I8) WRITE(ICOUT,9015)ISTAT CALL EDWRST('EDWRWF') 9015 FORMAT('ISTAT = ',A12) WRITE(ICOUT,9016)NUMLIN,NUMCHA CALL EDWRST('EDWRWF') 9016 FORMAT('NUMLIN,NUMCHA = ',2I8) WRITE(ICOUT,999) CALL EDWRST('EDWRWF') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDX C C PURPOSE--DETERMINE WHICH HELD COMMAND C WILL BE EXECUTED AND SET A SWITCH C SO THAT IT WILL BE EXECUTED. C C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C ORIGINAL VERSION--JANUARY 1985. C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDX ' ISUBN2=' ' C IFOUND='YES' IERROR='NO' C IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CALL')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDX ') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDX ') 51 FORMAT('***** AT THE BEGINNING OF EDX--') WRITE(ICOUT,52)ICXQT,IXQT CALL EDWRST('EDX ') 52 FORMAT('ICXQT,IXQT = ',A4,I8) WRITE(ICOUT,999) CALL EDWRST('EDX ') IF(IBUGT1.EQ.'ON')CALL EDTRA1 90 CONTINUE C C ********************************* C ** STEP 1-- ** C ** DETERMINE WHICH HELD LINE ** C ** IS TO BE EXECUTED. ** C ********************************* C ISTEPN='1' IF(IBUGE2.EQ.'ON'.OR.ISUBRO.EQ.'X') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C IXQT=1 C IF(NUMARG.LE.0)GOTO1100 GOTO1110 C 1100 CONTINUE GOTO1190 C 1110 CONTINUE IF(IARGT(1).EQ.'NUMB')IXQT=IARG(1) GOTO1190 C 1190 CONTINUE C C ************************************** C ** STEP 2-- ** C ** SET THE EXECUTE SWITCH TO ON ** C ************************************** C ISTEPN='2' IF(IBUGFI.EQ.'ON'.OR.ISUBRO.EQ.'CALL') 1CALL EDTRA3(ISTEPN,ISUBN1,ISUBN2) C ICXQT='ON' C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGFI.EQ.'OFF'.AND.ISUBRO.NE.'CALL')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDX ') WRITE(ICOUT,9011) CALL EDWRST('EDX ') 9011 FORMAT('***** AT THE END OF EDX--') WRITE(ICOUT,9013)ICXQT,IXQT CALL EDWRST('EDX ') 9013 FORMAT('ICXQT,IXQT = ',A4,I8) WRITE(ICOUT,999) CALL EDWRST('EDX ') IF(IBUGT2.EQ.'ON')CALL EDTRA2 9090 CONTINUE C RETURN END SUBROUTINE EDZERO(ICNEWL,NCNEWL) C C PURPOSE--BLANK-OUT THE 240-CHAREACTER VARIABLE ICNEWL C AND SET NCNEWL TO ZERO. C WRITTEN BY--JAMES J. FILLIBEN C LANGUAGE--ANSI FORTRAN (1977) C VERSION NUMBER--86.1 C ORIGINAL VERSION--MAY 1986. C C--------------------------------------------------------------------- C CHARACTER*240 ICNEWL C CHARACTER*4 ISUBN1 CHARACTER*4 ISUBN2 CCCCC CHARACTER*4 ISTEPN C C-----COMMON VARIABLES (EDITING)----------------------------------------------- C INCLUDE 'DPCOPA.INC' INCLUDE 'EDCOMM.INC' C C-----COMMON VARIABLES (GENERAL)----------------------------------------------- C COMMON /MACH/IRD,IPR,CPUMIN,CPUMAX,NUMBPC,NUMCPW,NUMBPW C C-----START POINT----------------------------------------------------- C ISUBN1='EDZE' ISUBN2='RO ' C IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO90 WRITE(ICOUT,999) CALL EDWRST('EDZERO') 999 FORMAT(1X) WRITE(ICOUT,51) CALL EDWRST('EDZERO') 51 FORMAT('***** AT THE BEGINNING OF EDZERO--') WRITE(ICOUT,52)NCNEWL CALL EDWRST('EDZERO') 52 FORMAT('NCNEWL = ',I8) WRITE(ICOUT,53)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDZERO') 53 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) 90 CONTINUE C C **************************************** C ** STEP 11-- ** C ** BLANK-OUT THE CHARACTER VARIABLE ** C ** ZERO -OUT THE INTEGER ** C **************************************** C DO1100I=1,240 ICNEWL(I:I)=' ' 1100 CONTINUE NCNEWL=0 C C ***************** C ** STEP 90-- ** C ** EXIT ** C ***************** C 9000 CONTINUE IF(IBUGE2.EQ.'OFF'.AND.ISUBRO.NE.'INSE')GOTO9090 WRITE(ICOUT,999) CALL EDWRST('EDZERO') WRITE(ICOUT,9011) CALL EDWRST('EDZERO') 9011 FORMAT('***** AT THE END OF EDZERO--') WRITE(ICOUT,9012)NCNEWL CALL EDWRST('EDZERO') 9012 FORMAT('NCNEWL = ',I8) WRITE(ICOUT,9013)(ICNEWL(I:I),I=1,100) CALL EDWRST('EDZERO') 9013 FORMAT('(ICNEWL(I:I),I=1,100) = ',100A1) 9090 CONTINUE C RETURN END