PROGRAM SETMDC 01 00010 01 00020 ************************************************************************01 00030 * *01 00040 * PROGRAM SETMDC *01 00050 * *01 00060 * VERSIONS 1 AND 2 WERE FOR INTERNAL DEVELOPMENT. *01 00070 * VERSION 3( 1) AS OF 7-DEC-77. FIRST DISTRIBUTION LEVEL. *01 00080 * VERSION 3( 2) AS OF 2-AUG-78. MAKE FILE 22 SEQOUT (DEC). *01 00090 * VERSION 3( 3) AS OF 7-FEB-80. ADD CLOSE + ERR= (DEC). *01 00100 * VERSION 4( 4) AS OF 16-JUN-81. USE DIALOG=LINE (DEC). *01 00110 * VERSION 5( 5) AS OF 11-AUG-82. DON'T CHANGE COLUMNS 73-80. *01 00120 * VERSION 6( 6) AS OF 6-DEC-84. CONVERT TO FORTRAN-77. *01 00130 * VERSION 6( 7) AS OF 6-DEC-84. ADD VAX AS MACHINE TYPE. *01 00140 * VERSION 6(10) AS OF 19-AUG-86. (VAX)OPEN STATEMENT. *01 00150 * VERSION 6(11) AS OF 2-DEC-86. ADD IbmPC MDC. NO BLANKS ADDED *01 00160 * VERSION 6(12) AS OF 30-SEP-87. Made selfcontained. (lenstr added)*01 00170 * VERSION 6(13) AS OF 2-NOV-87. VAX mdc OPEN with READONLY for inp*01 00180 * VERSION 6(14) AS OF AUG-89. ANS code *01 00190 * VERSION 6(15) as of 3-Aug-93. Finished typing all variables 01 00200 * Replaced Lenstr with latest from 01 00210 * NSDFLIB 01 00220 * *01 00230 * REFER ALL COMMENTS AND INQUIRIES TO *01 00240 * NATIONAL NUCLEAR DATA CENTER *01 00250 * BUILDING 197D *01 00260 * BROOKHAVEN NATIONAL LABORATORY *01 00270 * UPTON, NEW YORK 11973 *01 00280 * TELEPHONE 516-282-2901 COMM *01 00290 * 666-2901 FTS *01 00300 * *01 00310 ************************************************************************01 00320 01 00330 * THIS PROGRAM, AND ALL OTHER DISTRIBUTED SOFTWARE IN THIS PACKAGE, 01 00340 * HAS BEEN WRITTEN SO AS TO BE AS MACHINE INDEPENDENT AS POSSIBLE 01 00350 * (AT LEAST IN SO FAR AS CDC, VAX, IBM PC AND IBM 01 00360 * COMPUTERS). THERE ARE FEATURES OF THE FORTRAN LANGUAGE WHICH ARE 01 00370 * NOT SUPPORTED BY ALL VENDORS. AS A RESULT, SOME SECTIONS OF THE 01 00380 * CODE HAD TO BE WRITTEN IN A MACHINE DEPENDENT MANNER. IN SUCH 01 00390 * CASES THE VARIANT CODES HAVE ALL BEEN INCLUDED WITH THE 01 00400 * INAPPROPRIATE CODE STORED AS COMMENTS. THE FORMAT OF THE MACHINE 01 00410 * DEPENDENT CODE SECTIONS IS DESCRIBED BELOW. PROGRAM SETMDC WILL 01 00420 * CONVERT PROGRAMS FROM ONE CONFIGURATION TO ANOTHER SO AS TO MAKE 01 00430 * MACHINE PORTABILITY AS SIMPLE AS POSSIBLE. 01 00440 * 01 00450 * ALL MACHINE DEPENDENT CODE SECTIONS MUST HAVE THE SAME FORMAT. 01 00460 * EACH SECTION IS HEADED BY: 01 00470 * 01 00480 * C+++MDC+++ 01 00490 * 01 00500 * AND TRAILED BY: 01 00510 * 01 00520 * C---MDC--- 01 00530 * 01 00540 * CODE FOR ANY ONE MACHINE IS HEADED BY ONE OF: 01 00550 * 01 00560 * C...CDC (SCOPE, NOS) 01 00570 * C...IBM (MVS, OS, DOS, CMS) 01 00580 * C...VAX (VMS) 01 00590 * C...ANS (ANSI FORTRAN 77) 01 00600 * C...IPC (IBM PC) 01 00610 * 01 00620 * CODE FOR ANY TWO OR MORE MACHINES IS HEADED BY A LIST OF THE 01 00630 * MACHINES, SEPARATED BY COMMAS, BLANKS AFTER COMMAS OPTIONAL. 01 00640 * FOR EXAMPLE: 01 00650 * 01 00660 * C...CDC, IBM, VAX 01 00670 * C...IBM, VAX 01 00680 * 01 00690 * ALL INAPPROPRIATE CODE IS SHIFTED RIGHT BY TWO COLUMNS AND IS 01 00700 * PRECEDED BY 'C/' IN COLUMNS 1 AND 2. THEREFORE, ALL MACHINE 01 00710 * DEPENDENT CODE SHOULD FIT IN 70 COLUMNS SO THAT SHIFTING WILL NOT 01 00720 * SHIFT OUT GOOD CODE. 01 00730 * 01 00740 * SEE PROGRAM CODE SETMDC FOR EXAMPLES. 01 00750 01 00760 * LOCAL VARIABLES. 01 00770 01 00780 CHARACTER*80 FILE 01 00790 CHARACTER*3 MACH 01 00800 INTEGER K 01 00810 CHARACTER*72 CARD 01 00820 CHARACTER*8 SEQ 01 00830 LOGICAL MDC 01 00840 LOGICAL CLEAR 01 00850 CHARACTER*72 KARD 01 00860 Integer i 01 00870 C 01 00880 Integer Lenstr 01 00890 External Lenstr 01 00900 C 01 00910 * FORMAT STATEMENTS. 01 00920 C+++MDC+++ 01 00930 C...VAX 01 00940 C/ 1 FORMAT(A$) 01 00950 C...ANS,IPC 01 00960 1 FORMAT(A) 01 00970 C---MDC--- 01 00980 2 FORMAT(A) 01 00990 3 FORMAT(2A) 01 01000 01 01010 * WRITE OUT PROGRAM HEADER. 01 01020 01 01030 WRITE (UNIT=6, FMT=*) 01 01040 WRITE (UNIT=6, FMT=*) 01 01050 + 'PROGRAM S E T M D C VERSION 6(15) AS OF 3-Aug-93.' 01 01060 01 01070 * OPEN INPUT AND OUTPUT FILES. 01 01080 01 01090 C+++MDC+++ 01 01100 C...ANS 01 01110 OPEN (UNIT=21, STATUS='OLD') 01 01120 OPEN (UNIT=22, STATUS='NEW') 01 01130 C...IPC 01 01140 C/ 5 WRITE (UNIT=6, FMT=*) 01 01150 C/ WRITE (UNIT=6, FMT=1) ' ENTER INPUT FILE NAME: ' 01 01160 C/ READ (UNIT=5, FMT=2) FILE 01 01170 C/ OPEN (UNIT=21, FILE=FILE, STATUS='OLD', ERR=99) 01 01180 C/ WRITE (UNIT=6, FMT=1) ' ENTER OUTPUT FILE NAME: ' 01 01190 C/ READ (UNIT=5, FMT=2) FILE 01 01200 C/ OPEN (UNIT=22, FILE=FILE, STATUS='NEW') 01 01210 C/ WRITE (UNIT=6, FMT=1) ' MACHINE (ANS, VAX, IBM, etc): ' 01 01220 C...VAX 01 01230 C/ 5 WRITE (UNIT=6, FMT=*) 01 01240 C/ WRITE (UNIT=6, FMT=1) ' ENTER INPUT FILE NAME: ' 01 01250 C/ READ (UNIT=5, FMT=2) FILE 01 01260 C/ OPEN (UNIT=21, FILE=FILE, STATUS='OLD', ERR=99,READONLY) 01 01270 C/ WRITE (UNIT=6, FMT=1) ' ENTER OUTPUT FILE NAME: ' 01 01280 C/ READ (UNIT=5, FMT=2) FILE 01 01290 C/ OPEN (UNIT=22, FILE=FILE, STATUS='NEW', 01 01300 C/ 1 CARRIAGECONTROL='LIST') 01 01310 C/ WRITE (UNIT=6, FMT=1) ' MACHINE (IBM, VAX, ANS, IPC, etc): ' 01 01320 C---MDC--- 01 01330 01 01340 * OBTAIN MACHINE TYPE. 01 01350 01 01360 READ (UNIT=5, FMT=2) MACH 01 01370 WRITE (UNIT=6, FMT=*) 01 01380 01 01390 * SET CARD COUNT TO ZERO. 01 01400 01 01410 K = 0 01 01420 MDC = .FALSE. 01 01430 01 01440 * READ NEXT INPUT CARD AND PROCESS IT. 01 01450 01 01460 10 READ (UNIT=21, FMT=3, END=20) CARD, SEQ 01 01470 K = K + 1 01 01480 IF (MDC) THEN 01 01490 IF (CARD(1:4) .EQ. 'C---') THEN 01 01500 MDC = .FALSE. 01 01510 ELSE IF (CARD(1:4) .EQ. 'C...') THEN 01 01520 CLEAR = .FALSE. 01 01530 IF (INDEX(CARD, MACH) .GT. 0) CLEAR = .TRUE. 01 01540 ELSE 01 01550 KARD = CARD 01 01560 IF (CLEAR .AND. CARD(1:2) .EQ. 'C/') 01 01570 + CARD = KARD(3:72) // ' ' 01 01580 IF (.NOT. CLEAR .AND. CARD(1:2) .NE. 'C/') 01 01590 + CARD = 'C/' // KARD(1:70) 01 01600 END IF 01 01610 ELSE 01 01620 IF (CARD(1:4) .EQ. 'C+++') MDC = .TRUE. 01 01630 END IF 01 01640 C 01 01650 C if no sequence no. write only nonblank part of the code 01 01660 c 01 01670 IF(SEQ.EQ.' ') THEN 01 01680 I=LENSTR(CARD) 01 01690 IF(I.EQ.0) I=1 01 01700 WRITE(UNIT=22,FMT=2) CARD(1:I) 01 01710 ELSE 01 01720 WRITE (UNIT=22, FMT=3) CARD, SEQ 01 01730 ENDIF 01 01740 GOTO 10 01 01750 01 01760 * CLOSE FILES. 01 01770 01 01780 20 CLOSE (UNIT=21) 01 01790 CLOSE (UNIT=22) 01 01800 01 01810 * WRITE OUT FILE STATISTICS. 01 01820 01 01830 WRITE (UNIT=6, FMT=*) K, ' CARDS HAVE BEEN PROCESSED.' 01 01840 01 01850 * FOR INTERACTIVE MACHINES, REPEAT IF NEEDED. 01 01860 01 01870 C+++MDC+++ 01 01880 C... VAX, IPC 01 01890 C/ GOTO 5 01 01900 C---MDC--- 01 01910 99 END 01 01920 02 00010 INTEGER FUNCTION LENSTR (STRING) 02 00020 02 00030 ************************************************************************02 00040 * Copied from NSDFLIB library (03-Aug-1992) *02 00050 * COMPUTE LENGTH OF TEXT WITHIN STRING EXCLUSIVE OF TRAILING BLANK *02 00060 * OR NULL CHARACTERS (I.E., VARIABLE LENGTH STRINGS WHICH EXIST *02 00070 * WITHIN A FIXED LENGTH STRING AREA). *02 00080 * *02 00090 * *02 00100 ************************************************************************02 00110 02 00120 ************************************************************************02 00130 * *02 00140 * DATA SECTION. *02 00150 * *02 00160 ************************************************************************02 00170 02 00180 * FUNCTION ARGUMENTS. 02 00190 02 00200 CHARACTER*(*) STRING 02 00210 02 00220 * LOCAL VARIABLES. 02 00230 02 00240 INTEGER L 02 00250 02 00260 ************************************************************************02 00270 * *02 00280 * PROCEDURE SECTION. *02 00290 * *02 00300 ************************************************************************02 00310 02 00320 DO 10 L = LEN(STRING), 1, -1 02 00330 IF (STRING(L:L) .NE. ' ' .AND. 02 00340 1 ICHAR(STRING(L:L)).NE.0) THEN 02 00350 LENSTR = L 02 00360 RETURN 02 00370 ENDIF 02 00380 10 CONTINUE 02 00390 LENSTR = 0 02 00400 END 02 00410