Trailing-Edge
-
PDP-10 Archives
-
decuslib20-05
-
decus/20-0137/freq/freq.for
There is 1 other file named freq.for in the archive. Click here to see a list.
C WESTERN MICHIGAN UNIVERSITY
C FREQ.FRE (FILENAME ON LIBRARY DECTAPE)
C FREQ, 1.4.3 (CALLING NAME, SUBLST#)
C F, I, AND A-TYPE FREQUENCY COUNT PROGRAM
C PROGRAMMED AT WMU BY B. HOUCHARD, LATER MODIFIED
C BY D. C. SCHULZ AND M. T. O'BRYAN
C BNKLIB.FOR PROGRAMS USED: GETFRI, BNKNAM,VARLST, INFO,
C SELECT, PAGE, IO, GETID, GETMOD
C LIBRARY DECTAPE PROGS. USED: USAGE.MAC
C FORWMU PROGS. USED: TTYPTY, ALLCOR, GES, EXIST
C DEVCHR, GETPPN, EXISTS, RUNUUO, PRINTS, JOBNUM
C INTERNAL SUBR. USED: MAINL, OPTION, COUNT,
C PACK, SFLO, SALP, SFIX, SIZE
C ABOVE COMMENTS AND RIGHT ADJUSTED COMMENTS PUT IN BY WG
C
c variable DEVTMP changed from DSKC to DSK for DECUS conversion
c to DEC-20.
c Paul T. Robinson, Wesleyan Univ., Oct 1980
C
C THIS IS PART OF THE BANK SYSTEM DESIGNED BY RICHARD A. HOUCHARD.
C IT ACCEPTS DATA FROM A STRUCTURED DATA BANK FILE, THE TELETYPE
C AS WELL AS AN UNSTRUCTURED DATA FILE. A, I, F-TYPE VARIABLES
C ARE EASILY HANDLED. OPTIONS EXIST TO ENTER VARIABLE NAMES,
C TO SUBSET THE DATA BY SPECIFYING CERTAIN CRITERIA, OR TO ENTER
C USER'S OWN FORMAT. MISSING DATA DEFINED IN A DATA BANK WILL BE
C TREATED AS MISSING. A SHORT DESCRIPTION WILL TYPE OUT IN
C RESPONSE TO "HELP" FROM THE USER IN MAJOR KEY PLACES.
C
C
C LOADING COMMAND:
C .LOAD %'SEG:LOW' FREQ, BNKLIB/LIB, REL:APLB10/LIB,
C AGE [400,400], SYS:FORLIB/LIB
C
C
C SUBROUTINES USED:
C
C TTYPTY (*) DETERMINE IF JOB IS ON TELETYPE OR PSEUDO-
C TELETYPE
C
C USAGE (*) COUNTER FOR LIBRARY PROGRAMS USAGE
C
C IO INPUT/OUTPUT SUBROUTINE
C
C GETID HEADER SUBROUTINE
C
C GETFR1 FORMAT SUBROUTINE
C
C GETMOD DETERMINE MODES OF VARIABLES FROM THE FORMAT
C
C OPTION DETERMINE WHICH OPTIONS TO USE
C
C BNKNAM DETERMINE WHICH VARIABLES FROM THE DATA BANK
C TO BE USED
C
C VARLST OBTAIN VARIABLE NAMES OR NUMBERS FROM NON-DATA
C BANK INPUT
C
C SELECT ALLOWS PROGRAM TO CONSIDER ONLY THOSE OBSERVA-
C TIONS MEETING USER SPECIFIED CRITERIA
C
C INFO WRITE A HEADER PAGE FOR NON-TTY OUTPUT
C
C ALLCOR (*) TO ALLOCATE CORE DYNAMICALLY
C
C MAINL MAIN SUBROUTINE FOR THE PROGRAM
C
C GES (*) SUBROUTINE TO READ IN ONE LINE OF INFORMATION
C
C EXIST (*) TO DETERMINE IF A FILE ALREADY EXISTS IN THE
C USER'S AREA
C
C PACK USED IN DATA BANK FILE ONLY; IT PACKS THE DATA
C VECTOR WITH VALID DATA
C
C COUNT SORTS THE SYMBOLS IN ASCENDING ORDER AND
C COUNTS THEIR FREQUENCY OF OCCURENCES
C
C SIZE USED IN THE OUTPUT; IT DETERMINES THE NUMBER
C OF SYMBOLS PER COLUMN
C
C SALP OUTPUT SUBROUTINE FOR A-TYPE VARIABLES
C
C SFIX OUTPUT SUBROUTINE FOR I-TYPE VARIABLES
C
C SFLO OUTPUT SUBROUTINE FOR F-TYPE VARIABLES
C
C PAGE OUTPUTS PAGE NUMBER AND HEADER
C
C (*) MACRO SUBROUTINE
C
C
C***********************************************************************
C***********************************************************************
C
C
DIMENSION SPACE(1),IDUM(125)
C---------------SUBR. GETID, BNKNAM, SELECT, INFO, PAGE, VARLST
C--------------- (BNKLIB.FOR), AND SUBR. MAINL, OPTION, SFLO,
C--------------- SALP, SFIX, SIZE SHARE COMMON /IOBLK/
C--------------- IDEVO, NAMO, IPROG, IOUT, INP, IDEVI, NAMI,
C--------------- IPROJ ARE IN IO SUBR. ARG.LIST
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
C---------------SUBR IO SHARES COMMON /IOB/
COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
. ,NOUT
C---------------SUBR. GETMOD, BNKNAM, SELECT, INFO, VARLST,
C--------------- COMMON /SBNK/
C---------------SUBR. BNKNAM (P. 14 OF BNKLIB.FOR) SHOWS ITEMP(5000)
C--------------- ALLOCATED TO NOGOOD, IV, NOMAT, NAME, NUM, MODE
COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
C---------------SUBR. GETFR1 SHARES COMMON /SGETFR/
COMMON/SGETFR/ISTD,ITYPE
C COMMON/FMT/NOTF(48) ! MTO: EXPANDED 11-AUG-76 AS PER REQUEST
C---------------SUBR. INFO SHARES COMMON /FMT/
COMMON/FMT/NOTF(80)
C---------------SUBR OPTION SHARES COMMON /SOPT/
COMMON/SOPT/IOPT(4),MAXOPT,DEVTMP,DEVMOD
C---------------SUBR GETID, INFO, PAGE SHARE COMMON /SID/
COMMON/SID/ID(16),ISTOP
INTEGER OFFSET
DOUBLE PRECISION NAMI,NAMO,DEVNAM
EQUIVALENCE (ITEMP,IDUM)
C
C**********************************************************************
C
C DEVICES USED:
C
C IDLG--DEVICE USED TO COMMUNICATE WITH USER
C IT IS ALWAYS SET TO -1
C
C ICC---DEVICE USED TO ACCEPT USER'S RESPONSE
C IT IS ALWAYS SET TO -4
C
C INP---DEVICE USED TO READ DATA
C ITS LOGICAL NUMBER IS DETERMINED BY IO SUBROUTINE
C
C IOUT--DEVICE TO WRITE OUT THE RESULT
C ITS LOGICAL NUMBER IS DETERMINED BY THE IO SUBROUTINE
C
C
C
C AUXILIARY DEVICES USED IN SUBROUTINE MAINL TO WRITE TEMPORARY
C FILES:
C
C IDSK--IT IS ALWAYS SET TO 20
C LDSK--IT IS ALWAYS SET TO 1
C DEVMOD--MODE IN WHICH TEMPORARY FILES ARE WRIITEN
C DEVTMP--STRUCTURE WHERE TEMPORARY FILES ARE WRITTEN
C
C***********************************************************************
C
IDLG=-1
ICC=-4
INP=2
IOUT=3
IPAGCT=0
MAXPAG=58
OFFSET=0
C---------------SEE SUBR.MAINL ST. 38, ST. 31 + 2
DEVMOD='DUMP'
c devtmp changed from DSKC to DSK for DEC-20 conversion
DEVTMP='DSK'
C
C
ITYPE=3
WRITE(IDLG,9977)
9977 FORMAT('-*** W.M.U. FREQUENCY COUNT PROGRAM V2 ***'//)
C CALL USAGE('FREQ')
C---------------TTYPTY RETURNS ZERO - TTY JOB, MINUS ONE BATCH JOB.
CALL TTYPTY(ICODE)
C---------------1,0, IOUT, INP ARE INPUT. OTHER ARGS. ARE RETURNED.
C--------------- LFBR, IRTBR, IALT ARE RETURNED THRU COMMON /IOB/
CALL IO(1,IOUT,DEVNAM,IDEVO,NAMO,IPROJ,IPROG,IBNK)
1 CALL IO(0,INP,DEVNAM,IDEVI,NAMI,IPROJ,IPROG,IBNK)
IDEVO=NOUT
IPAGE=0
IF(IDEVO.EQ.'TTY') IPAGE=-999999
10 CALL OPTION
DO 110 I=1,16
110 ID(I)=' '
ISTOP=0
C---------------IOPT(I) RETURNED BY OPTION THRU COMMON /SOPT/
IF (IOPT(2).EQ.1) CALL GETID
GO TO (21,12) IBNK+1
C
C**********************************************************************
C
C FOR DATA BANK ONLY
C
C (1) READ HEADER RECORD IN THE DATA BANK:
C NVBNK--NUMBER OF VARIABLES IN THE BANK
C NOBNK--NUMBER OF OBSERVATIONS IN THE BANK
C NDBNK--DATE THE BANK WAS CREATED
C NPBNK--PROJ-PROG NUMBER THAT CREATED THE BANK
C
C
C (2) DETERMINE WHICH VARIABLES FROM THE BANK TO BE USED
C
C************************************************************************
12 READ(INP#1) IDUM
IF (IDUM(8).EQ.'V2') GO TO 101
WRITE(IDLG,102)
102 FORMAT('-This BANK was created with an experimental version of
1 the BANK.'/' Please update the Bank by running BANKUP from area
2 220,220.'/' If you are not responsible for the BANK, contact
3 the owner and'/' ask him to run the updating program.'/)
CALL EXIT
101 NVBNK=IDUM(1)
NOBNK=IDUM(2)
NDBNK(1)=IDUM(4)
NDBNK(2)=IDUM(5)
NPBNK(1)=IDUM(6)
NPBNK(2)=IDUM(7)
C---------------N=NO. OF VAR. RETURNED; ITYPE=4 SENT. SEE SUBR. BNKNAM
C--------------- ST. 51 THRU 52 INCL.
100 CALL BNKNAM(4,N)
NOTF(1)='DATA'
NOTF(2)='BANK'
NOTF(3)='FORMA'
NOTF(4)='T'
C DO 103 I=5,48 ! MTO: 11-AUG-76
DO 103 I=5,80
103 NOTF(I)=' '
GO TO 30
C
C************************************************************************
C
C NON-DATA BANK ONLY
C
C (1) ACCEPTS VARIABLE NAMES AND DETERMINE HOW MANY VARIABLES
C TO BE USED OR ACCEPTS THE TOTAL NO OF VARS.
C
C (2) DETERMINE WHICH FORMAT TO USE AND OBTAIN THE MODES OF THE
C VARIABLES
C
C***********************************************************************
C
C---------------N= NO. OF VARS. RETURNED
21 CALL VARLST(N)
IF (IOPT(4).NE.1) ISTD=1
C---------------IOPT(4)=1 MEANS USER CHOSE FORMAT OPTION ITYPE=3 SENT
C--------------- TO GETFR1 THRU COMMON /SGETFR/ SEE ST. 9977-2.
C--------------- ITYPE=3 MEANS 'ENTER FORMAT ENCLOSED IN PARENTHESIS'
C--------------- WILL PRINT; ITYPE=0,1,2 MEANS IN ADDITION F,A, OR I
C--------------- 'TYPE ONLY' WILL PRINT. SEE GETFR1 ST. 100 AND 101.
C IF (IOPT(4).EQ.1) CALL GETFR1(IOPT(1),48,NOTF) ! MTO: 11-AUG-76
IF (IOPT(4).EQ.1) CALL GETFR1(IOPT(1),80,NOTF)
IF (ISTD.EQ.1) GO TO 24
C CALL GETMOD(N,240,NOTF) ! MTO: 11-AUG-76
CALL GETMOD(N,400,NOTF)
GO TO 30
24 NOTF(1)='(80A1'
NOTF(2)=')'
C DO 25 I=3,48 ! MTO: 11-AUG-76
DO 25 I=3,80
25 NOTF(I)=' '
C---------------HERE USER CHOSE 80A1 FORMAT; THEREFORE MODE=1 I.E.
C--------------- A FORMAT.
C---------------SUBR.BNKNAM(P.14 OF BNKLIB.FOR) SHOWS ITEMP(2601-3400)=
C--------------- NAME, ITEMP(3401-4200)=NUM, ITEMP(4201-5000)=MODE
DO 26 I=4201,4200+N
26 ITEMP(I)=1
C
C**********************************************************************
C ALLOCATE CORE
C**********************************************************************
C
30 MAX=4*N
CALL ALLCOR(MAX,IERR,OFFSET,SPACE(1))
C IF(OFFSET.NE.0) CALL LSCORE(SPACE(1),OFFSET)
C OFFSET=0
C CALL GTCORE(MAX,SPACE(1),OFFSET,IERR,1000)
IF(IERR) 32,31,32
32 WRITE(IDLG,310) N
310 FORMAT('-ERROR: Number of variables ',I6,' outside allowable
1 range, Try again'/)
IF (ICODE.LT.0) CALL EXIT
GO TO (21,100), IBNK+1
C
C
31 I1=OFFSET
I2=I1+N
I3=I2+N
I4=I3+N
CALL MAINL(N,SPACE(I1),SPACE(I2),SPACE(I3),SPACE(I4))
C
C***********************************************************************
C END OF ONE DATA SET AND GO TO 'INPUT?'
C***********************************************************************
C
WRITE(IDLG,40)
40 FORMAT('-')
GO TO 1
END
C---------------N IS INPUT, OTHER ARGS. ARE SPACES RESERVED BY DYN.
C--------------- ALLOC.
C---------------IOUT, IDEVO, IDEVI, IBNK INPUT THRU COMMON /IOBLK/
C---------------IPAGCT, IPAGE, MAXPAGE ARE INPUT THRU COMMON /IOB/
C---------------ITEMP, NOBNK, INPUT THRU COMMON /SBNK/
C---------------ISTD IS INPUT THRU COMMON /SGETFR/
C---------------NOTF INPUT THRU COMMON /FMT/
C---------------IOPT, MAXOPT, DEVTMP, DEVMOD, ARE INPUT THRU COMMON /SOPT/
C---------------SEE MAIN PROG. ST. 9977-5,6
C---------------ID, ISTOP INPUT THRU COMMON /SID/
C---------------NVAR, NCON, VALUE, NVAL, NOR INPUT THRU COMMON /SELEC/
C---------------NSEC MADE AVAIL. THRU COMMON /SELEC/ BY SUBR. MAINL
C---------------IST, MISS, M MADE AVAIL. THRU COMMON /SCOUNT/ BY
C--------------- SUBR. MAINL
C---------------IACT, ISIZE, MADE AVAIL. THRU COMMON /SYMSZ/ BY SUBR.
C--------------- MAINL
C---------------NOMIS MADE AVAIL. THRU COMMON /RPT/ BY SUBR. MAINL
C---------------SUBR. CALLED BY SUBR. MAINL: INFO(BNKLIB.FOR), PACK,
C--------------- COUNT
C---------------SIZE, SALP, SFIX, SFLO, PAGE, SELECT
C---------------FORWMU PROGS. USED BY SUBR. MAINL: EXIST (ST.65+1)
SUBROUTINE MAINL(N,NAME,NUM,MODE,NSIZE)
DIMENSION NAME(1),NUM(1),MODE(1),NSIZE(1),NTYPE(0/2),ISYM(600),
1 SYM(600),NCK(125),KOUNT(600),DUM(125),IDUM(125),PER(600),
2 MTYPE(0/2),X(3750),IX(3750),KKOUNT(125),IVALUE(20,20),IY(125),
3 Y(125),NAM1(2),NAM2(2)
C
C**********************************************************************
C
C MAIN SUBROUTINE OF THE PROGRAM
C
C N-------NUMBER OF VARIABLES
C NAME----VECTOR CONTAINING NAMES OF THE VARIABLES
C NUM-----VECTOR CONTAING THE VARIABLE NUMBERS
C MODE----VECTOR CONTAINING MODES OF THE VARIABLES
C NSIZE---VECTOR USED TO STORE SYMBOL SIZES
C NTYPE---0 FLOAT
C 1 ALPHA
C 2 FIXED
C ISYM----VECTOR CONTAINING THE SYMBOLS
C KOUNT---VECTOR CONTAINING THE COUNTERS
C PER-----VECTOR CONTAINING THE PERCENTAGES
C X-------DATA VECTOR
C
C**********************************************************************
C
DOUBLE PRECISION NFILE1,NFILE2
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
COMMON/SBNK/NVBNK,NOBNK,NDBNK(2),NPBNK(2),ITEMP(5000)
COMMON/SGETFR/ISTD,ITYPE
C COMMON/FMT/NOTF(48) ! MTO: 11-AUG-76
COMMON/FMT/NOTF(80)
COMMON/SOPT/IOPT(4),MAXOPT,DEVTMP,DEVMOD
COMMON/SID/ID(16),ISTOP
C---------------SUBR. INFO, PAGE(BNKLIB.FOR) SHARE COMMON /SINFO/
COMMON/SINFO/CALNAM,PROG(12)
C---------------SUBR. SELECT(BNKLIB.FOR)SHARES COMMON /SELEC/
COMMON/SELEC/NSEC,NVAR(20),NCON(20),VALUE(20,20),NVAL(20),
1 NOR(20)
C---------------SUBR COUNT IN CORL.COR SHARES COMMON /SCOUNT/
COMMON/SCOUNT/IST,M,INC,MISS
C---------------SUBR. COUNT, SFLO, SALP, SFIX, SIZE IN FREQ.FRE
C--------------- SHARE COMMON /SYMSZ/
COMMON/SYMSZ/ISIZE,IACT
C---------------SUBR. SIZE, SFIX, SALP, SFLO SHARE COMMON /SSIZE/
COMMON/SSIZE/IR,NTIMES,N1,MS(4),NS(5)
C---------------SUBR. SFLO, SALP, SFIX, SHARE COMMON /RPT/
COMMON/RPT/NOMIS
C
C
C
DOUBLE PRECISION NAMI,NAMO
EQUIVALENCE(ITEMP,ISYM,SYM),(ITEMP(601),KOUNT),(ITEMP(1201),
1 PER,X,IX),(ITEMP(2000),NCK),(MISS,AMISS),(IDUM,DUM),
2 (IVALUE,VALUE),(KKOUNT,IY,Y),(NFILE1,NAM1),(NFILE2,NAM2)
C
C
C
DATA CALNAM,PROG/'FREQ','F, I, A-TYPE FREQUENCY COUNT
1 PROGRAM ',4*' '/
DATA MTYPE/'F','A','I'/
C
C
C
IDSK=20
LDSK=1
C
C**********************************************************************
C TRANSFER THE NAMES, NUMBERS AND MODES INTO THE PROPER VECTORS
C**********************************************************************
C
DO 1 I=1,N
NAME(I)=ITEMP(2600+I)
NUM(I)=ITEMP(3400+I)
1 MODE(I)=ITEMP(4200+I)
C
C***********************************************************************
C WRITE OUT A HEADER PAGE FOR NON-TTY OUTPUT
C***********************************************************************
C
IF (IDEVO.EQ.'TTY') GO TO 101
IPAGCT=IPAGCT+1
C---------------PART OF HEADER PAGE PRINTING COMES FROM INFO THE
C--------------- REST COMES FROM THE NEXT 9 LINES.
CALL INFO(N)
DO 11 I=1,MAXOPT
IDUM(I)='NO'
IF(IOPT(I).NE.0) IDUM(I)='YES'
11 CONTINUE
WRITE(IOUT,100) (IDUM(I),I=1,MAXOPT),(NAME(I),I=1,N)
100 FORMAT('-',29X,'OPTIONS AVAILABLE:',2X,'SELECT',3X,'HEADER',3X,
. 'MISS',
. 3X,'FORMAT'/30X,'OPTIONS USED',5X,':',4X,A3,6X,A3,5X,A3,5X,A3/
. '-',29X,'VARIABLES USED:'//((37X,A5),9(2X,A5)))
C
C***********************************************************************
C SELECT OPTION
C***********************************************************************
C
101 IF (IOPT(1).NE.1) NSEC=0
IF (IOPT(1).EQ.1) CALL SELECT(N)
C
C
C
102 DO 10 I=0,2
10 NTYPE(I)=0
MISS="400000000000
C
C**********************************************************************
C COUNT NUMBER OF FLOATING, ALPHA AND FIXED VARIABLES
C**********************************************************************
C
25 DO 26 I=1,N
L=MODE(I)
26 NTYPE(L)=NTYPE(L)+1
C
C*****************************************************************
C OUTPUT HEADING AND VARIABLE TYPE
C***************************************************************
C
IF(IDEVO.EQ.'TTY') GOTO 12
WRITE(IOUT,335)
335 FORMAT('-')
DO 336 I=0,2
IF(NTYPE(I).EQ.0) GOTO 336
WRITE(IOUT,337) MTYPE(I),NTYPE(I)
337 FORMAT(30X,'NUMBER OF ',A1,'-TYPE VARIABLES =',I7)
WRITE(IDLG,37) MTYPE(I),NTYPE(I)
336 CONTINUE
GOTO 13
12 WRITE(IDLG,35) (ID(I),I=1,ISTOP)
35 FORMAT('-',16A5)
DO 36 I=0,2
IF (NTYPE(I).NE.0) WRITE(IDLG,37) MTYPE(I),NTYPE(I)
37 FORMAT(' Number of ',A1,'-type variables =',I7)
36 CONTINUE
13 GO TO (60,30),IBNK+1
C
C
30 NT=(NOBNK+124)/125
NTT=NT-1
WRITE(IDLG,600)
IF (NSEC.LE.0) GO TO 40
C
C
C
IF (NT.EQ.1) GO TO 310
NAM1(1)='00000'
NAM1(2)='.TMP'
C---------------NFILE1 INPUT, I RETURNED, I=0 FILE EXISTS AND NAME
C--------------- IS LEGAL, =-1 NAME IS ILLEGAL I=1 FILE
C--------------- NOT FOUND OR NOT READABLE.
380 CALL EXIST(NFILE1,I)
IF (I.EQ.1) GO TO 38
NAM1(1)=NAM1(1)+1
GO TO 380
38 OPEN (UNIT=LDSK,FILE=NFILE1,MODE=DEVMOD,ACCESS='SEQOUT',
. DEVICE=DEVTMP)
310 DO 31 I=1,NT
DO 32 J=1,125
NCK(J)=1
I1=0
IZ1=1
33 I1=I1+1
C---------------NSEC=# OF QUALIFIERS
IF (I1.GT.NSEC) GO TO 32
IZ=1+I+(NVAR(I1)-1)*NT
C---------------FIRST REC. IS HEADER AND WE START WITH IZ=2
C---------------IF VAR # OF QUALIFIER IS SAME AS VAR # OF PREVIOUS
C--------------- QUALIFIER, THEN BYPASS READ ST., OTHERWISE WE READ THE
C--------------- APPROPRIATE RECORD FROM RANDOM ACCESS FILE. NVAR(J1)=ID
C--------------- OF VAR. ASSOCIATED WITH J1TH QUALIFIER.
IF (IZ.EQ.IZ1) GO TO 330
C---------------READ BINARY UNFORMATTED
READ(INP#IZ) IDUM
IZ1=IZ
C---------------THERE ARE SIX POSSIBILITIES FOR EACH NCON(J1). THEY
C--------------- ARE: EQ, GT, GE, LT, LE, NE
330 J1=NCON(I1)
C---------------NVAL IS # OF VALS. AFTER = IN A SELECT OPTION FOR THE
C--------------- I1TH QUALIFIER
DO 340 I4=1,NVAL(I1)
GO TO (341,342,343,344,345,346), J1
C
C---------------VALUE (I,J) IS THE ITH VALUE FOR THE JTH QUALIFIER
C--------------- SEE EQUIVALENCE ST.
341 IF (IDUM(J).EQ.IVALUE(I4,I1)) 3410,3420
342 IF (IDUM(J).GT.IVALUE(I4,I1)) 3410,3420
343 IF (IDUM(J).GE.IVALUE(I4,I1)) 3410,3420
344 IF (IDUM(J).LT.IVALUE(I4,I1)) 3410,3420
345 IF (IDUM(J).LE.IVALUE(I4,I1)) 3410,3420
346 IF (IDUM(J).EQ.IVALUE(I4,I1)) GO TO 3420
C
C
3410 NCK(J)=0
3411 IF (I1.EQ.NSEC) GO TO 32
C---------------NOR IS LINE # OF 'OR' QUALIFIERS
IF (NOR(I1).NE.NOR(I1+1)) GO TO 33
I1=I1+1
GO TO 3411
C
C
3420 IF (I4.NE.NVAL(I1)) GO TO 340
IF (I1.NE.NSEC) GO TO 3421
3422 NCK(J)=1
GO TO 32
3421 IF (NOR(I1).NE.NOR(I1+1)) 3422,33
340 CONTINUE
C
32 CONTINUE
IF ((I.EQ.NT).AND.(I.EQ.1)) GO TO 40
WRITE(LDSK) NCK
31 CONTINUE
CLOSE (UNIT=LDSK)
OPEN (UNIT=LDSK,FILE=NFILE1,MODE=DEVMOD,ACCESS='SEQIN',
. DEVICE=DEVTMP)
C
C
C
C
40 INC=1
M1=NOBNK-NTT*125
DO 42 I=1,N
NOB=0
MT=125
IZ=1+(NUM(I)-1)*NT
ISIZE=0
IACT=0
IF (NT.LE.1) GO TO 47
DO 43 J=1,NTT
IST=1
J1=IZ+J
READ(INP#J1) IDUM
IF (NSEC.EQ.0) GO TO 430
READ(LDSK) NCK
C---------------PUT GOOD DATA INTO IY AS DETERMINED BY NCK.MT, IDUM, NCK
C--------------- SUPPLED M, IY RETURNED
CALL PACK(M,MT,IY,IDUM,NCK)
IF (M.LE.0) GO TO 43
NOB=NOB+M
C---------------SORTS AND COUNTS SYMBOLS. IY(SUPPLED BY PACK) INPUT,
C--------------- ISYM AND KOUNT RETURNED.
CALL COUNT(IY,ISYM,KOUNT)
GO TO 43
C
430 M=125
NOB=NOB+M
CALL COUNT(IDUM,ISYM,KOUNT)
43 CONTINUE
C
C
C
47 IST=1
MT=M1
J1=NT*NUM(I)+1
49 READ(INP#J1) IDUM
IF (NSEC.LE.0) GO TO 492
IF (NT.LE.1) GO TO 490
READ(LDSK) NCK
REWIND LDSK
C
490 CALL PACK(M,MT,IY,IDUM,NCK)
IF (M.LE.0) GO TO 460
NOB=NOB+M
CALL COUNT(IY,ISYM,KOUNT)
GO TO 460
492 M=MT
NOB=NOB+M
CALL COUNT(IDUM,ISYM,KOUNT)
C
C**********************************************************************
C PERCENTAGE
C**********************************************************************
C
460 IF (I.NE.1) GOTO 464
WRITE(IDLG,461) NOB
IF(IDEVO.NE.'TTY') WRITE(IOUT,4461) NOB
4461 FORMAT(30X,'NUMBER OF OBSERVATIONS USED=',I7/)
IF((NOB.GT.0).AND.(IDEVO.NE.'TTY')) CALL PAGE
461 FORMAT(' Number of observations used=',I7/)
464 IF (NOB.GT.0) GO TO 4610
IF ((NSEC.NE.0).AND.(NT.NE.1)) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
RETURN
4610 OBS=100./NOB
NOMIS=1
IF (ISYM(1).NE.MISS) GO TO 463
ISYM(1)='MISSI'
IF((ISIZE.GT.1).AND.(IOPT(3).EQ.1))OBS=100./(NOB-KOUNT(1))
NOMIS=2
IF(IOPT(3).EQ.1) NOMIS=3
463 DO 46 J=1,ISIZE
46 PER(J)=KOUNT(J)*OBS
S=' '
IF (ISIZE.GT.1) S='S'
IJMOD=MODE(I)
CALL SIZE(IJMOD)
IF(IPAGE+7.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,746) NAME(I),ISIZE,S
IF (IACT.LE.600) GOTO 4611
IF(IPAGE+4.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,747) NAME(I)
4611 GO TO (52,50,51), IJMOD+1
C
50 CALL SALP(ISYM,KOUNT,PER)
GO TO 53
C
51 CALL SFIX(ISYM,KOUNT,PER)
GO TO 53
C
52 CALL SFLO(SYM,KOUNT,PER)
C
C
C
53 IF(N.EQ.I) GOTO 42
IF(IPAGE+4.GT.MAXPAG) CALL PAGE
IF(IPAGE.EQ.2) GOTO 42
IPAGE=IPAGE+3
WRITE(IOUT,54)
54 FORMAT('-')
42 CONTINUE
IF ((NSEC.NE.0).AND.(NT.NE.1)) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
GO TO 90
C
C**********************************************************************
C NON-DATA BANK ONLY
C**********************************************************************
C
60 IF (IDEVI.EQ.'TTY') GO TO 61
WRITE(IDLG,600)
600 FORMAT('-Please wait, your data is being processed'//)
GO TO 612
61 WRITE(IDLG,610)
610 FORMAT('-ENTER DATA')
IF (ISTD.EQ.1) WRITE(IDLG,611)
611 FORMAT(' Format assumed: (80A1)')
C
C
C
612 NP=1
IS=1
NT=3750/N
ISIZE=0
IACT=0
NOB=0
NOBS=0
INC=N
DO 613 I=1,N
613 NSIZE(I)=0
630 NTT=0
DO 63 I=1,NT
I1=(I-1)*N+1
I2=I*N
631 READ(INP,NOTF,ERR=632,END=64) (IX(JJ),JJ=I1,I2)
GO TO 633
632 JJ=NOB+1
WRITE(IDLG,63200) JJ
63200 FORMAT('-ERROR: Illegal character in observation:',I7/
1 9X,'Program proceeds ignoring the observation'///)
GO TO 631
C
633 NOB=NOB+1
IF (NSEC.LE.0) GO TO 6310
J=0
IA=1
C---------------SEE COMMENT FOR ST. 33+1 THRU ST. 3411+1 FOR
C--------------- NSEC, NCON(J), NVAL(J), IVALUE(I,J), NOR(J) AND
C--------------- RELATED INFO.
6300 J=J+1
IF (J.GT.NSEC) GO TO 6320
JJ=I1+NVAR(J)-1
J2=NCON(J)
DO 6319 I3=1,NVAL(J)
GO TO (6301,6302,6303,6304,6305,6306), J2
C
6301 IF (IX(JJ).EQ.IVALUE(I3,J)) 6311,6312
6302 IF (IX(JJ).GT.IVALUE(I3,J)) 6311,6312
6303 IF (IX(JJ).GE.IVALUE(I3,J)) 6311,6312
6304 IF (IX(JJ).LT.IVALUE(I3,J)) 6311,6312
6305 IF (IX(JJ).LE.IVALUE(I3,J)) 6311,6312
6306 IF (IX(JJ).EQ.IVALUE(I3,J))GO TO 6312
C
C
6311 IA=0
63110 IF (J.EQ.NSEC) GO TO 6320
IF (NOR(J).NE.NOR(J+1)) GO TO 6300
J=J+1
GO TO 63110
C
6312 IF (I3.NE.NVAL(J)) GO TO 6319
IF (J.NE.NSEC) GO TO 6313
63120 IA=1
GO TO 631
C
6313 IF (NOR(J).NE.NOR(J+1)) 63120,6300
C
6319 CONTINUE
6320 IF (IA.EQ.1) GO TO 631
6310 NTT=NTT+1
63 CONTINUE
M=NTT*N
NOBS=NOBS+NTT
IF (N.GT.1) GO TO 651
650 IST=1
CALL COUNT(IX,ISYM,KOUNT)
NSIZE(1)=IACT
GO TO (630,70),NP
C
64 NP=2
IF (NTT.LE.0) GO TO 70
M=NTT*N
NOBS=NOBS+NTT
IF (N.LE.1) GO TO 650
651 NAM1(2)='.001'
NAM1(1)='00001'
65 NAM1(1)=NAM1(1)+1
CALL EXIST(NFILE1,I)
IF (I.NE.1) GO TO 65
OPEN(UNIT=IDSK,FILE=NFILE1,ACCESS='SEQOUT',MODE=DEVMOD,
. DEVICE=DEVTMP)
IF (IS.EQ.2) OPEN(UNIT=LDSK,FILE=NFILE2,ACCESS='SEQIN',
1 MODE=DEVMOD,DEVICE=DEVTMP)
660 DO 66 I=1,N
IACT=NSIZE(I)
ISIZE=MIN0(IACT,600)
IST=I
IF (IS.LE.1) GO TO 68
I1=(ISIZE+124)/125
K=0
DO 670 J=1,I1
READ(LDSK) IDUM
READ(LDSK) KKOUNT
DO 670 JJ=1,125
K=K+1
IF (K.GT.ISIZE) GO TO 68
ISYM(K)=IDUM(JJ)
KOUNT(K)=KKOUNT(JJ)
670 CONTINUE
68 CALL COUNT(IX,ISYM,KOUNT)
69 K=0
DO 690 J=1,ISIZE
K=K+1
IF (K.GT.125) GO TO 691
IDUM(K)=ISYM(J)
KKOUNT(K)=KOUNT(J)
GO TO 690
691 WRITE(IDSK) IDUM
WRITE(IDSK) KKOUNT
IDUM(1)=ISYM(J)
KKOUNT(1)=KOUNT(J)
K=1
690 CONTINUE
NSIZE(I)=IACT
IF (K.LE.0) GO TO 66
WRITE(IDSK)IDUM
WRITE(IDSK) KKOUNT
66 CONTINUE
IF (IS.EQ.2) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
CLOSE(UNIT=IDSK,DISPOSE='RENAME',FILE=NFILE1)
IS=2
DO 6600 J=1,2
6600 NAM2(J)=NAM1(J)
GO TO (630,70), NP
C
C
70 IF(IDEVO.NE.'TTY') WRITE(IOUT,4461) NOBS
IF(IDEVO.NE.'TTY') CALL PAGE
WRITE(IDLG,461) NOBS
IF (NOBS.LE.0) RETURN
IF (N.GT.1) OPEN (UNIT=LDSK,FILE=NFILE2,ACCESS='SEQIN',
1 MODE=DEVMOD,DEVICE=DEVTMP)
OBS=100./NOBS
IF((ISYM(1).EQ.MISS).AND.(IOPT(3).EQ.1))OBS=100./(NOBS-KOUNT(1))
NC=0
DO 72 J=1,N
IJ=MODE(J)
NC=NC+1
ISIZE=MIN0(NSIZE(J),600)
IF (N.GT.1) GO TO 74
DO 721 JJ=1,ISIZE
721 PER(JJ)=KOUNT(JJ)*OBS
GO TO 744
74 KK=0
740 READ(LDSK) IDUM
READ(LDSK) KKOUNT
7410 DO 741 JJ=1,125
KK=KK+1
IF (KK.GT.ISIZE) GO TO 744
ISYM(KK)=IDUM(JJ)
KOUNT(KK)=KKOUNT(JJ)
741 PER(KK)=KOUNT(KK)*OBS
IF (KK.LT.ISIZE) GO TO 740
C
744 NOMIS=1
S=' '
IF (ISIZE.GT.1) S='S'
IF (ISYM(1).NE.MISS) GO TO 745
NOMIS=2
ISYM(1)='MISSI'
IF(IOPT(3).EQ.1) NOMIS=3
745 CALL SIZE(IJ)
IF(IPAGE+7.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,746) NAME(J),ISIZE,S
746 FORMAT('-***** VARIABLE ',A5,' HAS ',I3,' VALUE',A1,' *****'/)
IF (NSIZE(J).LE.600) GOTO 7411
IF(IPAGE+4.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,747) NAME(J)
747 FORMAT(' NOTE: More than 600 symbols encountered in variable ',
1 A5,','/8X,'No further symbols will be considered, but the
2 counts for'/8X,'those symbols in the table will be accurate.'/)
7411 GO TO (75,76,77), IJ+1
75 CALL SFLO(SYM,KOUNT,PER)
GO TO 78
76 CALL SALP(ISYM,KOUNT,PER)
GO TO 78
77 CALL SFIX(ISYM,KOUNT,PER)
C
C
C
78 IF(J.EQ.N) GOTO 72
IF(IPAGE+4.GT.MAXPAG) CALL PAGE
IF(IPAGE.EQ.2) GOTO 72
IPAGE=IPAGE+3
WRITE(IOUT,54)
72 CONTINUE
90 IF (N.GT.1) CLOSE(UNIT=LDSK,DISPOSE='DELETE')
RETURN
END
C---------------IOPT AND MAXOPT ARE INPUT THRU COMMON /SOPT/
C---------------IDLG, ICODE, IALT INPUT THRU COMMON /IOB/
C---------------IBNK INPUT THRU COMMON /IOBLK/
SUBROUTINE OPTION
C
C***********************************************************************
C SUBROUTINE THAT DETERMINES WHICH OPTION IS ELECTED
C
C IOPT(I)=0 MEANS THAT PARTICULAR OPTION IS NOT ELECTED
C =1 OTHERWISE
C
C***********************************************************************
C
DIMENSION IDUM(72),LIST(4),ISAVE(5)
C
C
C
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
C---------------IOPT(1),...,IOPT(4) CORRESPONDS TO SELECT, HEADER,
C--------------- MISS, FORMAT OPTIONS RESP. IOPT(I), MAXOPT RETURNED
C--------------- TO MAINL BY SUBR. OPTION
COMMON/SOPT/IOPT(4),MAXOPT
DOUBLE PRECISION NAMI,NAMO
C
C
DATA LIST/'SELEC','HEADE','MISS','FORMA'/
DATA IDOL,MAXOPT/'$',4/
C
1 WRITE(IDLG,100)
100 FORMAT(' OPTIONS?'/)
C---------------IDUM, IRET ARE RETURNED GES IS IN FORWMU
CALL GES(IDUM,72,IRET)
IF (IRET.EQ.2) CALL EXIT
IF ((IDUM(1).EQ.'S').AND.(IDUM(2).EQ.'A').AND.(IDUM(3).EQ.'M')
1.AND.(IDUM(4).EQ.'E')) RETURN
NPT=1
DO 10 I=1,3
10 IOPT(I)=0
C
C
C
DO 2 LAST=72,1,-1
IF (IDUM(LAST).NE.' ') GO TO 200
2 CONTINUE
RETURN
C
C
C
200 DO 20 I=1,5
20 ISAVE(I)=' '
IS=0
DO 21 I=1,LAST
L=IDUM(I)
IF (L.EQ.' ') GO TO 21
IF ((L.EQ.',').OR.(L.EQ.IALT).OR.(L.EQ.IDOL)) GO TO 22
IF (IS.GE.5) GO TO 21
IS=IS+1
ISAVE(IS)=L
GO TO 21
C
C
22 K=' '
ENCODE(5,220,K) ISAVE
220 FORMAT(5A1)
IF (K.EQ.'HELP') GO TO 40
IF (K.EQ.'NONE') RETURN
IF ((K.EQ.'ALL').OR.(K.EQ.'*')) GO TO 26
DO 23 J=1,MAXOPT
IF (K.EQ.LIST(J)) GO TO 25
23 CONTINUE
WRITE(IDLG,24) K
24 FORMAT('-ERROR: Option code "',A5,'" does not exist, Try again'
1 /)
IF (ICODE.GE.0) GO TO 1
CALL EXIT
C
C
C
25 IF ((IBNK.NE.1).OR.(J.NE.MAXOPT)) IOPT(J)=1
IF ((IBNK.EQ.1).AND.(J.EQ.MAXOPT)) WRITE(IDLG,252)
252 FORMAT('-WARNING: Cannot use FORMAT with a data BANK'/9X,'P
.rogram will ignore this option'/)
253 IF ((NPT.GT.1).OR.((I.EQ.LAST).AND.((L.EQ.IALT).OR.(L.EQ.IDOL)))
1) RETURN
DO 250 J=1,5
250 ISAVE(J)=' '
IS=0
21 CONTINUE
IF (IS.LE.0) RETURN
NPT=2
GO TO 22
C
C
26 LAST=MAXOPT
IF (IBNK.NE.1) GO TO 260
LAST=MAXOPT-1
WRITE(IDLG,252)
C
260 DO 27 J=1,LAST
27 IOPT(J)=1
30 RETURN
C
C
40 WRITE(IDLG,41)
41 FORMAT('-Options available are:'//' CODE DESCRIPTION'/
1 1X,4('-'),5X,11('-')/' SELECT Option to consider only those
2 observations meeting user'/10X,'specified criteria'/' HEADER
3 A line of at most 80 columns to be used as HEADER'/
4 ' FORMAT Option to enter own format, Default: (80A1)'/
.' MISS Missing data will not be in calculations of perc
.entages'/
5 1X,12('-')/' ALL All of the options listed above'/
6 ' NONE None of the options listed'/' SAME Maintain
7 the options used in the previous run'//' Enter the desired
8 options in a line separated by commas.'/)
IF (ICODE.GE.0) GO TO 1
CALL EXIT
END
SUBROUTINE PACK(M,MT,IY,IDUM,NCK)
C
C**********************************************************************
C
C SUBROUTINE THAT PUTS ALL THE GOOD DATA IN IY AS DETERMINED
C BY THE VECTOR NCK
C
C ARGUMENTS COMING FROM CALLING PROGRAM:
C MT-----NUMBER OF OBSERVATIONS TO CONSIDER
C IDUM---VECTOR CONTAINING THE ACTUAL DATA
C NCK----VECTOR CONTAINING 1'S AND 0'S TO DETERMINE IF A
C PARTICULAR DATA POINT IS GOOD OR BAD
C
C
C ARGUMENTS RETURN TO CALLING PROGRAM:
C M-----ACTUAL NUMBER OF OBSERVATIONS TO CONSIDER
C IY----VECTOR CONTAINING THE GOOD DATA
C
C***********************************************************************
C
DIMENSION IY(125),IDUM(125),NCK(125)
M=0
DO 10 I=1,MT
IF (NCK(I).EQ.1) GO TO 10
M=M+1
IY(M)=IDUM(I)
10 CONTINUE
RETURN
END
SUBROUTINE COUNT(IX,ISYM,KOUNT)
C---------------IX INPUT, ISYM AND KOUNT RETURNED
C--------------- IACT INPUT THRU COMMON /SYMSZ/ AND MODIFIED
C--------------- ISIZE REURNED THRU COMMON /SYMSZ/
C---------------IST, M, MISS INPUT THRU COMMON /SCOUNT/AND IST IS MODIFIED
C
C*********************************************************************
C SUBROUTINE THAT SORTS AND COUNTS THE SYMBOLS
C
C IX------VECTOR CONTAINING THE DATA
C ISYM----VECTOR CONTAINING THE SYMBOLS
C KOUNT---VECTOR CONTAINING THE COUNTS ASSOCIATED WITH THE SYMBOLS
C IST-----STARTING POINT IN IX
C M-------NUMBER OF DATA POINTS IN IX TO CONSIDER
C INC-----SIZE OF INCREMENT TO TAKE IN IX
C MISS----MISSING DATA SYMBOL
C ISIZE---SIZE OF SYMBOLS, COULD BE MORE THAN 600
C IACT----ACTUAL SIZE OF THE SYMBOLS, CANNOT BE MORE THAN 600
C
C***********************************************************************
C
DIMENSION IX(1),ISYM(1),KOUNT(1)
COMMON/SCOUNT/IST,M,INC,MISS
COMMON/SYMSZ/ISIZE,IACT
ISIZE=MIN0(IACT,600)
IF (ISIZE.GT.0) GO TO 20
ISIZE=1
IACT=1
ISYM(1)=IX(IST)
IF (ISYM(1).EQ.' ') ISYM(1)='BLANK'
KOUNT(1)=1
IF (M.LE.1) RETURN
IST=IST+INC
IF (IST.GT.M) RETURN
C
C
C
20 DO 21 I=IST,M,INC
L=IX(I)
I1=1
IF (L.EQ.' ') L='BLANK'
IF (L.NE.MISS) GO TO 210
IF (ISYM(1).NE.MISS) GO TO 22
KOUNT(1)=KOUNT(1)+1
GO TO 21
210 IF (ISYM(1).EQ.MISS) I1=2
C
C BUG FIX 4/28/77
C
C IF WE SET I1=2 BECAUSE ((L .NE. MISS) .AND. (MISS.EQ.ISYM(1)))
C I1 MAY BE GREATER THAN ISIZE, SO JUST COUNT THE NEW SYMBOL
C
IF(I1.GT.ISIZE)GO TO 230
C
IF (L.EQ.ISYM(I1)) GO TO 24
IF (L.GT.ISYM(I1)) GO TO 25
22 IF (IACT.GE.600) GO TO 2100
DO 23 J=ISIZE,I1,-1
ISYM(J+1)=ISYM(J)
23 KOUNT(J+1)=KOUNT(J)
230 ISIZE=ISIZE+1
IACT=IACT+1
KOUNT(I1)=1
ISYM(I1)=L
GO TO 21
24 KOUNT(I1)=KOUNT(I1)+1
GO TO 21
25 IF (L.LT.ISYM(ISIZE)) GO TO 30
IF (L.GT.ISYM(ISIZE)) GO TO 27
26 KOUNT(ISIZE)=KOUNT(ISIZE)+1
GO TO 21
27 IF (IACT.GE.600) GO TO 2100
I1=ISIZE+1
GO TO 230
30 L1=I1
L2=ISIZE
31 I1=(L1+L2)/2
IF (L.EQ.ISYM(I1)) GO TO 24
IF (L.LT.ISYM(I1)) L2=I1
IF (L.GT.ISYM(I1)) L1=I1
K1=L2-L1
IF (K1.GT.1) GO TO 31
I1=L2
IF (K1.LT.1) I1=I1+1
GO TO 22
2100 IACT=601
21 CONTINUE
RETURN
END
SUBROUTINE SFLO(SYM,KOUNT,PER)
C---------------SYM, KOUNT, AND PER ARE INPUT TO SFLO, MAXPAGE, IPAGE
C--------------- INPUT THRU COMMON /IOB/IOUT, IDEVO INPUT
C--------------- THRU COMMON /IOBLK/ IR, NTIMES, N1, NS, INPUT THRU
C--------------- COMMON /SSIZE/ ISIZE INPUT THRU COMMON /SYMSZ/
C--------------- NOMIS INPUT THRU COMMON /RPT/
C
C**********************************************************************
C SUBROUTINE THAT WRITES OUT THE REPORT FOR FLOATING POINT
C VARIABLES.
C
C SYM----VECTOR CONTAINING THE SYMBOLS
C KOUNT--VECTOR CONTAINING THE COUNTS ASSOCIATED WITH THE SYMBOLS
C PER----VECTOR CONTAINING THE PERCENTAGES
C**********************************************************************
C
DIMENSION SYM(1),KOUNT(1),PER(1)
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON/IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
COMMON/SYMSZ/ISIZE,IACT
COMMON/SSIZE/IR,NTIMES,N1,MS(4),NS(5)
COMMON/RPT/NOMIS
DOUBLE PRECISION NAMO,NAMI
DATA DASH,BLANK/'-',' '/
IF(IPAGE+5.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+2
WRITE(IOUT,71) (BLANK,J=1,NTIMES*2)
71 FORMAT(4(2A5,'VALUE',4X,'FREQ PERCENT'))
WRITE(IOUT,53) ((DASH, J=1,23),JJ=1,NTIMES)
53 FORMAT(4(8X,23A1))
IS=1
GO TO (73,720,62), NOMIS
720 WRITE(IOUT,72) ((SYM(1+NS(L)),KOUNT(1+NS(L)),PER(1+NS(L))),
1 L=1,NTIMES)
72 FORMAT(8X,A5,'NG',I8,F7.2,'%',3(1X,F14.3,I8,F7.2,'%'))
GOTO 63
62 IF(ISIZE.GT.1) GOTO 66
WRITE(IOUT,64) SYM(1+NS(1)),KOUNT(1+NS(1))
GOTO 63
66 WRITE(IOUT,64) SYM(1+NS(1)),KOUNT(1+NS(1)),(SYM(1+NS(L)),
. KOUNT(1+NS(L)),PER(1+NS(L)),L=2,NTIMES)
64 FORMAT(8X,A5,'NG',I8,8X,3(1X,F14.3,I8,F7.2,'%'))
63 IPAGE=IPAGE+1
IF (NTIMES.EQ.ISIZE) RETURN
IF (IS.EQ.N1) GO TO 76
IS=2
73 IF (IDEVO.NE.'TTY') GOTO 65
WRITE(IOUT,74) (((SYM(K+NS(L)),KOUNT(K+NS(L)),
1 PER(K+NS(L))),L=1,NTIMES),K=IS,N1)
74 FORMAT(2(1X,F14.3,I8,F7.2,'%'))
GOTO 76
65 DO 69 K=IS,N1
IPAGE=IPAGE+1
IF(IPAGE.LT.MAXPAG) GOTO 69
CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,71) (BLANK,J=1,NTIMES*2)
WRITE(IOUT,53) ((DASH,J=1,23),JJ=1,NTIMES)
69 WRITE(IOUT,75) ((SYM(K+NS(L)),KOUNT(K+NS(L)),
1 PER(K+NS(L))),L=1,NTIMES)
75 FORMAT(4(1X,F14.3,I8,F7.2,'%'))
76 IF (IR.EQ.0) RETURN
WRITE(IOUT,75) ((SYM(NS(I)),KOUNT(NS(I)),PER(NS(I))),I=2,IR+1)
IPAGE=IPAGE+1
RETURN
END
SUBROUTINE SALP(ISYM,KOUNT,PER)
C---------------ISYM, KOUNT, AND PER ARE INPUT TO SALP
C--------------- IR, NTIMES, N1, NS ARE INPUT THRU COMMON /SSIZE/
C---------------IACT, ISIZE INPUT THRU COMMON /SYMSZ/
C---------------IPAGE, MAXPAGE, INPUT THRU COMMON /IOB/
C---------------IOUT, IDEVO INPUT THRU COMMON /IOBLK/
C
C**********************************************************************
C SUBROUTINE THAT WRITES OUT THE REPORT FOR ALPHA-TYPE VARIABLES
C
C ISYM---VECTOR CONTAINING THE SYMBOLS
C KOUNT--VECTOR CONTAINING THE COUNTS ASSOCIATED WITH THE SYMBOLS
C PER----VECTOR CONTAINING THE PERCENTAGES
C*********************************************************************
C
DIMENSION ISYM(1),KOUNT(1),PER(1),ISAVE(5)
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
COMMON/SYMSZ/ISIZE,IACT
COMMON/SSIZE/IR,NTIMES,N1,MS(4),NS(5)
COMMON/RPT/NOMIS
DOUBLE PRECISION NAMI,NAMO
DATA DASH,BLANK,ITAB/'-----',' ',' '/
C
C THIS SECTION IS FOR CHANGING TAB'S TO A SPACE
C FOR OUTPUT
C
DO 40 I=1,IACT
J=ISYM(I)
IF((J.AND."774000000000).EQ."044000000000) GOTO 41
IF((J.AND."003760000000).EQ."000220000000) GOTO 41
IF((J.AND."000017700000).EQ."000001100000) GOTO 41
IF((J.AND."000000077400).EQ."000000004400) GOTO 41
IF((J.AND."000000000376).EQ."000000000022) GOTO 41
GOTO 40
41 DECODE(5,441,J) ISAVE
441 FORMAT(5A1)
DO 42 L=1,5
IF(ISAVE(L).EQ.ITAB) ISAVE(L)=' '
42 CONTINUE
ENCODE(5,441,ISYM(I)) ISAVE
40 CONTINUE
C
C
C
IF(IPAGE+5.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+2
WRITE(IOUT,51) (BLANK, J=1,NTIMES)
51 FORMAT(5(A1,'SYMBOL FREQ PERCENT',2X))
WRITE(IOUT,53) (DASH, J=1,NTIMES*4)
53 FORMAT(1X,4A5,4(3X,4A5))
IS=1
GO TO (58,56,62), NOMIS
56 WRITE(IOUT,57) (ISYM(1+NS(I)),KOUNT(1+NS(I)),PER(1+NS(I)),
1 I=1,NTIMES)
57 FORMAT(1X,A5,'NG',I5,F7.2,'%',4(3X,A5,1X,I6,F7.2,'%'))
GOTO 63
62 IF(ISIZE.GT.1) GOTO 662
WRITE(IOUT,64) ISYM(1+NS(1)),KOUNT(1+NS(1))
GOTO 63
662 WRITE(IOUT,64) ISYM(1+NS(1)),KOUNT(1+NS(1)),(ISYM(1+NS(I)),
. KOUNT(1+NS(I)),PER(1+NS(I)),I=2,NTIMES)
64 FORMAT(1X,A5,'NG',I5,8X,4(3X,A5,1X,I6,F7.2,'%'))
63 IPAGE=IPAGE+1
IF (NTIMES.EQ.ISIZE) RETURN
IF (IS.EQ.N1) GO TO 61
IS=2
58 IF (IDEVO.NE.'TTY') GOTO 65
DO 66 K=IS,N1
67 WRITE(IOUT,59) (ISYM(K+NS(I)),KOUNT(K+NS(I)),
1 PER(K+NS(I)),I=1,NTIMES)
59 FORMAT(3(1X,A5,I7,F7.2,'%',2X))
66 CONTINUE
GOTO 61
65 DO 68 K=IS,N1
IPAGE=IPAGE+1
IF(IPAGE.LT.MAXPAG) GOTO 69
CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,51) (BLANK,J=1,NTIMES)
WRITE(IOUT,53) (DASH,J=1,NTIMES*4)
69 WRITE(IOUT,60) (ISYM(K+NS(I)),KOUNT(K+NS(I)),
1 PER(K+NS(I)),I=1,NTIMES)
60 FORMAT(5(1X,A5,I7,F7.2,'%',2X))
68 CONTINUE
61 IF (IR.EQ.0) RETURN
WRITE(IOUT,60) (ISYM(NS(I)),KOUNT(NS(I)),PER(NS(I)), I=2,IR+1)
IPAGE=IPAGE+1
RETURN
END
SUBROUTINE SFIX(ISYM,KOUNT,PER)
C---------------ISYM, KOUNT, AND PER ARE INPUT TO SFIX
C---------------IR, NTIMES, N1, NS ARE INPUT THRU COMMON /SSIZE/
C---------------IPAGE, MAXPAGE, INPUT THRU COMMON /IOB/
C---------------IOUT, IDEVO INPUT THRU COMMON /IOBLK/
C---------------NOMIS INPUT THRU COMMON /RPT/
C
C**********************************************************************
C SUBROUTINE THAT WRITES OUT THE REPORT FOR FIXED POINT VARIABLES
C
C ISYM---VECTOR CONTAINING THE SYMBOLS
C KOUNT--VECTOR CONTAINING THE COUNTS ASSOCIATED WITH THE SYMBOLS
C PER----VECTOR CONTAINING THE PERCENTAGES
C**********************************************************************
C
DIMENSION ISYM(1),KOUNT(1),PER(1)
COMMON/IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON /IOB/LFBR,IRTBR,IALT,MAXPAG,IPAGE,IPAGCT,IDLG,ICC,ICODE
COMMON/SYMSZ/ISIZE,IACT
COMMON/SSIZE/IR,NTIMES,N1,MS(4),NS(5)
COMMON/RPT/NOMIS
DOUBLE PRECISION NAMO,NAMI
DATA DASH,BLANK/'-',' '/
IF(IPAGE+5.GT.MAXPAG) CALL PAGE
IPAGE=IPAGE+2
WRITE(IOUT,61) (BLANK,J=1,NTIMES)
61 FORMAT(5(A4,'VALUE FREQ PERCENT '))
WRITE(IOUT,62) ((DASH, J=1,22),JJ=1,NTIMES)
62 FORMAT(5(2X,22A1))
IS=1
GO TO (67,65,71), NOMIS
65 WRITE(IOUT,66) ((ISYM(1+NS(I)),KOUNT(1+NS(I)),PER(1+NS(I))),
1 I=1,NTIMES)
66 FORMAT(3X,A5,'NG',I6,F7.2,'% ',4(I9,I6,F7.2,'% '))
GOTO 73
71 IF(ISIZE.GT.1) GOTO 666
WRITE(IOUT,72) ISYM(1+NS(1)),KOUNT(1+NS(1))
GOTO 73
666 WRITE(IOUT,72) ISYM(1+NS(1)),KOUNT(1+NS(1)),(ISYM(1+NS(I)),
. KOUNT(1+NS(I)),PER(1+NS(I)),I=2,NTIMES)
72 FORMAT(3X,A5,'NG',I6,9X,4(I9,I6,F7.2,'% '))
73 IPAGE=IPAGE+1
IF (NTIMES.EQ.ISIZE) RETURN
IF (IS.EQ.N1) GO TO 70
IS=2
67 IF (IDEVO.NE.'TTY') GOTO 74
WRITE(IOUT,68)(((ISYM(K+NS(I)),KOUNT(K+NS(I)),
1 PER(K+NS(I))),I=1,NTIMES),K=IS,N1)
68 FORMAT(3(1X,I9,I6,F7.2,'%'))
GOTO 70
74 DO 75 K=IS,N1
IPAGE=IPAGE+1
IF(IPAGE.LT.MAXPAG) GOTO 75
CALL PAGE
IPAGE=IPAGE+4
WRITE(IOUT,61) (BLANK,J=1,NTIMES)
WRITE(IOUT,62) ((DASH,J=1,21),JJ=1,NTIMES)
75 WRITE(IOUT,69) (ISYM(K+NS(I)),KOUNT(K+NS(I)),PER(K+NS(I)),
. I=1,NTIMES)
69 FORMAT(5(1X,I9,I6,F7.2,'%'))
70 IF(IR.EQ.0) RETURN
WRITE(IOUT,69) ((ISYM(NS(I)),KOUNT(NS(I)),PER(NS(I))),I=2,IR+1)
IPAGE=IPAGE+1
RETURN
END
SUBROUTINE SIZE(MODE)
C---------------MODE IS INPUT IR, NTIMES, N1, NS ARE RETURNED THRU
C--------------- COMMON /SSIZE/
C---------------IDEVO INPUT THRU COMMON /IOBLK/; ISIZE INPUT THRU COMMON
C--------------- /SYMSZ/
C
C**********************************************************************
C SUBROUTINE THAT DETERMINES THE NUMBER OF THE SYMBOLS PER COLUMN
C**********************************************************************
C
COMMON /IOBLK/INP,IOUT,IDEVI,IDEVO,IBNK,NAMI,NAMO,IPROJ,IPROG
COMMON/SYMSZ/ISIZE,IACT
COMMON/SSIZE/IR,NTIMES,N1,MS(4),NS(5)
IF (MODE.GT.0) GO TO 10
NTIMES=2
IF (IDEVO.NE.'TTY') NTIMES=4
GO TO 20
10 NTIMES=3
IF (IDEVO.NE.'TTY') NTIMES=5
20 IF (ISIZE.LT.NTIMES) NTIMES=ISIZE
IR=MOD(ISIZE,NTIMES)
N1=ISIZE/NTIMES
N2=(ISIZE+NTIMES-1)/NTIMES
DO 21 I=1,4
MS(I)=N1
IF (IR.GE.I) MS(I)=N2
21 CONTINUE
NS(1)=0
NS(2)=MS(1)
IF (NTIMES.LE.2) RETURN
DO 22 I=3,NTIMES
NS(I)=0
DO 22 J=1,I-1
22 NS(I)=NS(I)+MS(J)
RETURN
END