CFPRIME MAIN                                                            MAIN        1
C***********************************************************************RIGHTE      1
C*                                                                     *RIGHTE      2
C*        Extended Transient-Midterm Stability Program (ETMSP)         *RIGHTE      3
C*        ====================================================         *RIGHTE      4
C*                                                                     *RIGHTE      5
C*       Copyright (C) (1993) Electric Power Research Institute        *RIGHTE      6
C*                                                                     *RIGHTE      7
C* EPRI reserves all rights in the software and associated             *RIGHTE      8
C* documentation as delivered. The software and its associated         *RIGHTE      9
C* documention or any portion thereof may not be reproduced in any form*RIGHTE     10
C* whatsoever without the consent of EPRI, except as explicity provided*RIGHTE     11
C* for by license. Licensee shall submit a detailed description to EPRI*RIGHTE     12
C* of any changes or modifications to the software within two (2)      *RIGHTE     13
C* months after such changes or modifications are made. At EPRI's sole *RIGHTE     14
C* discretion, the software, as changed or modified, shall be given a  *RIGHTE     15
C* new designation sufficiently different from its then current        *RIGHTE     16
C* designation as to prevent mistake,confusion, or deception as between*RIGHTE     17
C* the current software as changed or modified.                        *RIGHTE     18
C*                                                                     *RIGHTE     19
C* A license under EPRI's rights in the software can be obtained       *RIGHTE     20
C* directly from EPRI.                                                 *RIGHTE     21
C*                                                                     *RIGHTE     22
C* This program and supporting materials may be independently available*RIGHTE     23
C* from Electric Power Software centre (EPSC) for an appropriate       *RIGHTE     24
C* distribution fee. The EPSC is a service of                          *RIGHTE     25
C*                                                                     *RIGHTE     26
C*                    Power Computing Company                          *RIGHTE     27
C*                    1930 Hi Line                                     *RIGHTE     28
C*                    Dallas, Tx 75207                                 *RIGHTE     29
C*                                                                     *RIGHTE     30
C* NEITHER EPRI, ANY MEMBER OF EPRI, NOR ANY PERSON OR  ORGANIZATION   *RIGHTE     31
C* ACTING ON BEHAVE OF THEM:                                           *RIGHTE     32
C*                                                                     *RIGHTE     33
C* 1. MAKE ANY WARRANTY OR REPRESENTATION WHATSOEVER, EXPRESS OR       *RIGHTE     34
C*    IMPLIED, INCLUDING ANY WARRANTY OF MERCHANTABILITY OR FITNESS OR *RIGHTE     35
C*    ANY PURPOSE WITH RESPECT TO THE SOFTWARE OR ITS ASSOCIATED       *RIGHTE     36
C*    DOCUMENTATION; OR                                                *RIGHTE     37
C*                                                                     *RIGHTE     38
C* 2. ASSUMES ANY LIABILITY WHATSOEVER WITH RESPECT TO ANY USE OF THE  *RIGHTE     39
C*    SOFTWARE OR ITS ASSOCIATED DOCUMENTATION OR ANY PORTION THEREOF  *RIGHTE     40
C*    OR WITH RESPECT TO ANY DAMAGES WHICH MAY RESULT FROM SUCH USE.   *RIGHTE     41
C*                                                                     *RIGHTE     42
C* THIS NOTICE MAY NOT BE REMOVED FROM THE SOFTWARE BY ANY USER        *RIGHTE     43
C* THEREOF.                                                            *RIGHTE     44
C*                                                                     *RIGHTE     45
C***********************************************************************RIGHTE     46
       PROGRAM MAIN                                                     MAIN        3
CD                                                                      MAIN        4
CD    THE MAIN PROGRAM OF EXTENDED TRANSIENT/MID-TERM STABILITY         MAIN        5
CD    PROGRAM (ETMSP).                                                  MAIN        6
CD                                                                      MAIN        7
      INCLUDE 'CNLSTA.INS'                                              MAIN        8
C                                                                       MAIN        9
      INCLUDE 'PARX.INS'                                                MAIN       10
      INCLUDE 'CNB19.INS'                                               MAIN       11
      INCLUDE 'CNUNIT.INS'                                              MAIN       12
      INCLUDE 'CNFLAG.INS'                                              MAIN       13
      INCLUDE 'CNFRUN.INS'                                              MAIN       14
C                                                                       MAIN       15
      CHARACTER*80 COMMD                                                MAIN       16
      CHARACTER*50 PARAM                                                MAIN       17
C                                                                       MAIN       18
C   SETUP SCRATCH COMMON LENGTH                                         MAIN       19
C                                                                       MAIN       20
      COMMON /SCRAT0/ SCRAT0(NSCRA0)                                    MAIN       21
      COMMON /SCRAT1/ SCRAT1(NSCRA1)                                    MAIN       22
      COMMON /SCRAT2/ SCRAT2(NSCRA2)                                    MAIN       23
      COMMON /SCRAT3/ SCRAT3(NSCRA3)                                    MAIN       24
      COMMON /SCRAT4/ SCRAT4(NSCRA4)                                    MAIN       25
      COMMON /SCRAT5/ SCRAT5(NSCRA5)                                    MAIN       26
      COMMON /SCRAT6/ SCRAT6(NSCRA6)                                    MAIN       27
      COMMON /SCRAT7/ SCRAT7(NSCRA7)                                    MAIN       28
      COMMON /SCRAT8/ SCRAT8(NSCRA8)                                    MAIN       29
      COMMON /SCRAT9/ SCRAT9(NSCRA9)                                    MAIN       30
C                                                                       MAIN       31
*IF MIBM                                                                MAIN       32
*ENDIF                                                                  MAIN       34
C                                                                       MAIN       35
      LDEB=.FALSE.                                                      MAIN       36
      IEBK=0                                                            MAIN       37
      CALL PARSET                                                       MAIN       38
      CALL BANNER                                                       MAIN       39
      CALL SETUP(IEBK)                                                  MAIN       40
      IF(IEBK.EQ.2)THEN                                                 MAIN       41
      IEBK=0                                                            MAIN       42
      GOTO 2000                                                         MAIN       43
      ELSEIF(IEBK.NE.0)THEN                                             MAIN       44
      WRITE(LOUT,5020)                                                  MAIN       45
      GOTO 2000                                                         MAIN       46
      ENDIF                                                             MAIN       47
C                                                                       MAIN       48
      IF(CFLRUN)THEN                                                    MAIN       49
        CALL FILRUN (IEBK)                                              MAIN       50
        GOTO 2000                                                       MAIN       51
      ENDIF                                                             MAIN       52
C                                                                       MAIN       53
      LENSTR=1                                                          MAIN       54
      JEND=0                                                            MAIN       55
C                                                                       MAIN       56
C   ..................................                                  MAIN       57
C   : MAIN LOOP OF PROGRAM           :                                  MAIN       58
C                                                                       MAIN       59
 100  CONTINUE                                                          MAIN       60
C      ...............................                                  MAIN       61
C      : Abnormal ending of program  :                                  MAIN       62
C      :                             :                                  MAIN       63
        IF (LENSTR.NE.0) JEND=JEND+1                                    MAIN       64
        IF(JEND.GT.5) THEN                                              MAIN       65
            WRITE(LOUT,5010)                                            MAIN       66
            GOTO 2000                                                   MAIN       67
        ENDIF                                                           MAIN       68
C      :.............................:                                  MAIN       69
        COMMD=' '                                                       MAIN       70
        ISTAT=0                                                         MAIN       71
        IF(MENUM) THEN                                                  MAIN       72
           CALL INMENU(COMMD,ISTAT)                                     MAIN       73
        ELSE                                                            MAIN       74
           CALL INUSER(COMMD,ISTAT)                                     MAIN       75
        ENDIF                                                           MAIN       76
        IF(ISTAT.EQ.-1) GOTO 100                                        MAIN       77
        LENSTR=LENS(COMMD)                                              MAIN       78
        IF(LENSTR.LT.3) GOTO 100                                        MAIN       79
        CALL CCMMD(COMMD,LENSTR,PARAM,LENPAR,ICM)                       MAIN       80
        IF(ICM.EQ.-1) GOTO 100                                          MAIN       81
        CALL GOTOS(ICM,COMMD,PARAM,LENPAR,IGOTO)                        MAIN       82
        IF(IGOTO.EQ.1) GOTO 2000                                        MAIN       83
        JEND=0                                                          MAIN       84
      GOTO 100                                                          MAIN       85
C    :...............................:                                  MAIN       86
                                                                        MAIN       87
C    ....................................                               MAIN       88
C    : NORMAL END OF PROGRAM.  CLEAN UP :                               MAIN       89
C    :..................................:                               MAIN       90
 2000 CONTINUE                                                          MAIN       91
C                                                                       MAIN       92
      CALL CLOSEA                                                       MAIN       93
C                                                                       MAIN       94
      IF(IEBK.EQ.0)THEN                                                 MAIN       95
      WRITE(LOUT,5000)                                                  MAIN       96
      STOP 'ETMSP NORMAL TERMINATION'                                   MAIN       97
      ELSE                                                              MAIN       98
      WRITE(LOUT,5030)                                                  MAIN       99
      STOP 'ETMSP ABNORMAL TERMINATION'                                 MAIN      100
      ENDIF                                                             MAIN      101
C                                                                       MAIN      102
 5000 FORMAT(//,                                                        MAIN      103
     1  10X,'......................................',/,                 MAIN      104
     1  10X,':   -- ETMSP NORMAL TERMINATION --   :',/,                 MAIN      105
     1  10X,':....................................:',//)                MAIN      106
 5010 FORMAT(//,                                                        MAIN      107
     1  10X,'......................................',/,                 MAIN      108
     1  10X,':  -- TOO MANY INVALID COMMANDS --   :',/,                 MAIN      109
     1  10X,':....................................:',//)                MAIN      110
 5020 FORMAT(//,                                                        MAIN      111
     1  10X,'......................................',/,                 MAIN      112
     1  10X,':      -- FILE SETUP ERRORS --       :',/,                 MAIN      113
     1  10X,':....................................:',//)                MAIN      114
 5030 FORMAT(//,                                                        MAIN      115
     1  10X,'......................................',/,                 MAIN      116
     1  10X,':  -- ETMSP ABNORMAL TERMINATION --  :',/,                 MAIN      117
     1  10X,':....................................:',//)                MAIN      118
C                                                                       MAIN      119
      END                                                               MAIN      120
C                                                                       MAIN      121
      BLOCK DATA STBDTA                                                 MAIN      122
CD -------------------------------------------------------------------  MAIN      123
CD                                                                      MAIN      124
CD              *****     BLOCK  DATA     *****                         MAIN      125
CD                                                                      MAIN      126
CD -------------------------------------------------------------------  MAIN      127
CD                                                                      MAIN      128
CD       ROUTINE To initializes the COMMON BLOCK data OF UDC            MAIN      129
CD                 and logical units of the program                     MAIN      130
CD                                                                      MAIN      131
CD -------------------------------------------------------------------  MAIN      132
      INCLUDE 'PARX.INS'                                                MAIN      133
*IF LTSP                                                                MAIN      134
*ENDIF                                                                  MAIN      137
      INCLUDE 'GRPDCS.INS'                                              MAIN      138
      INCLUDE 'UDCA.INS'                                                MAIN      139
      INCLUDE 'CNUNIT.INS'                                              MAIN      140
      INCLUDE 'CNFLAG.INS'                                              MAIN      141
      INCLUDE 'CNCPT2.INS'                                              MAIN      142
      INCLUDE 'UDCADT.INS'                                              MAIN      143
C                                                                       MAIN      144
C   UNITS USED IN THE PROGRAM THEY CAN BE CHANGED TO SUIT THE COMPUTER  MAIN      145
C   SYSTEM AND RE-COMPILE AND LINK THIS ROUTINE                         MAIN      146
C                                                                       MAIN      147
      DATA IU3/92/,IU4/93/,IU6/62/,IU7/94/,IU8/63/,IU11/96/             MAIN      148
     &,IU12/95/,IU15/97/,IU16/61/,IU17/64/,IU18/66/,IU21/89/,IU26/69/   MAIN      149
     &,IU27/70/,IU31/91/,IU33/90/,IU35/65/,IU36/75/,IU50/71/,IU51/67/   MAIN      150
     &,IU52/74/,IU53/73/,IU54/72/,IUD6/68/,IU55/85/,IU56/86/,IU57/87/   MAIN      151
     &,IU58/88/,IU59/84/,IU60/83/,IU61/82/,IUHK/81/                     MAIN      152
C                                                                       MAIN      153
      INCLUDE 'CDCPT2.INS'                                              MAIN      154
*IF LTSP                                                                MAIN      155
*ENDIF                                                                  MAIN      158
C                                                                       MAIN      159
      END                                                               MAIN      160
C                                                                       MAIN      161
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCMAIN      162
      INTEGER FUNCTION LENS(STRING)                                     MAIN      163
CD                                                                      MAIN      164
CD    TO DETERMINE THE LENGTH OF A COMMAND.                             MAIN      165
CD                                                                      MAIN      166
      INCLUDE 'CNLSTA.INS'                                              MAIN      167
      CHARACTER*80 STRING                                               MAIN      168
C   .............................................                       MAIN      169
C   : IGNORE EVERYTHING AFTER THE '!' CHARACTER :                       MAIN      170
C   :                                           :                       MAIN      171
      DO 100 I=1,80                                                     MAIN      172
      IF(STRING(I:I).EQ.' ') GOTO 200                                   MAIN      173
 100  CONTINUE                                                          MAIN      174
C   :............................................:                      MAIN      175
 200  CONTINUE                                                          MAIN      176
      LENS=I-1                                                          MAIN      177
      IF(LENS.LT.3.AND.LENS.NE.0) WRITE(LOUT,5000)                      MAIN      178
 5000 FORMAT(/,                                                         MAIN      179
     1  10X,'............................................',/,           MAIN      180
     1  10X,':  COMMANDS REQUIRE AT LEAST 3 CHARACTERS  :',/,           MAIN      181
     1  10X,':     TYPE "HELP" FOR MORE INFORMATION     :',/,           MAIN      182
     1  10X,':..........................................:',/)           MAIN      183
      RETURN                                                            MAIN      184
      END                                                               MAIN      185
C                                                                       MAIN      186
      INTEGER FUNCTION LENSB(STRING,LL)                                 MAIN      187
CD                                                                      MAIN      188
CD    TO DETERMINE THE LAST BLANK OF A CHARACTER STRING.                MAIN      189
CD                                                                      MAIN      190
      INCLUDE 'CNLSTA.INS'                                              MAIN      191
      CHARACTER*(*) STRING                                              MAIN      192
C   .............................................                       MAIN      193
C   : IGNORE EVERYTHING AFTER THE '!' CHARACTER :                       MAIN      194
C   :                                           :                       MAIN      195
      DO 100 I=LL,1,-1                                                  MAIN      196
      IF(STRING(I:I).NE.' ') GOTO 200                                   MAIN      197
 100  CONTINUE                                                          MAIN      198
      I=0                                                               MAIN      199
 200  CONTINUE                                                          MAIN      200
      LENSB=I                                                           MAIN      201
      IF(LENSB.LE.2.AND.LENSB.NE.0) WRITE(LOUT,5000)                    MAIN      202
 5000 FORMAT(/,                                                         MAIN      203
     1  10X,'............................................',/,           MAIN      204
     1  10X,':  COMMANDS REQUIRE AT LEAST 3 CHARACTERS  :',/,           MAIN      205
     1  10X,':     TYPE "HELP" FOR MORE INFORMATION     :',/,           MAIN      206
     1  10X,':..........................................:',/)           MAIN      207
      RETURN                                                            MAIN      208
      END                                                               MAIN      209
C                                                                       MAIN      210
      CHARACTER*1 FUNCTION QQ(LIN,LOUT)                                 MAIN      211
CD                                                                      MAIN      212
CD    TO WRITE Q TO QUIT AND C TO CONTINUE PROMT.                       MAIN      213
CD                                                                      MAIN      214
      WRITE(LOUT,'(A)') ' ENTER Q TO QUIT; C TO CONTINUE:'              MAIN      215
      READ(LIN,'(A)',IOSTAT=IOS) QQ                                     MAIN      216
      RETURN                                                            MAIN      217
      END                                                               MAIN      218
C                                                                       MAIN      219
      INTEGER FUNCTION IDAMAX (N, DX, INCX)                             MAIN      220
CD                                                                      MAIN      221
CD    TO FIND THE INDEX OF ELEMENT HAVING MAX. ABSOLUTE VALUE.          MAIN      222
CD                                                                      MAIN      223
      DOUBLE PRECISION DX(*), DMAX                                      MAIN      224
C                                                                       MAIN      225
C---------------------------------------------------------------------  MAIN      226
C                                                                       MAIN      227
      IDAMAX = 0                                                        MAIN      228
      IF (N .LT. 1) RETURN                                              MAIN      229
      IDAMAX = 1                                                        MAIN      230
      IF (N .EQ. 1) RETURN                                              MAIN      231
      IF (INCX .EQ. 1) GO TO 20                                         MAIN      232
C                                                                       MAIN      233
C        Code for increment not equal to 1.                             MAIN      234
C                                                                       MAIN      235
      IX = 1                                                            MAIN      236
      DMAX = ABS(DX(1))                                                 MAIN      237
      IX = IX + INCX                                                    MAIN      238
      DO 10 I = 2,N                                                     MAIN      239
         IF (ABS(DX(IX)) .LE. DMAX) GO TO 5                             MAIN      240
         IDAMAX = I                                                     MAIN      241
         DMAX = ABS(DX(IX))                                             MAIN      242
5        IX = IX + INCX                                                 MAIN      243
10    CONTINUE                                                          MAIN      244
      RETURN                                                            MAIN      245
C                                                                       MAIN      246
C        Code for increment equal to 1.                                 MAIN      247
C                                                                       MAIN      248
20    DMAX = ABS(DX(1))                                                 MAIN      249
      DO 30 I = 2,N                                                     MAIN      250
         IF (ABS(DX(I)) .LE. DMAX) GO TO 30                             MAIN      251
         IDAMAX = I                                                     MAIN      252
         DMAX = ABS(DX(I))                                              MAIN      253
30    CONTINUE                                                          MAIN      254
      RETURN                                                            MAIN      255
      END                                                               MAIN      256
C                                                                       MAIN      257
      DOUBLE PRECISION FUNCTION DDOT (N, DX, INCX, DY, INCY)            MAIN      258
CD -------------------------------------------------------------------  MAIN      259
CD                                                                      MAIN      260
CD              *****     DDOT    ROUTINE   *****                       MAIN      261
CD                                                                      MAIN      262
CD -------------------------------------------------------------------  MAIN      263
CD                                                                      MAIN      264
CD    Forms the dot product of two vectors.                             MAIN      265
CD    Uses unrolled loops for increments equal to one.                  MAIN      266
CD    JACK DONGARRA, LINPACK, 3/11/78.                                  MAIN      267
CD                                                                      MAIN      268
CD -------------------------------------------------------------------  MAIN      269
C                                                                       MAIN      270
      DOUBLE PRECISION DX(*), DY(*), DTEMP                              MAIN      271
C                                                                       MAIN      272
C---------------------------------------------------------------------  MAIN      273
C                                                                       MAIN      274
      DDOT = 0.0D0                                                      MAIN      275
      DTEMP = 0.0D0                                                     MAIN      276
      IF (N .LE. 0) RETURN                                              MAIN      277
      IF (INCX .EQ. 1 .AND. INCY .EQ. 1) GO TO 20                       MAIN      278
C                                                                       MAIN      279
C        Code for unequal increments or equal increments                MAIN      280
C          not equal to 1.                                              MAIN      281
C                                                                       MAIN      282
      IX = 1                                                            MAIN      283
      IY = 1                                                            MAIN      284
      IF (INCX .LT. 0) IX = (-N + 1) * INCX + 1                         MAIN      285
      IF (INCY .LT. 0) IY = (-N + 1) * INCY + 1                         MAIN      286
      DO 10 I = 1, N                                                    MAIN      287
        DTEMP = DTEMP + DX(IX) * DY(IY)                                 MAIN      288
        IX = IX + INCX                                                  MAIN      289
        IY = IY + INCY                                                  MAIN      290
   10 CONTINUE                                                          MAIN      291
      DDOT = DTEMP                                                      MAIN      292
      RETURN                                                            MAIN      293
C                                                                       MAIN      294
C        Code for both increments equal to 1.                           MAIN      295
C                                                                       MAIN      296
C                                                                       MAIN      297
C        Clean-up loop.                                                 MAIN      298
C                                                                       MAIN      299
   20 M = MOD(N,5)                                                      MAIN      300
      IF (M .EQ. 0) GO TO 40                                            MAIN      301
      DO 30 I = 1, M                                                    MAIN      302
        DTEMP = DTEMP + DX(I) * DY(I)                                   MAIN      303
   30 CONTINUE                                                          MAIN      304
      IF (N .LT. 5) GO TO 60                                            MAIN      305
   40 MP1 = M + 1                                                       MAIN      306
      DO 50 I = MP1, N, 5                                               MAIN      307
        DTEMP = DTEMP + DX(I) * DY(I) + DX(I+1) * DY(I+1) +             MAIN      308
     *    DX(I+2) * DY(I+2) + DX(I+3) * DY(I+3) + DX(I+4) * DY(I+4)     MAIN      309
   50 CONTINUE                                                          MAIN      310
   60 DDOT = DTEMP                                                      MAIN      311
      RETURN                                                            MAIN      312
      END                                                               MAIN      313
      CHARACTER * (*) FUNCTION CODE(A,M,N)                              MAIN      314
CD                                                                      MAIN      315
CD    TO CHECK VALIDITY OF FORMAT SPECIFICATIONS.                       MAIN      316
CD                                                                      MAIN      317
      INCLUDE 'CNLSTA.INS'                                              MAIN      318
      CHARACTER E * 21, FMT * 10                                        MAIN      319
      INTEGER FREE                                                      MAIN      320
C                                                                       MAIN      321
      IF (M .LE. 0 .OR. M .GT. 10 .OR. N .GT. M .OR. N .LT. 0) THEN     MAIN      322
         WRITE (LOUT,1000) M, N                                         MAIN      323
 1000    FORMAT(' IMPROPER ENCODING FORMAT (PROGRAMMING ERROR) :FORMAT: MAIN      324
     1','F',I2,'.',I1)                                                  MAIN      325
         CODE = '**********'                                            MAIN      326
         RETURN                                                         MAIN      327
      ENDIF                                                             MAIN      328
C ***                                                                   MAIN      329
C *** Skip under/overflow tests for zero's                              MAIN      330
C ***                                                                   MAIN      331
      IF (A .EQ. 0) THEN                                                MAIN      332
         CODE = ' '                                                     MAIN      333
         RETURN                                                         MAIN      334
      ENDIF                                                             MAIN      335
C ***                                                                   MAIN      336
C *** Encode WORD in maximum F21.10 (ten digits on either               MAIN      337
C *** side of decimal point.                                            MAIN      338
C ***                                                                   MAIN      339
      WRITE (E,1100) A                                                  MAIN      340
 1100 FORMAT(F21.10)                                                    MAIN      341
C ***                                                                   MAIN      342
C *** Compress leading blanks                                           MAIN      343
C ***                                                                   MAIN      344
      LAST = 21                                                         MAIN      345
 1200 LAST = LAST - 1                                                   MAIN      346
      IF (E(1:1) .EQ. ' ') THEN                                         MAIN      347
         E(1:) = E(2:)                                                  MAIN      348
         GO TO 1200                                                     MAIN      349
      ENDIF                                                             MAIN      350
C ***                                                                   MAIN      351
C *** Eliminate leading "0"                                             MAIN      352
C ***                                                                   MAIN      353
      IF (E(1:1) .EQ. '-' .AND. E(2:2) .EQ. '0') THEN                   MAIN      354
         E(2:) = E(3:)                                                  MAIN      355
      ELSE IF (E(1:1) .EQ. '0') THEN                                    MAIN      356
         E(1:) = E(2:)                                                  MAIN      357
      ENDIF                                                             MAIN      358
C ***                                                                   MAIN      359
C *** Locate decimal point                                              MAIN      360
C ***                                                                   MAIN      361
      ID = INDEX (E,'.') - 1                                            MAIN      362
C ***                                                                   MAIN      363
C *** Compute available characters for mantissa                         MAIN      364
C ***                                                                   MAIN      365
      FREE = M - N - ID                                                 MAIN      366
C ***                                                                   MAIN      367
C *** Three conditions exist for encoding "E":                          MAIN      368
C ***                                                                   MAIN      369
C *** 1.  Word fits perfectly into M.N.  Encode word in                 MAIN      370
C ***     M+1.N and squeeze out decimal point.                          MAIN      371
C ***                                                                   MAIN      372
      IF (FREE .EQ. 0 .OR. FREE .EQ. 1) THEN                            MAIN      373
         WRITE (FMT,1300) M + 2, N                                      MAIN      374
 1300    FORMAT ('(F',I2,'.',I2,')')                                    MAIN      375
         WRITE (E,FMT) A                                                MAIN      376
         IF (E(1:1) .EQ. ' ') THEN                                      MAIN      377
            E = E(2:)                                                   MAIN      378
            ID = INDEX (E,'.')                                          MAIN      379
            E(ID:) = E(ID+1:)                                           MAIN      380
            IF (ID .EQ. 2 .AND. E(1:1) .EQ. '0') E(1:1) = ' '           MAIN      381
         ELSE IF (E(1:1) .EQ. '-') THEN                                 MAIN      382
            IF (E(2:2) .EQ. '0') E(2:) = E(3:)                          MAIN      383
            ID = INDEX (E,'.')                                          MAIN      384
            E(ID:) = E(ID+1:)                                           MAIN      385
            IF (ID .EQ. 3 .AND. E(2:2) .EQ. '0') E(2:2) = ' '           MAIN      386
         ENDIF                                                          MAIN      387
C ***                                                                   MAIN      388
C *** 2. Leading blanks appear in encoded word.  Accuracy of            MAIN      389
C ***    encoding can be improved by shifting decimal point             MAIN      390
C ***    left.                                                          MAIN      391
C ***                                                                   MAIN      392
      ELSE IF (FREE .GT. 1) THEN                                        MAIN      393
         IF (ABS (A) .GE. 1.0) THEN                                     MAIN      394
            WRITE (FMT,1300) M + 1, M - ID - 1                          MAIN      395
            WRITE (E,FMT) A                                             MAIN      396
            IF (E(1:1) .EQ. ' ') THEN                                   MAIN      397
               E = E(2:)                                                MAIN      398
            ENDIF                                                       MAIN      399
         ELSE                                                           MAIN      400
            WRITE (FMT,1300) M + 2, M - ID - 1                          MAIN      401
            WRITE (E,FMT) A                                             MAIN      402
            IF (E(1:1) .EQ. ' ') THEN                                   MAIN      403
               E = E(2:)                                                MAIN      404
            ENDIF                                                       MAIN      405
C ***                                                                   MAIN      406
C *** Eliminate leading "0"                                             MAIN      407
C ***                                                                   MAIN      408
            IF (E(1:1) .EQ. '-' .AND. E(2:2) .EQ. '0') THEN             MAIN      409
               E(2:) = E(3:)                                            MAIN      410
            ELSE IF (E(1:1) .EQ. '0') THEN                              MAIN      411
               E(1:) = E(2:)                                            MAIN      412
            ENDIF                                                       MAIN      413
         ENDIF                                                          MAIN      414
C ***                                                                   MAIN      415
C *** 3. Overflow occurs in present format.  Check if shifting          MAIN      416
C ***    the decimal point to the right suffices.                       MAIN      417
C ***                                                                   MAIN      418
      ELSE IF (FREE .LT. 0) THEN                                        MAIN      419
         IF (M-1 .LT. ID) THEN                                          MAIN      420
            WRITE (LOUT,1400) A, M, N                                   MAIN      421
 1400       FORMAT(' DATA OVERFLOW ',E12.5,' FORMAT: ','F',I2,          MAIN      422
     1       '.',I1)                                                    MAIN      423
            CODE = '**********'                                         MAIN      424
            RETURN                                                      MAIN      425
         ELSE                                                           MAIN      426
            WRITE (FMT,1300) M + 1, M - ID - 1                          MAIN      427
            WRITE (E,FMT) A                                             MAIN      428
            IF (E(1:1) .EQ. ' ') THEN                                   MAIN      429
               E = E(2:)                                                MAIN      430
            ENDIF                                                       MAIN      431
         ENDIF                                                          MAIN      432
      ENDIF                                                             MAIN      433
      CODE = E                                                          MAIN      434
      RETURN                                                            MAIN      435
      END                                                               MAIN      436
      LOGICAL FUNCTION ODD( TVAL )                                      MAIN      437
CD                                                                      MAIN      438
CD    TO DETERMINE ODD AND EVEN INTEGER TVAL.                           MAIN      439
CD                                                                      MAIN      440
      INTEGER IVAL, TVAL                                                MAIN      441
      IVAL = TVAL / 2                                                   MAIN      442
      IVAL = IVAL * 2                                                   MAIN      443
      IF( IVAL.EQ.TVAL ) THEN                                           MAIN      444
        ODD = .FALSE.                                                   MAIN      445
      ELSE                                                              MAIN      446
        ODD = .TRUE.                                                    MAIN      447
      ENDIF                                                             MAIN      448
      RETURN                                                            MAIN      449
      END                                                               MAIN      450
      INTEGER FUNCTION IFNBLK(STRING,LL)                                MAIN      451
CD                                                                      MAIN      452
CD    TO DETERMINE THE FIRST NON-BLANK OF A CHARACTER STRING.           MAIN      453
CD                                                                      MAIN      454
      CHARACTER*(*) STRING                                              MAIN      455
C                                                                       MAIN      456
      DO 100 IFNBLK=1,LL+1                                              MAIN      457
      IF(STRING(IFNBLK:IFNBLK).NE.' ') RETURN                           MAIN      458
 100  CONTINUE                                                          MAIN      459
      IFNBLK=0                                                          MAIN      460
      RETURN                                                            MAIN      461
      END                                                               MAIN      462
C                                                                       MAIN      463
      INTEGER FUNCTION IFBLK(STRING,LL)                                 MAIN      464
CD                                                                      MAIN      465
CD    TO DETERMINE FIRST BLANK OF A CHARACTER STRING.                   MAIN      466
CD                                                                      MAIN      467
C                                                                       MAIN      468
      CHARACTER*(*) STRING                                              MAIN      469
C                                                                       MAIN      470
      DO 100 IFBLK=1,LL+1                                               MAIN      471
      IF(STRING(IFBLK:IFBLK).EQ.' ') RETURN                             MAIN      472
 100  CONTINUE                                                          MAIN      473
      IFBLK=0                                                           MAIN      474
      RETURN                                                            MAIN      475
      END                                                               MAIN      476
C                                                                       MAIN      477
      CHARACTER*12 FUNCTION FMTOUT(R)                                   MAIN      478
CD                                                                      MAIN      479
CD    TO DETERMINE THE FORM OF A FORMAT SEPCIFICATION.                  MAIN      480
CD                                                                      MAIN      481
      CHARACTER*20 FMT                                                  MAIN      482
      WRITE(FMT,'(F20.9)') R                                            MAIN      483
      I=0                                                               MAIN      484
  100 I=I+1                                                             MAIN      485
      IF(FMT(I:I).EQ.' ') GOTO 100                                      MAIN      486
      FMTOUT=FMT(I:)                                                    MAIN      487
      RETURN                                                            MAIN      488
      END                                                               MAIN      489
      LOGICAL FUNCTION ABORT(STRING)                                    MAIN      490
CD                                                                      MAIN      491
CD    TO WRITE ABORT MESSAGE.                                           MAIN      492
CD                                                                      MAIN      493
      CHARACTER*(*) STRING                                              MAIN      494
      INCLUDE 'CNLSTA.INS'                                              MAIN      495
      IF((STRING(1:4).EQ.'QUIT').OR.(STRING(1:5).EQ.'ABORT').OR.        MAIN      496
     1(STRING(1:4).EQ.'quit').OR.(STRING(1:5).EQ.'abort') )THEN         MAIN      497
        ABORT=.TRUE.                                                    MAIN      498
        WRITE(LOUT,'(/10X,A,/)')'** FUNCTION ABORTED **'                MAIN      499
      ELSE                                                              MAIN      500
        ABORT=.FALSE.                                                   MAIN      501
      ENDIF                                                             MAIN      502
      RETURN                                                            MAIN      503
      END                                                               MAIN      504
C                                                                       MAIN      505
      SUBROUTINE ALPHAN(STRING,N,IALPHA)                                MAIN      506
CD                                                                      MAIN      507
CD    TO DETERMINE IF A CHARACTER IN A STRING IS NUMERICAL OR           MAIN      508
CD    NON-NUMERICAL.                                                    MAIN      509
CD                                                                      MAIN      510
      CHARACTER*80 STRING                                               MAIN      511
      CHARACTER*1  NEMUN(9)                                             MAIN      512
      DATA NEMUN/'1','2','3','4','5','6','7','8','9'/                   MAIN      513
      IALPHA=0                                                          MAIN      514
      DO 10 I=1,9                                                       MAIN      515
      IF(STRING(N:N).EQ.NEMUN(I))THEN                                   MAIN      516
      IALPHA=1                                                          MAIN      517
      RETURN                                                            MAIN      518
      ENDIF                                                             MAIN      519
 10   CONTINUE                                                          MAIN      520
      RETURN                                                            MAIN      521
      END                                                               MAIN      522
C                                                                       MAIN      523
      INTEGER FUNCTION ITERPQ(I,J)                                      MAIN      524
C                                                                       MAIN      525
      INCLUDE 'CNLCOM.INS'                                              MAIN      526
      INCLUDE 'CDLCOM.INS'                                              MAIN      527
C                                                                       MAIN      528
      ITERPQ=1                                                          MAIN      529
      DO 200 K=1,3                                                      MAIN      530
      IF(I.NE.ITERML(K,1))GOTO 200                                      MAIN      531
      L=K-3                                                             MAIN      532
      DO 100 II=1,3                                                     MAIN      533
      L=L+3                                                             MAIN      534
      IF(J.NE.ITERML(L,2))GOTO 100                                      MAIN      535
      ITERPQ=L                                                          MAIN      536
      GOTO 300                                                          MAIN      537
 100  CONTINUE                                                          MAIN      538
 200  CONTINUE                                                          MAIN      539
 300  CONTINUE                                                          MAIN      540
      RETURN                                                            MAIN      541
      END                                                               MAIN      542
      SUBROUTINE PACK(CKT,JR,JFIN)                                      MAIN      543
*IF -PRIME                                                              MAIN      544
*IF -MIBM                                                               MAIN      545
      CHARACTER*2 CKT                                                   MAIN      546
      CHARACTER*4 RCKT                                                  MAIN      547
C                                                                       MAIN      548
      EQUIVALENCE (RCKT,JRCKT)                                          MAIN      549
C                                                                       MAIN      550
      DATA I16B/65536/                                                  MAIN      551
C                                                                       MAIN      552
      RCKT=CKT(1:2)//CKT(1:2)                                           MAIN      553
      JRCKT=JRCKT/I16B                                                  MAIN      554
C                                                                       MAIN      555
      JFIN=JRCKT*I16B+JR                                                MAIN      556
C                                                                       MAIN      557
      RETURN                                                            MAIN      558
C                                                                       MAIN      559
      ENTRY UNPACK(CKT,JR,JFIN)                                         MAIN      560
C                                                                       MAIN      561
      JRCKT=JFIN/I16B                                                   MAIN      562
      JR=MOD(JFIN,I16B)                                                 MAIN      563
*IF -DIGITAL                                                            MAIN      564
      CKT(1:2)=RCKT(3:4)                                                MAIN      565
*ENDIF                                                                  MAIN      566
*IF DIGITAL                                                             MAIN      567
*ENDIF                                                                  MAIN      569
*ENDIF                                                                  MAIN      570
*IF MIBM                                                                MAIN      571
*ENDIF                                                                  MAIN      584
C                                                                       MAIN      585
*ENDIF                                                                  MAIN      586
*IF PRIME                                                               MAIN      587
*ENDIF                                                                  MAIN      610
C                                                                       MAIN      611
      RETURN                                                            MAIN      612
      END                                                               MAIN      613
      SUBROUTINE PACKII(J1,J2,JFIN)                                     MAIN      614
C                                                                       MAIN      615
      DATA I16B/65536/                                                  MAIN      616
C                                                                       MAIN      617
      JFIN=J1*I16B+J2                                                   MAIN      618
C                                                                       MAIN      619
      RETURN                                                            MAIN      620
C                                                                       MAIN      621
      ENTRY UPACKI(J1,J2,JFIN)                                          MAIN      622
C                                                                       MAIN      623
      J1=JFIN/I16B                                                      MAIN      624
      J2=MOD(JFIN,I16B)                                                 MAIN      625
C                                                                       MAIN      626
      RETURN                                                            MAIN      627
      END                                                               MAIN      628
C                                                                       MAIN      629
      SUBROUTINE LOGEN (UID1,MCID,JFOUND)                               MAIN      630
C                                                                       MAIN      631
      CHARACTER*2 UID1,MCID,UID2                                        MAIN      632
C                                                                       MAIN      633
      IF(UID1.EQ.MCID)THEN                                              MAIN      634
        JFOUND=1                                                        MAIN      635
      ELSEIF(UID1(1:1).EQ.' '.OR.UID1(2:2).EQ.' ')THEN                  MAIN      636
        UID2(1:1)=UID1(2:2)                                             MAIN      637
        UID2(2:2)=UID1(1:1)                                             MAIN      638
        IF(UID2.EQ.MCID)THEN                                            MAIN      639
          JFOUND=1                                                      MAIN      640
        ELSE                                                            MAIN      641
          JFOUND=0                                                      MAIN      642
        ENDIF                                                           MAIN      643
      ELSE                                                              MAIN      644
        JFOUND=0                                                        MAIN      645
      ENDIF                                                             MAIN      646
C                                                                       MAIN      647
      RETURN                                                            MAIN      648
      END                                                               MAIN      649
