CFPRIME FUNCTN                                                          FUNCTN      1
C***********************************************************************RIGHTE      1
C*                                                                     *RIGHTE      2
C*               Output Analysis Program for ETMSP (OAP)               *RIGHTE      4
C*               =======================================               *RIGHTE      5
C*                                                                     *RIGHTE     11
C*        copyright @(1993) Electric Power Research Institute          *RIGHTE     12
C*                                                                     *RIGHTE     13
C* EPRI reserves all rights in the software and associated             *RIGHTE     14
C* documentation as delivered. The software and its associated         *RIGHTE     15
C* documention or any portion thereof may not be reproduced in any form*RIGHTE     16
C* whatsoever without the consent of EPRI, except as explicity provided*RIGHTE     17
C* for by license. Licensee shall submit a detailed description to EPRI*RIGHTE     18
C* of any changes or modifications to the software within two (2)      *RIGHTE     19
C* months after such changes or modifications are made. At EPRI's sole *RIGHTE     20
C* discretion, the software, as changed or modified, shall be given a  *RIGHTE     21
C* new designation sufficiently different from its then current        *RIGHTE     22
C* designation as to prevent mistake,confusion, or deception as between*RIGHTE     23
C* the current software as changed or modified.                        *RIGHTE     24
C*                                                                     *RIGHTE     25
C* A license under EPRI's rights in the software can be obtained       *RIGHTE     26
C* directly from EPRI.                                                 *RIGHTE     27
C*                                                                     *RIGHTE     28
C* This program and supporting materials may be independently available*RIGHTE     29
C* from Electric Power Software centre (EPSC) for an appropriate       *RIGHTE     30
C* distribution fee. The EPSC is a service of                          *RIGHTE     31
C*                                                                     *RIGHTE     32
C*                    Power Computing Company                          *RIGHTE     33
C*                    1930 Hi Line                                     *RIGHTE     34
C*                    Dallas, Tx 75207                                 *RIGHTE     35
C*                                                                     *RIGHTE     36
C* NEITHER EPRI, ANY MEMBER OF EPRI, NOR ANY PERSON OR  ORGANIZATION   *RIGHTE     37
C* ACTING ON BEHAVE OF THEM:                                           *RIGHTE     38
C*                                                                     *RIGHTE     39
C* 1. MAKE ANY WARRANTY OR REPRESENTATION WHATSOEVER, EXPRESS OR       *RIGHTE     40
C*    IMPLIED, INCLUDING ANY WARRANTY OF MERCHANTABILITY OR FITNESS OR *RIGHTE     41
C*    ANY PURPOSE WITH RESPECT TO THE SOFTWARE OR ITS ASSOCIATED       *RIGHTE     42
C*    DOCUMENTATION; OR                                                *RIGHTE     43
C*                                                                     *RIGHTE     44
C* 2. ASSUMES ANY LIABILITY WHATSOEVER WITH RESPECT TO ANY USE OF THE  *RIGHTE     45
C*    SOFTWARE OR ITS ASSOCIATED DOCUMENTATION OR ANY PORTION THEREOF  *RIGHTE     46
C*    OR WITH RESPECT TO ANY DAMAGES WHICH MAY RESULT FROM SUCH USE.   *RIGHTE     47
C*                                                                     *RIGHTE     48
C* THIS NOTICE MAY NOT BE REMOVED FROM THE SOFTWARE BY ANY USER        *RIGHTE     49
C* THEREOF.                                                            *RIGHTE     50
C*                                                                     *RIGHTE     51
C***********************************************************************RIGHTE     52
C                                                                       FUNCTN      3
      SUBROUTINE FUNCTN(PARAM,LENPAR)                                   FUNCTN      4
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCFFUNCTN      5
CD                                                                      FUNCTN      6
CD            THIS ROUTINE IS THE MAIN DRIVER TO DIFFERENT FUNCTION     FUNCTN      7
CD            OPTIONS BASED ON THE COMMAND SUPPLIED BY THE USERS        FUNCTN      8
CD                                                                      FUNCTN      9
CD            CALLING PARAMETERS :                                      FUNCTN     10
CD                                                                      FUNCTN     11
CD                      PARAM    - INPUT COMMAND                        FUNCTN     12
CD                      LENPAR   - NUMBER OF CHARACTER IN PARAM         FUNCTN     13
CD                                                                      FUNCTN     14
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCFUNCTN     15
      INCLUDE 'PARAM.INS'                                               FUNCTN     16
      INCLUDE 'SOAPC1.INS'                                              FUNCTN     17
      INCLUDE 'BUFBIG.INS'                                              FUNCTN     18
      INCLUDE 'XYARAY.INS'                                              FUNCTN     19
      INCLUDE 'DBFLG.INS'                                               FUNCTN     20
      INCLUDE 'CHDISP.INS'                                              FUNCTN     21
      CHARACTER*80 MSG                                                  FUNCTN     22
      CHARACTER*50 PARAM                                                FUNCTN     23
C                                                                       FUNCTN     24
      LDEBUG=DEBUG(6)                                                   FUNCTN     25
      IF(LDEBUG) WRITE(LOUT,1000) LENPAR,PARAM                          FUNCTN     26
C                                                                       FUNCTN     27
      IF(PARAM(1:3).EQ.'CAL'.OR.PARAM(1:3).EQ.'cal') THEN               FUNCTN     28
C   Arithmetic Functions                                                FUNCTN     29
        IF(IPLTYP.EQ.3)THEN                                             FUNCTN     30
          WRITE(LOUT,6100)                                              FUNCTN     31
          GOTO 9999                                                     FUNCTN     32
        ELSEIF(IPLTYP.EQ.2)THEN                                         FUNCTN     33
          WRITE(LOUT,6200)                                              FUNCTN     34
        ENDIF                                                           FUNCTN     35
        CALL FNCTN                                                      FUNCTN     36
C                                                                       FUNCTN     37
      ELSE IF(PARAM(1:3).EQ.'RLY'.OR.PARAM(1:3).EQ.'rly') THEN          FUNCTN     38
C   Perform relay analysis                                              FUNCTN     39
        WRITE(LOUT,'(/,A,/)')                                           FUNCTN     40
     +  ' * THIS FEATURE OF OAP IS CURRENTLY UNDER DEVELOPMENT * '      FUNCTN     41
C        CALL RELAN                                                     FUNCTN     42
C                                                                       FUNCTN     43
      ELSE IF(PARAM(1:3).EQ.'LSF'.OR.PARAM(1:3).EQ.'lsf') THEN          FUNCTN     44
C   Least Squares Fit                                                   FUNCTN     45
        IF((FILLED).AND.IPLTYP.EQ.2)THEN                                FUNCTN     46
          WRITE(LOUT,5100)                                              FUNCTN     47
          GOTO 9999                                                     FUNCTN     48
        ELSE                                                            FUNCTN     49
          CALL GET1CH(*9999)                                            FUNCTN     50
          CALL FNTTRN(XA,YA,NOGO)                                       FUNCTN     51
        ENDIF                                                           FUNCTN     52
C                                                                       FUNCTN     53
      ELSE IF(PARAM(1:3).EQ.'ENV'.OR.PARAM(1:3).EQ.'env') THEN          FUNCTN     54
C   Envelope analysis                                                   FUNCTN     55
        IF((FILLED).AND.IPLTYP.EQ.2)THEN                                FUNCTN     56
          WRITE(LOUT,5100)                                              FUNCTN     57
          GOTO 9999                                                     FUNCTN     58
        ELSE                                                            FUNCTN     59
          CALL GET1CH(*9999)                                            FUNCTN     60
          CALL FNTENV(XA,YA,NOGO)                                       FUNCTN     61
        ENDIF                                                           FUNCTN     62
      ELSE                                                              FUNCTN     63
        WRITE(LOUT,5000)                                                FUNCTN     64
      ENDIF                                                             FUNCTN     65
C                                                                       FUNCTN     66
 9999 RETURN                                                            FUNCTN     67
 1000 FORMAT(/,1X,'** DEBUG (FUNCTN) ** PARAM,LENPAR : ',I5,2X,A,/)     FUNCTN     68
 5000 FORMAT(/,                                                         FUNCTN     69
     * 10X,'*********************************',/,                       FUNCTN     70
     * 10X,'*  FUNCTION SYNTAX ERROR        *',/,                       FUNCTN     71
     * 10X,'*  Type HELP=FUNCTION for Help  *',/,                       FUNCTN     72
     * 10X,'*********************************')                         FUNCTN     73
 5100 FORMAT(/,                                                         FUNCTN     74
     + 10X,'LSF/ENV ANALYSIS CANNOT BE PERFORMED ON X-Y TYPE OF DATA',/,FUNCTN     75
     + 10X,'PLEASE CLEAR ALL BUFFERS AND START AGAIN.',/)               FUNCTN     76
 6100 FORMAT(/,                                                         FUNCTN     77
     + 10X,'BUFFER ARE CURRENTLY FILLED WITH FREQUENCY PLOTS',/,        FUNCTN     78
     + 10X,'PLEASE CLEAR ALL BUFFERS AND START AGAIN.',/)               FUNCTN     79
 6200 FORMAT(/,                                                         FUNCTN     80
     + 10X,'BUFFER ARE CURRENTLY FILLED WITH X-Y PLOTS',/,              FUNCTN     81
     + 10X,'PLEASE NOTE THAT THE PLOT COMMAND WILL YIELD X-Y PLOTS.',/) FUNCTN     82
C*********************************************************************  FUNCTN     83
C  Prony analysis                                                       FUNCTN     84
      ENTRY SPECT2                                                      FUNCTN     85
      IF((FILLED).AND.IPLTYP.NE.1)THEN                                  FUNCTN     86
        WRITE(LOUT,5200)                                                FUNCTN     87
      ELSE                                                              FUNCTN     88
        CALL GET1CH(*9990)                                              FUNCTN     89
        CALL SPECT1(XA,YA,NOGO)                                         FUNCTN     90
      ENDIF                                                             FUNCTN     91
 9990 RETURN                                                            FUNCTN     92
 5200 FORMAT(/,                                                         FUNCTN     93
     + 10X,'PRONY ANALYSIS CAN BE PERFORMED ON TIME FUNCTIONS ONLY.',/, FUNCTN     94
     + 10X,'PLEASE CLEAR ALL BUFFERS AND START AGAIN.',/)               FUNCTN     95
C                                                                       FUNCTN     96
      END                                                               FUNCTN     97
C*********************************************************************  FUNCTN     98
C                                                                       FUNCTN     99
      SUBROUTINE GET1CH (*)                                             FUNCTN    100
CD                                                                      FUNCTN    101
CD    TO LOAD ONE CHANNEL INTO XA AND YA IN ORDER TO PERFORM            FUNCTN    102
CD    PRONY, TREND OR ENVELOPE ANALYSIS                                 FUNCTN    103
CD                                                                      FUNCTN    104
C                                                                       FUNCTN    105
      INCLUDE 'PARAM.INS'                                               FUNCTN    106
      INCLUDE 'SOAPC1.INS'                                              FUNCTN    107
      INCLUDE 'BUFBIG.INS'                                              FUNCTN    108
      INCLUDE 'XYARAY.INS'                                              FUNCTN    109
      INCLUDE 'GPINFO.INS'                                              FUNCTN    110
      INCLUDE 'JJNAME.INS'                                              FUNCTN    111
      INCLUDE 'GTIT.INS'                                                FUNCTN    112
      INCLUDE 'CHDISP.INS'                                              FUNCTN    113
C                                                                       FUNCTN    114
      CHARACTER*2 UID                                                   FUNCTN    115
      CHARACTER*80 MSG,STRING                                           FUNCTN    116
C                                                                       FUNCTN    117
      CHARACTER*80 TITCAS,TITSWI,TITEXT                                 FUNCTN    118
      CHARACTER*12 TITDAT                                               FUNCTN    119
      CHARACTER*4  TITVER                                               FUNCTN    120
C                                                                       FUNCTN    121
      DIMENSION XMMIN(MCHNL+1),XMMAX(MCHNL+1),XAMIN(MCHNL+1),           FUNCTN    122
     +          XAMAX(MCHNL+1)                                          FUNCTN    123
C                                                                       FUNCTN    124
      COMMON /BITEXT/ TITCAS,TITSWI,TITEXT,TITDAT,TITVER                FUNCTN    125
      COMMON /RECPT/ KRSTRT, ISTNAM, IIDARY, ITYARY, IHREC,ICHAN,       FUNCTN    126
     *          NPFL,LRREC,IRREC                                        FUNCTN    127
C                                                                       FUNCTN    128
      IF(FILLED)THEN                                                    FUNCTN    129
        WRITE(LOUT,2000)                                                FUNCTN    130
        MSG='Do you wish to proceed (Y/N)? :'                           FUNCTN    131
 3000   CALL PMTRED(LOUT,LIN,JERR,31,MSG,'SP7',STRING)                  FUNCTN    132
        IF(JERR.LT.0)GOTO 3000                                          FUNCTN    133
        IF(RECORD) WRITE(IREC,'(A)') STRING                             FUNCTN    134
        IF(STRING(1:1).EQ.'N'.OR.STRING(1:1).EQ.'n')THEN                FUNCTN    135
          NOGO=-1                                                       FUNCTN    136
          RETURN 1                                                      FUNCTN    137
        ENDIF                                                           FUNCTN    138
        IF(STRING(1:1).EQ.'Y'.OR.STRING(1:1).EQ.'y')GOTO 3500           FUNCTN    139
        GOTO 3000                                                       FUNCTN    140
      ELSEIF (OPENED) THEN                                              FUNCTN    141
        MSG='Enter channel number (Q to quit): '                        FUNCTN    142
 3100   CALL PMTRED(LOUT,LIN,JERR,34,MSG,'SP7',STRING)                  FUNCTN    143
        IF(JERR.LT.0)GOTO 3100                                          FUNCTN    144
        IF(RECORD)WRITE(IREC,'(A)') STRING                              FUNCTN    145
        IF(STRING(1:1).EQ.'Q'.OR.STRING(1:1).EQ.'q') RETURN 1           FUNCTN    146
        READ(STRING,*,IOSTAT=IOS)ICN                                    FUNCTN    147
        IF(IOS.NE.0)GOTO 3100                                           FUNCTN    148
        IF(ICN.LT.11.OR.ICN.GT.ICHAN)THEN                               FUNCTN    149
          WRITE(LOUT,4000)ICHAN                                         FUNCTN    150
          GOTO 3100                                                     FUNCTN    151
        ENDIF                                                           FUNCTN    152
        CALL GPPAGE                                                     FUNCTN    153
        FILLED=.TRUE.                                                   FUNCTN    154
        KCH(1)=1                                                        FUNCTN    155
        KCH(2)=ICN                                                      FUNCTN    156
        CALL UNPACK(UID,NTYPE,ITY(1,ICN))                               FUNCTN    157
        CALL WNTYPE(NTYPE,NTIT,NSTATE)                                  FUNCTN    158
        IPLTYP=1                                                        FUNCTN    159
        ICHTYP(1)=0                                                     FUNCTN    160
        DISPCH(1,1)=' '                                                 FUNCTN    161
        DISPCH(2,1)=' '                                                 FUNCTN    162
        IF(NTIT.GE.36.AND.NTIT.LE.41)THEN                               FUNCTN    163
          WRITE(DISPCH(1,1),5100)ICN,ITY(2,ICN),JNAME(1,ICN),           FUNCTN    164
     +     JNAME(2,ICN),JNAME(3,ICN)                                    FUNCTN    165
          WRITE(DISPCH(2,1),5200)ITY(3,ICN),JNAME(4,ICN),               FUNCTN    166
     +     JNAME(5,ICN),JNAME(6,ICN),UID,GRPTIL(NTIT)(1:35)             FUNCTN    167
        ELSEIF(NTIT.GE.42.AND.NTIT.LE.43)THEN                           FUNCTN    168
          WRITE(DISPCH(1,1),5300)ICN,JNAME(1,ICN),JNAME(2,ICN),         FUNCTN    169
     +     JNAME(3,ICN),JNAME(4,ICN),JNAME(5,ICN),JNAME(6,ICN),         FUNCTN    170
     +     GRPTIL(NTIT)(1:35)                                           FUNCTN    171
        ELSE                                                            FUNCTN    172
          WRITE(DISPCH(1,1),5400)ICN,ITY(2,ICN),JNAME(1,ICN),           FUNCTN    173
     +     JNAME(2,ICN),JNAME(3,ICN),UID,GRPTIL(NTIT)(1:35)             FUNCTN    174
        ENDIF                                                           FUNCTN    175
        IF(NTIT.EQ.4.AND.RELATE)THEN                                    FUNCTN    176
          YTITLE(1)='GENERATOR RELATIVE ANGLE'                          FUNCTN    177
        ELSE                                                            FUNCTN    178
          YTITLE(1)=GRPTIL(NTIT)                                        FUNCTN    179
          IF(NTIT.EQ.54.OR.NTIT.EQ.55)                                  FUNCTN    180
     *    WRITE(YTITLE(1)(30:35),'(I6)') NSTATE                         FUNCTN    181
        ENDIF                                                           FUNCTN    182
        CALL BUSNAM(LTITLE(1),ICN,KLFO,III)                             FUNCTN    183
        WRITE(LTITL2(1),'(A,I3)') 'CH# ',ICN                            FUNCTN    184
        CTITLE(1)=TITCAS                                                FUNCTN    185
        CTITL2(1)=CHNLFI                                                FUNCTN    186
        FILCHN(1)=CHNLFI                                                FUNCTN    187
        CASEID(1)=CASID                                                 FUNCTN    188
        CALL RECFLD(ICN,KRECFD(2,1),KRECFD(2,2))                        FUNCTN    189
        WRITE(LOUT,5500)                                                FUNCTN    190
        CALL REMASS(T,YARAY,MXPT,MXPLOT,ICHNL,1,1,KRECFD)               FUNCTN    191
        XMMIN(1)=T(1,1)                                                 FUNCTN    192
        XMMAX(1)=T(MAXPT(1),1)                                          FUNCTN    193
        XAMIN(1)=XMMIN(1)                                               FUNCTN    194
        XAMAX(1)=XMMAX(1)                                               FUNCTN    195
        XTITLE='TIME IN SECONDS'                                        FUNCTN    196
        IDX1(1)=1                                                       FUNCTN    197
        IDX2(1)=MAXPT(1)                                                FUNCTN    198
        XMMIN(2)=999999.0                                               FUNCTN    199
        XMMAX(2)=-999999.0                                              FUNCTN    200
        DO 3200 II=1,MAXPT(1)                                           FUNCTN    201
          XARAY(II,1)=T(II,1)                                           FUNCTN    202
          IF(XMMIN(2).GT.YARAY(II,1))XMMIN(2)=YARAY(II,1)               FUNCTN    203
          IF(XMMAX(2).LT.YARAY(II,1))XMMAX(2)=YARAY(II,1)               FUNCTN    204
 3200   CONTINUE                                                        FUNCTN    205
        XMMIN(8)=XMMIN(2)                                               FUNCTN    206
        XMMAX(8)=XMMAX(2)                                               FUNCTN    207
        IF(IFLG.NE.2)THEN                                               FUNCTN    208
          CALL YSCALE (XMMIN(2),XMMAX(2),XAMIN(2),XAMAX(2))             FUNCTN    209
          CALL YSCALE (XMMIN(8),XMMAX(8),XAMIN(8),XAMAX(8))             FUNCTN    210
        ENDIF                                                           FUNCTN    211
        GSCALE=.FALSE.                                                  FUNCTN    212
        CALL SCALEV(XAMIN(1),XAMAX(1),XAMIN(2),XAMAX(2),1)              FUNCTN    213
        CALL SCALED(XAMIN(1),XAMAX(1),XAMIN(2),XAMAX(2),1)              FUNCTN    214
        SCALX=.FALSE.                                                   FUNCTN    215
      ELSE                                                              FUNCTN    216
        WRITE(LOUT,5600)                                                FUNCTN    217
        RETURN 1                                                        FUNCTN    218
      ENDIF                                                             FUNCTN    219
C                               Transfer data to prony anaylsis arrays  FUNCTN    220
 3500 DO 8100 I=1,MAXPT(1)                                              FUNCTN    221
        XA(I,1)=XARAY(I,1)                                              FUNCTN    222
        YA(I,1)=YARAY(I,1)                                              FUNCTN    223
 8100 CONTINUE                                                          FUNCTN    224
C                                                                       FUNCTN    225
      RETURN                                                            FUNCTN    226
C                                                                       FUNCTN    227
 2000 FORMAT(/,                                                         FUNCTN    228
     + 10X,'Buffer already filled from the last read.',/,               FUNCTN    229
     + 10X,'Analysis will be performed on buffer #1.',/,                FUNCTN    230
     + 10x,'Remaining buffers may be overwritten.',//)                  FUNCTN    231
 4000 FORMAT(' *** ERROR CHANNEL NUMBER MUST BE BETWEEN 11 AND',I3,'.') FUNCTN    232
 5100 FORMAT(I6,'   (F)',I6,1X,3A4)                                     FUNCTN    233
 5200 FORMAT(9X,'(T)',I6,1X,3A4,1X,A2,4X,A)                             FUNCTN    234
 5300 FORMAT(I6,7X,6A4,1X,A)                                            FUNCTN    235
 5400 FORMAT(I6,I12,1X,3A4,1X,A2,4X,A)                                  FUNCTN    236
 5500 FORMAT(/,                                                         FUNCTN    237
     + 10X,'...................................',/,                     FUNCTN    238
     + 10X,':   READING CHANNEL FILE. WAIT    :',/,                     FUNCTN    239
     + 10X,':.................................:')                       FUNCTN    240
 5600 FORMAT(/,                                                         FUNCTN    241
     + 10X,'**************************************************',/,      FUNCTN    242
     + 10X,'*        CHANNEL FILE/DATA NOT AVAILABLE         *',/,      FUNCTN    243
     + 10X,'*   USE OPENCASE/RESTORE/OPASCII,RDASCII FIRST   *',/,      FUNCTN    244
     + 10X,'**************************************************')        FUNCTN    245
C                                                                       FUNCTN    246
      END                                                               FUNCTN    247
