home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / fortran / library / pearson / stat.for < prev   
Text File  |  1986-09-19  |  37KB  |  973 lines
  1.       SUBROUTINE CENTER (INPUT, OUTPUT, N)
  2. C ............................................................
  3. C        Center a Smaller String within A Larger String
  4. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  5. C PURPOSE:  To center 'INPUT' string in 'OUTPUT' string of 'N'
  6. C      characters. 
  7. C USAGE:
  8. C      CALL CENTER (INPUT, OUTPUT, N)
  9. C DESCRIPTION OF PARAMETERS:
  10. C      INPUT - Input   character   variable   of   length   80
  11. C              containing  string  to be centered.  The actual
  12. C              text of the string must be  terminated  with  a
  13. C              backslash (\). 
  14. C      OUTPUT- Output string of length 80 printed or otherwise
  15. C              used by the calling program returned with INPUT
  16. C              centered on a line length of N characters.
  17. C      N     - Total length < 80  in  which  INPUT  is  to  be
  18. C              centered. 
  19. C REMARKS:  None. 
  20. C SUBPROGRAMS REQUIRED:
  21. C      INSTR
  22. C      MOVE
  23. C METHOD:  Not applicable. 
  24. C ............................................................
  25.       CHARACTER INPUT*80, BLANK*80, BLK(80), OUTPUT*80
  26.       EQUIVALENCE (BLANK, BLK(1))
  27.       DATA BLK/80*' '/
  28.       OUTPUT = BLANK
  29.       II = INSTR(INPUT, '\', 1) - 1
  30.       JJ = (N-II)/2
  31.       CALL MOVE (INPUT, 1, OUTPUT, JJ+1, II)
  32.       RETURN
  33.       END
  34.       SUBROUTINE CLS
  35. C ............................................................
  36. C                         Clear Screen
  37. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  38. C PURPOSE:  To clear the MS-DOS display screen. 
  39. C USAGE:
  40. C      CALL CLS
  41. C DESCRIPTION OF PARAMETERS:  None. 
  42. C REMARKS:  On IBM  PC  systems,  or  close  compatibles,  the
  43. C      ANSI.SYS device driver must be installed.  For machines
  44. C      like  the TIPC ANSI screen handling is always in place.
  45. C SUBPROGRAMS REQUIRED:  None. 
  46. C METHOD:   See  the  section  in  your  MS-DOS/PC-DOS  manual
  47. C      describing  the  ANSI  escape  sequences and how to use
  48. C      them. 
  49. C ............................................................
  50.       WRITE (*,10)
  51. 10    FORMAT (' '\)
  52.       RETURN
  53.       END
  54.       SUBROUTINE CORR (N, NV, R, FMEAN, STD, T, FMT,
  55.      * INPDEV, IDISK1, IOUT, ND)
  56. C ............................................................
  57. C             Pearson Product Moment Correlations
  58. C SOURCE OR AUTHOR:  Thomas Wm. Madron.  Such subroutines  are
  59. C      easily available in a wide variety of textbooks.
  60. C PURPOSE:    Computes  means,  standard  deviations,  and   a
  61. C      correlation  matrix from raw data from either a file or
  62. C      keyboard.  If the data are from keyboard, they  may  be
  63. C      optionally saved to a file for subsequent use.
  64. C USAGE:
  65. C      CALL CORR (N, NV, R, FMEAN, STD, T, FMT, INPDEV,
  66. C     *  IDISK1, IOUT, ND)
  67. C DESCRIPTION OF PARAMETERS:
  68. C      N     - Number   of    Observations    calcualted    by
  69. C              subroutine.
  70. C      NV    - Number of Variables.
  71. C      R     - Output correlation matrix.
  72. C      FMEAN - Output vector of means.
  73. C      STD   - Output vector of standard deviations.
  74. C      FMT   - Character variable containing  variable  format
  75. C              statement.
  76. C      INPDEV- Data input device (>-2-Disk; 1-Keyboard).
  77. C      IDISK1- Data input Logical Unit Number.
  78. C      IOUT  - Data Output Flag (0-No ouput;  2-Disk  output).
  79. C      ND    - Number of Rows Dimensioned  for  R  in  calling
  80. C              program. 
  81. C REMARKS:  CORR cannot handle missing  data.    It  can  take
  82. C      input from keyboard or disk, however. 
  83. C SUBPROGRAMS REQUIRED:
  84. C      KEYBD - Keyboard Input Routine.
  85. C      LOCATE - Place  cursor  at  specified  screen  Row  and 
  86. C               Column.
  87. C METHOD:  Product Moment Correlations are computed. 
  88. C ............................................................
  89.       CHARACTER FMT*80
  90.       REAL*4 R(ND,NV), FMEAN(NV), STD(NV), A, B, C
  91.       N = 0
  92.       IEND = 0
  93.       DO 5 I = 1,NV
  94.       FMEAN(I) = 0.0
  95.       STD(I) = 0.0
  96.       DO 5 J = 1,NV
  97.       R(I,J) = 0.0
  98. 5     CONTINUE
  99.       CALL HEADER
  100. C     BEGIN DATA INPUT LOOP
  101. 10    GO TO (15, 20), INPDEV
  102. C     INPUT FROM KEYBOARD
  103. 15         CALL KEYBD (STD, NV, N, IOUT, IEND)
  104.            IF (IEND .EQ. 1) GO TO 50
  105.            CALL WAIT (NCALL)
  106.            GO TO 25
  107. C     INPUT FROM DISK
  108. 20         READ (IDISK1,FMT,END=50) (STD(I),I=1,NV)
  109. C          A  LITTLE  SPEED  IN  EXECUTION  CAN BE GAINED BY
  110. C          ELIMINATING  THE  FOLLOWING  FIVE  LINES  AT  THE 
  111. C          EXPENSE OF A LITTLE USER FRIENDLINESS.
  112.            NX = N + 1
  113.            NROW = 10
  114.            NCOL = 28
  115.            CALL LOCATE (NROW,NCOL)
  116.            WRITE (*,'(''READING RECORD #'',I8)') NX
  117. 25    N = N + 1
  118.       DO 40 I = 1,NV
  119.            FMEAN(I) = FMEAN(I) + STD(I)
  120.            DO 30 J = I,NV
  121.                 R(I,J) = R(I,J) + STD(I) * STD(J)
  122. 30         CONTINUE
  123. 40    CONTINUE
  124.       GO TO 10
  125. C     END OF DATA INPUT LOOP
  126. 50    T = N
  127. C     CALCULATE THE CORRELATIONS
  128.       DO 70 I = 1,NV
  129.            DO 65 J = I,NV
  130.                 IF (I .EQ. J) GO TO 65
  131.                 A = T*R(I,J) - (FMEAN(I)*FMEAN(J))
  132.                 B = T*R(I,I) - FMEAN(I)**2
  133.                 C = T*R(J,J) - FMEAN(J)**2
  134.                 IF (B * C .EQ. 0.0) GO TO 65
  135.                 R(I,J) = A / SQRT(B * C)
  136. 65         CONTINUE
  137. 70    CONTINUE
  138. C     DO MEANS AND STANDARD DEVIATIONS
  139.       DO 80 I = 1,NV
  140.            FMEAN(I) = FMEAN(I) / T
  141.            STD(I) = SQRT(R(I,I) / T - FMEAN(I)**2)
  142. 80    CONTINUE
  143. C ............................................................
  144. C For consistency with a correlation program that accounts for
  145. C missing  data,  "N"  (sample  size) is placed  in  both  the
  146. C diagonal  of  the  Correlation Matrix and  fills  the  lower
  147. C diagonal  matrix  as well.   If you modify this  program  to
  148. C allow  for  missing  data,  you  will  need  the  number  of
  149. C observations with all data present for each variable and the
  150. C number  of observations with all data present for each  pair
  151. C of  variables.   Programs that calculate significance  tests
  152. C usually  need  an  estimate of the number  of  observations.
  153. C Subsequent  programs use the LOWEST number  of  observations
  154. C taken  from  the  lower diagonal matrix  as  a  conservative
  155. C estimate since any significance tests based on a data matrix
  156. C with missing data are suspect.
  157. C ............................................................
  158.       DO 100 I = 1,NV
  159.            DO 90 J = I,NV
  160.                 R(J,I) = T
  161. 90         CONTINUE
  162. 100   CONTINUE
  163.       RETURN
  164.       END
  165.       SUBROUTINE FILES (TITLE, IO, FILENM, STA)
  166. C ............................................................
  167. C                       Open Disk FILES
  168. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  169. C PURPOSE:  To request filespecs from the  operator  and  open
  170. C      appropriate  files.   The filespecs are returned to the
  171. C      calling program for other uses. 
  172. C USAGE:
  173. C      CALL FILES (TITLE, IO, FILENM, STA)
  174. C DESCRIPTION OF PARAMETERS:
  175. C      TITLE - 28 Character variable for prompt  to  operator.
  176. C      IO    - FORTRAN logical unit number (LUN) to be opened.
  177. C              Passed to FILES from the calling program. 
  178. C      FILENM- Character*14 variable containing filespecs. 
  179. C      STA   - STAtus for file ('NEW' or 'OLD'). 
  180. C REMARKS:  None.
  181. C SUBPROGRAMS REQUIRED:  None.
  182. C METHOD:  Not applicable.
  183. C ............................................................
  184.       CHARACTER TITLE*28, FILENM*14, STA*3
  185.       IOD = 1
  186.       WRITE (*,'(1H ,A)') TITLE
  187. C IF INPUT IS FROM DISK, THEN:
  188.       WRITE (*,
  189.      * '(1H ,''Please Enter Filespecs <d:filename.ext>: ''\)')
  190.       READ (*,'(A)') FILENM
  191.       IF (STA .EQ. 'NEW') THEN
  192.            OPEN (IO, FILE=FILENM, STATUS='NEW',
  193.      *          ACCESS='SEQUENTIAL')
  194.       ELSEIF (STA .EQ. 'OLD') THEN
  195.            OPEN (IO, FILE=FILENM, STATUS='OLD',
  196.      *          ACCESS='SEQUENTIAL')
  197.       ENDIF
  198.       RETURN
  199.       END
  200.       SUBROUTINE HEADER
  201. C ............................................................
  202. C             Print a HEADER on the Video Display
  203. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  204. C PURPOSE:  To print  a  HEADER  at  the  top  of  the  screen
  205. C      consisting of three lines:
  206. C      Line 1:  First title (TITLE1). 
  207. C      Line 2:  Second title (TITLE2). 
  208. C      Line 3:  Horizontal  divider  bar  entered   as   ASCII
  209. C               character  205.    This  can  be  changed,  of
  210. C               course,   to  anything  else.    One  possible
  211. C               alternative might be an equals ('=') sign. 
  212. C REMARKS:  A named  COMMON  statement  (/HEAD/)  is  used  to
  213. C      transmit  the two title lines to HEADER.FOR.  COMMON is
  214. C      used, rather than a parameter list, so that the  titles
  215. C      can be initialized once in the main program, and not in
  216. C      every   subprogram   that   might   call  HEADER,  thus
  217. C      conserving memory and programming effort. 
  218. C SUBPROGRAMS REQUIRED:
  219. C      CLS
  220. C      CENTER
  221. C      LOCATE
  222. C METHOD:  Not applicable. 
  223. C ............................................................
  224. C     SPECIFICATIONS:
  225.       CHARACTER*80 TITLE1, TITLE2, OUTPUT
  226.       COMMON /HEAD/ TITLE1, TITLE2
  227. C     Clear the Screen:
  228.       LL = 80
  229.       CALL CLS
  230. C     Center and Print Program Name
  231.       CALL CENTER (TITLE1, OUTPUT, LL)
  232.       IROW=1
  233.       ICOL=1
  234.       CALL LOCATE (IROW, ICOL)
  235.       WRITE (*,'(A78)') OUTPUT
  236. C     Center and Print Author Name
  237.       CALL CENTER (TITLE2, OUTPUT, LL)
  238.       IROW=2
  239.       ICOL=1
  240.       CALL LOCATE (IROW, ICOL)
  241.       WRITE (*,'(A78)') OUTPUT
  242. C     Print a Horizontal Bar (ASCII CODE 205)
  243. C     NOTE:  The Ms in FORMAT statement 10,  below,  is  the
  244. C            character representation of the horizontal rule
  245. C            --the ASCII character 205.   With  some editors
  246. C            the  characters beyond decimal 127 can be added
  247. C            by pressing the <ALT> key and at  the same time
  248. C            entering  the  decimal equivalent of the letter
  249. C            on the numeric keypad.   A possible alternative
  250. C            character might be an equals (=) sign.
  251.       WRITE (*,10)
  252. 10    FORMAT ('════════════════════════════════════════',
  253.      1        '════════════════════════════════════════')
  254.       RETURN
  255.       END
  256.       FUNCTION ICLS(IOUT)
  257. C ............................................................
  258. C                    Top of Forms Function
  259. C SOURCE OR AUTHOR:  Thomas Wm. Madron.
  260. C PURPOSE:  To send an output device a  top-of-forms  command.
  261. C USAGE:
  262. C      II = ICLS(IOUT)
  263. C DESCRIPTION OF PARAMETERS:
  264. C      IOUT  - Output device: 1=video; 2=printer; >=3 =  disk.
  265. C REMARKS:  None. 
  266. C SUBPROGRAMS REQUIRED:
  267. C      HEADER
  268. C METHOD:  Not applicable.
  269. C ............................................................
  270.       ICRT = 5
  271.       IPRT = 6
  272.       IF (IOUT .EQ. IPRT) THEN
  273. C          SEND TOP OF PAGE TO PRINTER
  274. 10         WRITE (IOUT,'(1H1)')
  275.       ELSEIF (IOUT .EQ. IPRT) THEN
  276. C          CLEAR VIDEO DISPLAY
  277. 30         CALL HEADER
  278.       ELSE
  279. C          SEND ONE BLANK LINE TO DISK FILE
  280. 50         WRITE (IOUT,60)
  281. 60         FORMAT (' ')
  282.       ENDIF
  283.       ICLS = IOUT
  284.       RETURN
  285.       END
  286.       SUBROUTINE INPMNU (TITLE,IQ)
  287. C ............................................................
  288. C                       Data Input Menu
  289. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  290. C PURPOSE:    To  allow  a  selection  for  raw  data   input,
  291. C      initialize IQ, for return to the calling program. 
  292. C USAGE:
  293. C      CALL INPMNU (TITLE, IQ)
  294. C DESCRIPTION OF PARAMETERS:
  295. C      TITLE - Character*64  variable  passed   from   calling
  296. C              program. 
  297. C      IQ    - Pointer for input data type:
  298. C              1 - from keyboard;
  299. C              2 - from disk;
  300. C              3 - return to DOS. 
  301. C REMARKS:  None. 
  302. C SUBPROGRAMS REQUIRED:
  303. C      HEADER
  304. C METHOD:  Not applicable. 
  305. C ............................................................
  306.       CHARACTER TITLE*64
  307. 1     CALL HEADER
  308.       WRITE (*,'('' '',A)') TITLE
  309.       WRITE (*,10)
  310. 10    FORMAT (' ARE THE DATA FROM:'//
  311.      1 '      (1) KEYBOARD, OR'/
  312.      2 '      (2) DISK, OR'/
  313.      3 '      (3) RETURN TO DOS?'//
  314.      4 ' WHICH DATA INPUT DEVICE? '\)
  315.       READ (*,'(I5)') IQ
  316.       IF (IQ .LT. 1 .OR. IQ .GT. 3) GO TO 1
  317.       RETURN
  318.       END
  319.       FUNCTION INSTR (STRING, VALUE, LENVAL)
  320. C ............................................................
  321. C                    String Search Function
  322. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  323. C PURPOSE:  To find  the  location  of  substring  'VALUE'  in
  324. C      'STRING'. 
  325. C USAGE:
  326. C      II = INSTR(STRING, VALUE, LENVAL)
  327. C DESCRIPTION OF PARAMETERS:
  328. C      STRING- Character*80  variable  is  the  string  to  be
  329. C              searched. 
  330. C      VALUE - Character*80 variable is the source string. 
  331. C      LENVAL- The length of VALUE. 
  332. C REMARKS:  This is an attempt to provide in FORTRAN  some  of
  333. C      the functionality of the INSTR$ function in BASIC. 
  334. C SUBPROGRAMS REQUIRED:  None. 
  335. C METHOD:  Not applicable. 
  336. C ............................................................
  337.       CHARACTER STRING*80, VALUE*80, ST*80, VL*80, STR, VALX
  338.       DIMENSION STR(80), VALX(80)
  339.       EQUIVALENCE (ST,STR(1)), (VL,VALX(1))
  340.       ST = STRING
  341.       VL = VALUE
  342.       DO 100 I = 1,80
  343.            IX = 0
  344.            J = I
  345.            DO 50 K = 1,LENVAL
  346.                 IF (STR(J) .NE. VALX(K)) THEN
  347.                      GO TO 100
  348.                 ELSE
  349.                      IX = IX + 1
  350.                      J =  J + 1
  351.                 ENDIF
  352. 50         CONTINUE
  353.            IF (IX .EQ. LENVAL) THEN
  354.                 K = I
  355.                 GO TO 150
  356.            ENDIF
  357. 100   CONTINUE
  358.       INSTR = 0
  359.       RETURN
  360. 150   INSTR = K
  361.       RETURN
  362.       END
  363.       SUBROUTINE KEYBD (X, NV, NOBS, IOUT, IEND)
  364. C ............................................................
  365. C                   Data Input from Console
  366. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  367. C PURPOSE:  To provide raw data input from the keyboard. 
  368. C USAGE:
  369. C      CALL KEYBD (X, NV, NOBS, IOUT, IEND)
  370. C DESCRIPTION OF PARAMETERS:
  371. C      X(i)  - Input data  array  or  record  buffer.    Input
  372. C              fields are placed in X(i). 
  373. C      NV    - Number  of  variables   passed   from   calling
  374. C              program. 
  375. C      NOBS  - Number of observations accumulated  in  calling
  376. C              program and passed to KEYBD. 
  377. C      IOUT  - Flag  for  saving  data  to  disk  passed  from
  378. C              calling program.  Save if IOUT=2. 
  379. C      IEND  - Flag for  end-of-data  passed  to  the  calling
  380. C              program to terminate data input. 
  381. C REMARKS:  This is a relatively slow and unsophisticated data
  382. C      entry routine  for  quick  and  dirty  entry  of  small
  383. C      datasets.   Large datasets should be entered with other
  384. C      software. 
  385. C SUBPROGRAMS REQUIRED:
  386. C      CLS SUBS
  387. C METHOD:  Not applicable. 
  388. C ............................................................
  389.       CHARACTER ID*8
  390.       CHARACTER DAT, DAT2*10, EN1, EN2, DOT, BLK, REC, REC2*8
  391.       DIMENSION X(NV), REC(8), DAT(10)
  392.       COMMON /FILEX/ IDISK1,IDISK2,IDISK3,IDISK4
  393.       EQUIVALENCE (DAT(1),DAT2), (REC(1),REC2)
  394.       DATA EN1/'E'/,EN2/'e'/,DOT/'.'/,BLK/' '/
  395.       IEND = 0
  396.       IOD = 1
  397.       CALL CLS
  398.       N = NOBS + 1
  399.       WRITE (*,5)
  400. 5     FORMAT ('BEGIN ENTERING YOUR DATA -')
  401.       DO 50 I = 1,NV
  402.            DO 6 J = 1,10
  403.                 DAT(J) = BLK
  404. 6          CONTINUE
  405.            WRITE (*,20) N, I
  406.            READ (*,35) DAT
  407.            DO 8 J = 1,10
  408.                 IF (DAT(J) .NE. EN1 .AND. DAT(J) .NE. EN2)
  409.      *               GO TO 8
  410.                 IEND = 1
  411.                 GO TO 60
  412. 8          CONTINUE
  413.            DO 9 J = 1,10
  414.                 IF (DAT(J) .EQ. DOT) GO TO 40
  415. 9          CONTINUE
  416.            DO 11 J = 1,10
  417.                 IF (DAT(J) .NE. BLK) GO TO 11
  418.                 DAT(J) = DOT
  419.                 GO TO 40
  420. 11         CONTINUE
  421. 40         READ (DAT2,30) X(I)
  422. 50    CONTINUE
  423.       WRITE (REC2,70) N
  424.       READ (REC2,80) ID
  425.       IF (IOUT .EQ. 2) CALL SUBS (X, NV, IDISK2, ID)
  426. 60    RETURN    
  427. C     FORMAT STATEMENTS
  428. 20    FORMAT (' OBSERVATION',I6,' VARIABLE',I4,': '\)
  429. 30    FORMAT (F10.0)
  430. 35    FORMAT (10A1)
  431. 70    FORMAT (I5,'  1')
  432. 80    FORMAT (A8)
  433.       END
  434.       SUBROUTINE LOCATE (IROW, ICOL)
  435. C ............................................................
  436. C               Locate the Cursor on the Screen
  437. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  438. C PURPOSE:  To locate the cursor at IROW and ICOL. 
  439. C USAGE:
  440. C      CALL LOCATE (IROW, ICOL)
  441. C DESCRIPTION OF PARAMETERS:
  442. C      IROW  - Row to which cursor is to be moved passed  from
  443. C              calling program. 
  444. C      ICOL  - Column to which cursor is to  be  moved  passed
  445. C              from calling program. 
  446. C REMARKS:  Using ANSI screen control, this is  an  effort  to
  447. C      implement  in  FORTRAN  a function similar to LOCATE in
  448. C      MS-BASIC.  It requires that the ANSI.SYS device  driver
  449. C      be installed on IBM PC type machines. 
  450. C SUBPROGRAMS REQUIRED:  None. 
  451. C METHOD:  Uses ANSI screen control. 
  452. C ............................................................
  453.       CHARACTER AROW*2, ACOL*2, AFILE*2, BUF(2)*1, Z*1, B*1
  454.       EQUIVALENCE (BUF(1), AFILE)
  455.       Z='0'
  456.       B=' '
  457.       WRITE (AFILE,'(I2)') IROW
  458.       IF (BUF(1) .EQ. B) BUF(1)=Z
  459.       AROW=AFILE
  460.       WRITE (AFILE,'(I2)') ICOL
  461.       IF (BUF(1) .EQ. B) BUF(1)=Z
  462.       ACOL=AFILE
  463.       WRITE (*,10) AROW, ACOL
  464. 10    FORMAT (' ',A,';',A,'H'\)
  465.       RETURN
  466.       END
  467.       SUBROUTINE MOVE (FROM,LOC1,TO,LOC2,LENGTH)
  468. C ............................................................
  469. C                          Move Data
  470. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  471. C PURPOSE:  To provide a means for moving a block of data from
  472. C      one string to another. 
  473. C USAGE:
  474. C      CALL MOVE (FROM, LOC1, TO, LOC2, LENGTH)
  475. C DESCRIPTION OF PARAMETERS:
  476. C      FROM  - Source string to be moved, <= 80 characters. 
  477. C      LOC1  - Starting location  in  FROM  for  block  to  be
  478. C              moved. 
  479. C      TO    - Destination  string  for  FROM  data,   <=   80
  480. C              characters  but  >=  the  amount  of data to be
  481. C              moved. 
  482. C      LOC2  - Starting location of the destination in TO. 
  483. C      LENGTH- Length of the block to be  moved,  passed  from
  484. C              the calling program. 
  485. C REMARKS:  None. 
  486. C SUBPROGRAMS REQUIRED:  None. 
  487. C METHOD:  Not applicable. 
  488. C ............................................................
  489.       CHARACTER FROM*80, TO*80, F2*80, T2*80, FROMX, TOX
  490.       DIMENSION FROMX(80), TOX(80)
  491.       EQUIVALENCE (F2,FROMX),(T2,TOX)
  492.       F2 = FROM
  493.       T2 = TO
  494.       LOCA = LOC1 + LENGTH - 1
  495.       LOCB = LOC2 - 1
  496.       DO 100 I = LOC1,LOCA
  497.            LOCB = LOCB + 1
  498.            TOX(LOCB) = FROMX(I)
  499. 100   CONTINUE
  500.       FROM = F2
  501.       TO = T2
  502.       RETURN
  503.       END
  504.       SUBROUTINE OUTMNU (IOD, IDISK3, TITLE3)
  505. C ............................................................
  506. C                   Output Destination Menu
  507. C SOURCE OR AUTHOR:  Thomas Wm. Madron. 
  508. C PURPOSE:  To allow the user to specify the output device for
  509. C      the normal 'printed' output:  video, printer, or  disk.
  510. C USAGE:
  511. C      CALL OUTMNU (IOD, IDISK3, TITLE3)
  512. C DESCRIPTION OF PARAMETERS:
  513. C      IOD   - Destination logical unit number  returned  from
  514. C              subroutine. 
  515. C      IDISK3- Logical unit number for disk output if disk  is
  516. C              destination  for  output.  If this is opted, IO
  517. C              is set equal to IDISK3. 
  518. C      TITLE3- Title for filespec for disk output,  passed  to
  519. C              subroutine FILES.
  520. C REMARKS:  None.
  521. C SUBPROGRAMS REQUIRED:
  522. C      HEADER
  523. C      WAIT
  524. C      FILES
  525. C METHOD:  Not applicable.
  526. C ............................................................
  527.       CHARACTER FILENM*14, TITLE3*28
  528.       INTEGER*2 DRIVE
  529.       ICRT = 5
  530.       IPRT = 6
  531.       NCALL = 0
  532. 5     CALL HEADER
  533.       WRITE (*,10)
  534. 10    FORMAT (' DESTINATION OF OUTPUT:'//
  535.      1 '      (1) VIDEO DISPLAY'/
  536.      2 '      (2) PRINTER'/
  537.      3 '      (3) DISK FILE'//
  538.      4 ' WHICH OUTPUT DEVICE (ENTER APPROPRIATE NUMBER)? '\)
  539.       READ (*,'(I5)') IOD
  540.       GO TO (50, 30, 40), IOD
  541.       IF (IOD .LT. 1 .OR. IOD .GT. 3) GO TO 5
  542. C     OUTPUT TO PRINTER
  543. 30    CALL HEADER
  544.       IROW = 4
  545.       ICOL = (80-25)/2
  546.            CALL LOCATE (IROW, ICOL)
  547.       WRITE (*,'(''* * * READY PRINTER * * *'')')
  548.       CALL WAIT (NCALL)
  549.       OPEN (IPRT, FILE='LPT1')
  550.       IOD = IPRT
  551.       RETURN
  552. C     OUTPUT TO DISK FILE
  553. 40    CALL FILES (TITLE3,IDISK3,FILENM,'NEW')
  554.       IOD = IDISK3
  555.       RETURN
  556. C     OUTPUT TO VIDEO DISPLAY
  557. 50    OPEN (ICRT, FILE='CON')
  558.       IOD = ICRT
  559.       RETURN
  560.       END
  561.       SUBROUTINE PCDS (X, N, M, FH, IO, IDIAG, ND)
  562. C ............................................................
  563. C                     Save Arrays to Disk
  564. C SOURCE OR AUTHOR:  Modified from Donald J. Veldman,  FORTRAN
  565. C      PROGRAMMING  FOR  THE  BEHAVIORAL  SCIENCES  (New York:
  566. C      Holt, Rinehart and Winston, 1967),  pp.  135-37.    The
  567. C      original was written for FORTRAN IV and was designed to
  568. C      punch cards, hence the name 'PCDS' (Punch CarDS). 
  569. C PURPOSE:  To  save  records  from  an  array  in  12-element
  570. C      blocks.    A matrix is recorded by rows, beginning each
  571. C      row with a new physical record. 
  572. C USAGE:
  573. C      CALL PCDS (X, N, M, FH, IO, IDIAG, ND)
  574. C DESCRIPTION OF PARAMETERS:
  575. C      X     = NAME OF ARRAY TO BE OUTPUT. 
  576. C      N     = NUMBER OF ROWS IF X IS MATRIX, OR ELEMENTS IF A
  577. C              VECTOR.
  578. C      M     = NUMBER OF COLUMNS IF X IS MATRIX.  SET = 1  FOR
  579. C              A VECTOR. 
  580. C      FH    = OUTPUT LABEL.  HOLLERITH BLOCK  (MAX  =  4)  IN
  581. C              CALL STATEMENT.
  582. C      IO    = OUTPUT LOGICAL UNIT NUMBER. 
  583. C      ND    = NUMBER OF ROWS DIMENSIONED  FOR  X  IN  CALLING
  584. C              PROGRAM. 
  585. C REMARKS:  None.
  586. C SUBPROGRAMS REQUIRED:  None.
  587. C METHOD:  Not applicable.
  588. C ............................................................
  589.       CHARACTER FH*4
  590.       DIMENSION X(ND, M)
  591.       L = 1
  592.       IF (M .EQ. 1) THEN
  593.            DO 10 I = 1,N,12
  594.                 J = MIN0(I + 11, N)
  595.                 WRITE (IO,5) FH, M, L, (X(K,1), K = I,J)
  596. 5               FORMAT (A4,I2,I2,12F10.4)
  597.                 L = L + 1
  598. 10         CONTINUE
  599.       ELSE
  600.            DO 30 I = 1,N
  601.                 LL = 1
  602.                 DO 20 J = 1,M,12
  603.                      K = MIN0(J + 11, M)
  604.                      WRITE (IO,5) FH, I, LL, (X(I,L), L = J,K)
  605.                      LL = LL + 1
  606. 20              CONTINUE
  607. 30         CONTINUE
  608.       ENDIF
  609.       RETURN
  610.       END
  611.       SUBROUTINE PRTS (X,N,M,NVAR,KH,ND,NSET,IDIAG)
  612. C ............................................................
  613. C                        Print a Matrix
  614. C SOURCE OR AUTHOR:  Modified from Donald J. Veldman,  FORTRAN
  615. C      PROGRAMMING  FOR  THE  BEHAVIORAL  SCIENCES  (New York:
  616. C      Holt, Rinehart and Winston, 1967),  pp.  135-37.    The
  617. C      original was written in FORTRAN IV.  PURPOSE:  To print
  618. C      a matrix or vector in 10-column partitions. 
  619. C USAGE:
  620. C      CALL PRTS (X,N,M,NVAR,KH,ND,NSET,IDIAG)
  621. C DESCRIPTION OF PARAMETERS:
  622. C      X(i)  - Array to be output. 
  623. C      N     - Number of rows  (or  elements)  of  X()  to  be
  624. C              printed. 
  625. C      M     - Number of columns of X() to be printed (set = 1
  626. C              if X() is a vector). 
  627. C      NVAR  - Vector of variable numbers. 
  628. C      KH    - Character*8 variable passed as a  constant  for
  629. C              output heading. 
  630. C      ND    - Number of rows (or  elements)  dimensioned  for
  631. C              X() in the calling program. 
  632. C      NSET  - Output Logical Unit Number. 
  633. C      IDIAG - Flag for diagonal matrix (0=no; 1=yes). 
  634. C REMARKS:  None. 
  635. C SUBPROGRAMS REQUIRED:  None. 
  636. C METHOD:  Not applicable. 
  637. C ............................................................
  638.       CHARACTER KH*8
  639.       INTEGER*2 NVAR(1), I, J
  640.       REAL*4 X(ND,1)
  641. C     WRITE A VECTOR
  642.       IF (M .EQ. 1) THEN
  643.       WRITE (NSET,15)
  644.       DO 10 I = 1,N,10
  645.            J = MIN0(I + 9,N)
  646.            WRITE (NSET,5) KH, (NVAR(K), K = I,J)
  647.            WRITE (NSET,15) (X(K,1), K = I,J)
  648. 10    CONTINUE
  649. C     WRITE A DIAGONAL MATRIX
  650.       ELSEIF (IDIAG .GT. 0) THEN
  651.       WRITE (NSET,15)
  652.       DO 110 I = 1,N,10
  653.            J = MIN0(I + 9,N)
  654.            WRITE (NSET,5) KH, (NVAR(K), K = I,J)
  655.            WRITE (NSET,15) (X(K,K), K = I,J)
  656. 110   CONTINUE
  657. C     WRITE AN N X M MATRIX
  658.       ELSEIF (M .GT. 1) THEN
  659.       DO 25 K = 1,M,10
  660.            WRITE (NSET,15)
  661.            L = MIN0(K + 9,M)
  662.            WRITE (NSET,5) KH, (NVAR(J),J = K,L)
  663.            DO 20 I = 1,N
  664.                 WRITE (NSET,30) NVAR(I), (X(I,J), J = K,L)
  665. 20         CONTINUE
  666. 25    CONTINUE
  667.       ENDIF
  668.       WRITE (NSET,'(/'' '')')
  669.       RETURN
  670. C     FORMAT STATEMENTS
  671.    5  FORMAT (1H ,A8,10I11)
  672.   15  FORMAT (1H , 10X, 10F11.4)
  673.   30  FORMAT (1H , I6, 4X, 10F11.4)
  674.       END
  675.       SUBROUTINE SUBS (X, N, IO, ID)
  676. C ............................................................
  677. C                 Write an Output Data Record
  678. C SOURCE OR AUTHOR:  Modified from Donald J. Veldman,  FORTRAN
  679. C      PROGRAMMING  FOR  THE  BEHAVIORAL  SCIENCES  (New York:
  680. C      Holt, Rinehart and Winston, 1967),  pp.  135-37.    The
  681. C      original was written for FORTRAN IV and was designed to
  682. C      punch cards. 
  683. C PURPOSE:  To 'punch' one  subject's  score  vector  in  real
  684. C      mode. 
  685. C USAGE:
  686. C      CALL SUBS (X, N, IO, ID)
  687. C DESCRIPTION OF PARAMETERS:
  688. C      X(i)  - Array containing output data. 
  689. C      N     - Number of scores to be punched. 
  690. C      IO    - Output Logical Unit Number. 
  691. C      ID    - Character subject identification (Max=8). 
  692. C REMARKS:  None. 
  693. C SUBPROGRAMS REQUIRED:  None. 
  694. C METHOD:  Not applicable. 
  695. C ............................................................
  696.       CHARACTER ID*8
  697.       REAL*4 X(1)
  698.       M = IABS(N)
  699.       L = 1
  700.       DO 10 I = 1,M,7
  701.            K = MIN0(I + 6, M)
  702.            WRITE (IO,5) ID, L, (X(J), J = I,K)
  703.            L = L + 1
  704. 10    CONTINUE
  705.       RETURN
  706. 5     FORMAT (A8, I2, 7F10.4)
  707.       END
  708.       FUNCTION UPPER (CHARX)
  709. C ............................................................
  710. C               Lower to Upper Case Translation
  711. C SOURCE OR AUTHOR:  Thomas Wm. Madron
  712. C PURPOSE:  To convert an ASCII character from lower to  upper
  713. C      case. 
  714. C USAGE:
  715. C      II = UPPER(CHARX)
  716. C DESCRIPTION OF PARAMETERS:
  717. C      CHARX - Character*1 variable  used  to  pass  character
  718. C              from the calling program.
  719. C REMARKS:  If the function is compiled with the main program,
  720. C      then UPPER must be declared as CHARACTER*1 only in  the
  721. C      calling program.  If the function is added to a program
  722. C      library,  then the CHARACTER declaration must be within
  723. C      the function.
  724. C SUBPROGRAMS REQUIRED:  None.
  725. C METHOD:  Not applicable.
  726. C ............................................................
  727.       INTEGER*2 IUPPER
  728. C     CHARACTER CHARX
  729.       CHARACTER CHARX, UPPER
  730.       II = 0
  731.       JJ = ICHAR(CHARX)
  732.       IF (95 .LT. JJ) II = -1
  733.       IUPPER = JJ + (32 * II)
  734.       UPPER = CHAR(IUPPER)
  735.       RETURN
  736.       END
  737.       SUBROUTINE VPRTS (TITLE,NVAR,X,NR,NC,FH,IDIAG,NCALL,ND)
  738. C ............................................................
  739. C                       Display a Matrix
  740. C SOURCE OR AUTHOR:  Modified from Donald J. Veldman,  FORTRAN
  741. C      PROGRAMMING  FOR  THE  BEHAVIORAL  SCIENCES  (New York:
  742. C      Holt, Rinehart and Winston, 1967),  pp.  135-37.    The
  743. C      original was written in FORTRAN IV.  
  744. C PURPOSE:    To  print  a  matrix  or  vector  in  ten-column
  745. C      partitions on an 80 column video display.  
  746. C USAGE:
  747. C      CALL VPRTS (TITLE,NVAR,X,NR,NC,FH,IDIAG,NCALL,ND)
  748. C DESCRIPTION OF PARAMETERS:
  749. C      TITLE - Character*64 variable containing  a  title  for
  750. C              the matrix.  
  751. C      NVAR  - Vector of variable labels.  
  752. C      X()   - Matrix to be printed.
  753. C      NR    - Number of rows in the matrix.  
  754. C      NC    - Number of columns in the matrix (set = 1 if X()
  755. C              is a vector).  
  756. C      FH    - Character*4 variable containing a name for  the
  757. C              matrix for output.  
  758. C      IDIAG - Flag for  printing  a  diagonal  matrix  (0=no;
  759. C              1=yes).  
  760. C      NCALL - Counter for the number of times VPRTS is called
  761. C              during an analysis.  Must be set  before  entry 
  762. C              to the subroutine.
  763. C      ND    - Number of rows dimensioned in X().  
  764. C REMARKS:  None.  
  765. C SUBPROGRAMS REQUIRED:  None.  
  766. C METHOD:  Not applicable.  
  767. C ............................................................
  768.       CHARACTER TITLE*64, FH*4
  769.       INTEGER*2 NVAR(NR), I, J, M, IA, JA
  770.       REAL*4 X(ND,NC)
  771. C     PRINT AN N X M MATRIX
  772.       IF (NC .GT. 1) THEN
  773.       DO 100 I=1,NR,10
  774.       IA = I+9
  775.       IF (IA-NR) 15,10,10
  776. 10    IA = NR
  777. 15         DO 75 J=1,NC,10
  778.                 JA = J+9
  779.                 IF (JA-NC) 25,20,20
  780. 20              JA = NC
  781. 25              CALL HEADER
  782.                 WRITE (*,'('' '',A)') TITLE
  783.                 WRITE (*,50) FH, (NVAR(M),M=J,JA)
  784.                 DO 70 L=I,IA
  785.                      WRITE (*,65) NVAR(L),(X(L,M),M=J,JA)
  786. 70              CONTINUE
  787.                 CALL WAIT (NCALL)
  788.                 IF (NCALL .GE. 1) GO TO 15
  789. 75          CONTINUE
  790. 100   CONTINUE
  791. C     RETURN
  792. C     PRINT A VECTOR
  793.       ELSEIF (NC .EQ. 1) THEN
  794. 110   CALL HEADER
  795.       WRITE (*,'('' '',A)') TITLE
  796.       DO 130 I=1,NR,10
  797.            J = MIN0(I + 9, NR)
  798.            WRITE (*,115) FH, (NVAR(K), K = I,J)
  799.            WRITE (*,120) (X(K,1), K=I,J)
  800. 130   CONTINUE
  801.       CALL WAIT (NCALL)
  802.       IF (NCALL .GE. 1) GO TO 110
  803. C     RETURN
  804. C     PRINT A DIAGONAL MATRIX
  805.       ELSEIF (IDIAG .GT. 0) THEN
  806. 210   CALL HEADER
  807.       WRITE (*,'(A)') TITLE
  808.       DO 230 I = 1,NR,10
  809.            J = MIN0(I + 9, NR)
  810.            WRITE (*,115) FH, (NVAR(K), K=I,J)
  811.            WRITE (*,120) (X(K,K), K=I,J)
  812. 230   CONTINUE
  813.       CALL WAIT (NCALL)
  814.       IF (NCALL .GE. 1) GO TO 210
  815.       ENDIF
  816.       RETURN
  817. C     FORMAT STATEMENTS
  818. 50    FORMAT (1H ,A4,10I7)
  819. 65    FORMAT (1H ,I4,10F7.3)
  820. 115   FORMAT (1H ,A4,10I7)
  821. 120   FORMAT (1H ,4X,10F7.3)
  822.       END
  823.       SUBROUTINE WAIT (NCALL)
  824. C ............................................................
  825. C                      Wait for Response
  826. C SOURCE OR AUTHOR:  Thomas Wm. Madron.
  827. C PURPOSE:  To pause for  operator  intervention  to  continue
  828. C      execution of a program.
  829. C USAGE: CALL WAIT (NCALL)
  830. C DESCRIPTION OF PARAMETERS:
  831. C      NCALL - Counter for the number of times VPRTS is called
  832. C              to determine the help file to call.
  833. C REMARKS:  If no help subroutines are used, a dummy help sub-
  834. C      routine should accompany the main program.
  835. C SUBPROGRAMS REQUIRED:
  836. C      LOCATE (nrow, ncol)
  837. C      INSTR (string, srchchar, len) [function]
  838. C      UPPER (char) [function]
  839. C      HELP (ncall)
  840. C METHOD:  Uses ANSI screen control, see  your  MS-DOS  manual
  841. C      for further information.
  842. C ............................................................
  843.       CHARACTER A, HELPX, UPPER, INPUT*80, OUTPUT*80
  844. C     CHARACTER A, HELPX, INPUT*80, OUTPUT*80
  845.       HELPX = 'H'
  846.       IROW = 25
  847.       LL = 80
  848.       IF (NCALL .GT. 0) THEN
  849.            INPUT =
  850.      1       '<<Press {ENTER} to Continue or {H} for Help>>\'
  851.            CALL CENTER (INPUT, OUTPUT, LL)
  852.            ICOL = 1
  853.            CALL LOCATE (IROW,ICOL)
  854.            WRITE (*, '(A78\)') OUTPUT
  855.            READ (*, '(A1)') A
  856.            A = UPPER(A)
  857.            IF (A .EQ. HELPX) THEN
  858.                 CALL HELP (NCALL)
  859.            ELSE
  860.                 NCALL = 0
  861.            ENDIF
  862.       ELSE
  863.            INPUT = '<<Press {ENTER} to Continue>>\'
  864.            CALL CENTER (INPUT, OUTPUT, LL)
  865.            ICOL = 1
  866.            CALL LOCATE (IROW,ICOL)
  867.            WRITE (*, '(A78\)') OUTPUT
  868.            READ (*,'(A1)') A
  869.       ENDIF
  870.       RETURN
  871.       END
  872.       SUBROUTINE WTMAT (R, FMEAN, STD, NV, DTFILE, FMT,
  873.      1 TITLE, IDISK4, IDIAG, N, LL, ND)
  874. C ............................................................
  875. C               Write a Standard Matrix to Disk
  876. C SOURCE OR AUTHOR:  Thomas Wm. Madron.
  877. C PURPOSE:  To save a standard matrix to disk.
  878. C USAGE: CALL WTMAT (R, FMEAN, STD, NV, DTFILE, FMT, TITLE,
  879. C     1 IDISK4, IDIAG, N, LL, ND)
  880. C DESCRIPTION OF PARAMETERS:
  881. C      R -       Doubly   Subscripted   array   containing   a
  882. C                correlation or similar matrix.
  883. C      FMEAN -   Singly  subscripted  array of means for  each
  884. C                variable.
  885. C      STD -     Singly   subscripted   array   of    standard
  886. C                deviations for each variable.
  887. C      NV -      Number of Variables.
  888. C      DTFILE -  CHARACTER*14  character  variable  containing
  889. C                the name of a raw data input file.
  890. C      FMT -     CHARACTER*80  character variable containing a
  891. C                standard format statement describing the  raw
  892. C                data file.
  893. C      TITLE -   CHARACTER*64  character variable containing a
  894. C                title or label for the file.
  895. C      IDISK4 -  Logical  Unit Number (LUN) for output  matrix
  896. C                file.
  897. C      IDIAG -   Flag  for  array type for use  of  Subroutine
  898. C                SUBS.
  899. C      N -       Number  of  observations represented  by  the
  900. C                summary    statistics    (means,     standard
  901. C                deviations, and correlations).
  902. C      LL -      Line  Length for the  video  display--usually
  903. C                80.
  904. C      ND -      Number  of  row  dimensions  for  the  doubly
  905. C                subscripted variable.
  906. C REMARKS:
  907. C      THE  STANDARD MATRIX FILE:   The standard matrix   file
  908. C      is  an ASCII file with a well defined format,  produced
  909. C      in  part  with  SUBROUTINE PCDS.   It consists  of  six
  910. C      record types:
  911. C      1.   Header Record containing the number  of  variables
  912. C           and  title  (not  to exceed 64 characters) for the
  913. C           matrix in the following format: (I5, A64)
  914. C      2.   Record(s) containing a vector of  means,  one  for
  915. C           each  variable.  The second field is a row number,
  916. C           the third is a physical record number  within  the
  917. C           logical  record,  followed  by  up  to 12 floating
  918. C           point numbers per physical record.  For  a  vector
  919. C           the   row  number  is  always  one  (1).    For  a
  920. C           correlation matrix the number of rows  will  equal
  921. C           the  number of variables in the matrix.  The first
  922. C           four columns contain 'MEAN": (A4,I2,I2,12F10.4)
  923. C      3.   Record(s)  containing   a   vector   of   standard
  924. C           deviations  for  each  variable.    The  format is
  925. C           identical to (2), above.
  926. C      4.   Records containing a N  x  M  correlation  matrix,
  927. C           including  the  correlation coefficients above the
  928. C           diagonal, the  number  of  observations  for  each
  929. C           variable on the diagonal, and the number of obser-
  930. C           vations  present  for  each  pair  of variables on
  931. C           which each corresponding  correlation  was  based.
  932. C           The format is identical to (2), above.
  933. C      5.   File  specifications  (d:filename.ext)   for   the
  934. C           original  dataset  not  to  exceed  14 characters.
  935. C           This is used if subsequent programs require access
  936. C           to  the  original  data  for  residuals  or  other
  937. C           predicted scores.  
  938. C      6.   Format statement for the raw data as read by CORL.
  939. C           This is also used if subsequent  programs  require
  940. C           access to the original data.  
  941. C SUBPROGRAMS REQUIRED:  
  942. C      CENTER (INPUT, OUTPUT, N)
  943. C      HEADER
  944. C      LOCATE (IROW, ICOL)
  945. C      PCDS (X, N, M, FH, IO, IDIAG, ND)
  946. C          NOTE:  IDISK4 must be opened prior to entry.
  947. C METHOD:   Not Applicable.   
  948. C ............................................................
  949. C     SPECIFICATION STATEMENTS
  950.       CHARACTER DTFILE*14, FMT*80, TITLE*64, INPUT*80,
  951.      1 OUTPUT*80
  952.       REAL*4 R(ND,NV), FMEAN(NV), STD(NV)
  953.       INTEGER*2 I, J
  954. C     PREPARE TO WRITE THE STANDARD MATRIX
  955.            CALL HEADER
  956.            INPUT =
  957.      1       '* * * Writing the Matrix, Please Wait * * *\'
  958.            CALL CENTER (INPUT, OUTPUT, LL)
  959.            NROW = 10
  960.            NCOL = 1
  961.            CALL LOCATE (NROW, NCOL)
  962.            WRITE (*,'(A\)') OUTPUT
  963. C     WRITE STANDARD MATRIX
  964.            WRITE (IDISK4,'(I5,A)') NV, TITLE
  965.            CALL PCDS (FMEAN,NV,1,'MEAN',IDISK4,IDIAG,ND)
  966.            CALL PCDS (STD,NV,1,'STDV',IDISK4,IDIAG,ND)
  967.            CALL PCDS (R,NV,NV,'CORL',IDISK4,IDIAG,ND)
  968.            WRITE (IDISK4,'(A)') DTFILE
  969.            WRITE (IDISK4,'(A)') FMT
  970.            CLOSE (IDISK4, STATUS='KEEP')
  971.       RETURN
  972.       END
  973.