diff options
Diffstat (limited to 'Ganlib/src/DRVUTL.f')
| -rw-r--r-- | Ganlib/src/DRVUTL.f | 711 |
1 files changed, 711 insertions, 0 deletions
diff --git a/Ganlib/src/DRVUTL.f b/Ganlib/src/DRVUTL.f new file mode 100644 index 0000000..36d171c --- /dev/null +++ b/Ganlib/src/DRVUTL.f @@ -0,0 +1,711 @@ +*DECK DRVUTL + SUBROUTINE DRVUTL(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY) +* +*----------------------------------------------------------------------- +* +*Purpose: +* standard utility module for linked list or xsm files. +* +*Copyright: +* Copyright (C) 1988 Ecole Polytechnique de Montreal +* This library is free software; you can redistribute it and/or +* modify it under the terms of the GNU Lesser General Public +* License as published by the Free Software Foundation; either +* version 2.1 of the License, or (at your option) any later version +* +*Author(s): R. Roy +* +*Parameters: input/output +* NENTRY number of LCM objects or files used by the operator. +* HENTRY name of each LCM object or file: +* HENTRY(1): read-only or modification type(VECTOR). +* IENTRY type of each LCM object or file: +* =1 LCM memory object; =2 XSM file; =3 sequential binary file; +* =4 sequential ascii file. +* JENTRY access of each LCM object or file: +* =0 the LCM object or file is created; +* =1 the LCM object or file is open for modifications; +* =2 the LCM object or file is open in read-only mode. +* KENTRY LCM object address or file unit number. +* +* List of utility actions: +* IMPR : print a block. +* COPY : copy a block or a directory. +* CREA : create a block. +* DEL : delete a block. +* STAT : compare two blocks. +* ADD : add two floating point blocks or directories component by +* component. +* MULT : multiply the floating point components of a block or +* directory by a constant. +* SADD : add the floating point components of a block or directory +* by a constant. +* STEP : change of directory level. +* DIR : print the active directory content. +* DUMP : dump the active and son directories on the printer. +* +*----------------------------------------------------------------------- +* + USE GANLIB +*---- +* SUBROUTINE ARGUMENTS +*---- + INTEGER :: NENTRY,IENTRY(NENTRY),JENTRY(NENTRY) + TYPE(C_PTR) :: KENTRY(NENTRY) + CHARACTER :: HENTRY(NENTRY)*12 +*---- +* LOCAL VARIABLES +*---- + INTEGER, PARAMETER :: MAXLEV=50 + TYPE(C_PTR) :: IPLIST,IPLIS1,IPKEEP(MAXLEV) + CHARACTER :: TEXT4*4,NAMT*12,NAMT2*12,NAMMY*12,NAMLCM*72, + 1 CTYP(3)*11,CENT(3)*9,HSMG*131,TEXT12*12 + INTEGER, ALLOCATABLE, DIMENSION(:) :: IARA + REAL, ALLOCATABLE, DIMENSION(:) :: ARA,ARA2 + DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:) :: DARA + CHARACTER(LEN=4), ALLOCATABLE, DIMENSION(:) :: HARA + COMPLEX, ALLOCATABLE, DIMENSION(:) :: CARA + LOGICAL, ALLOCATABLE, DIMENSION(:) :: LARA + DOUBLE PRECISION :: DFLOTT + LOGICAL :: EMPTY,LCM + DATA (CTYP(ITY),ITY=1,3)/'CLE_2000','LINKED_LIST','XSM_FILE'/ + DATA (CENT(ITY),ITY=1,3)/'CREATE','IN_OUT','READ-ONLY'/ + SAVE CTYP,CENT +*---- +* PARAMETER VALIDATION. +*---- + IF(NENTRY.EQ.0) CALL XABORT('DRVUTL: PARAMETER EXPECTED.') + TEXT12=HENTRY(1) + IF(JENTRY(1).EQ.0) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ELSE IF(JENTRY(1).EQ.1) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ELSE IF(JENTRY(1).EQ.2) THEN + IF(IENTRY(1).GT.2) CALL XABORT('DRVUTL: THE UTILITY MODULE WO' + 1 //'RKS ONLY WITH LINKED LISTS AND XSM FILES ('//TEXT12//').') + ENDIF + IND=JENTRY(1) + ITYPE=IENTRY(1) + IPLIST=KENTRY(1) + IPKEEP(1)=IPLIST + ILEV=1 + FLUSH(6) +*---- +* SET EDITION FLAG. +*---- + IMPX=1 + CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT) + IF(INDIC.EQ.10) RETURN + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'EDIT') THEN + CALL REDGET(ITYP,IMPX,FLOTT,TEXT12,DFLOTT) + IF(ITYP.NE.1) CALL XABORT('DRVUTL: NO INTEGER AFTER *EDIT*.') + ELSE + GO TO 20 + ENDIF + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(IMPX.GT.0) WRITE(6,180) CTYP(ITYPE+1),CENT(IND+1),NAMMY,NAMLCM +*---- +* PERFORM SOME UTILITY ACTIONS. +*---- + 10 CALL REDGET(INDIC,NITMA,DPREC,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + 20 IF(TEXT4.EQ.'IMPR') THEN +* PRINT A LCM OR XSM BLOCK. + CALL REDGET(INDPRT,ISET,FLOTT,NAMT,DFLOTT) + IF(INDPRT.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG,ITYBLK) + IF(ILONG.EQ.0) THEN + WRITE (6,245) ISET + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + GO TO 10 + ENDIF + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK) + IF(ILONG.EQ.0) THEN + WRITE (6,250) NAMT + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + GO TO 10 + ENDIF + ELSE + CALL XABORT('DRVUTL: BLOCK-NAME OR LIST INDEX EXPECTED.') + ENDIF + IF(ITYBLK.EQ.10) CALL XABORT('DRVUTL: '//NAMT//' IS A LIST OF' + 1 //' ARRAYS. USE A STEP UP KEYWORD TO ACCESS THE LIST.') + IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN + ALLOCATE(IARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,IARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,IARA) + ENDIF + ELSE IF(ITYBLK.EQ.2) THEN + ALLOCATE(ARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + ELSE IF(ITYBLK.EQ.4) THEN + ALLOCATE(DARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,DARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,DARA) + ENDIF + ELSE IF(ITYBLK.EQ.6) THEN + ALLOCATE(CARA(ILONG)) + IF(INDPRT.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,CARA) + ELSE IF(INDPRT.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,CARA) + ENDIF + ELSE + CALL XABORT('DRVUTL: IMPR TYPE NOT SUPPORTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + LL=99999999 + IF(INDIC.EQ.1) THEN + LL=NITMA + ELSE IF(INDIC.NE.3) THEN + CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + ELSE IF(TEXT4.NE.'*') THEN + CALL XABORT('DRVUTL: CHARACTER * EXPECTED.') + ENDIF + ICONT=0 + IMAX=MIN0(LL,ILONG) + IF(ITYBLK.EQ.1) THEN + DO I=1,ILONG + IF(IARA(I).NE.0) ICONT=ICONT+1 + ENDDO + ELSE IF(ITYBLK.EQ.2) THEN + DO I=1,ILONG + IF(ARA(I).NE.0.0) ICONT=ICONT+1 + ENDDO + ELSE IF(ITYBLK.EQ.4) THEN + DO I=1,ILONG + IF(DARA(I).NE.0.0D0) ICONT=ICONT+1 + ENDDO + IMAX=MIN0(LL,ILONG) + ELSE IF(ITYBLK.EQ.6) THEN + DO I=1,ILONG + IF(CARA(I).NE.0.0) ICONT=ICONT+1 + ENDDO + IMAX=MIN0(LL,ILONG) + ENDIF + IF(INDPRT.EQ.1) THEN + WRITE (6,225) ISET,ILONG,ICONT + ELSE IF(INDPRT.EQ.3) THEN + WRITE (6,230) NAMT,ILONG,ICONT + ENDIF + IF((IMAX.GT.0).AND.(ITYBLK.EQ.1)) THEN + WRITE (6,'(1X,13I10)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.2)) THEN + WRITE (6,'(1X,1P,10E13.4)') (ARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.3)) THEN + WRITE (6,'(1X,32A4)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.4)) THEN + WRITE(6,'(1X,1P,6D21.12)') (DARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.5)) THEN + WRITE(6,'(1X,65L2)') (IARA(I),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.6)) THEN + WRITE(6,'(1X,1P,4(2H (,E13.4,1H,,E13.4,1H)))') + 1 (REAL(CARA(I)),AIMAG(CARA(I)),I=1,IMAX) + ELSE IF((IMAX.GT.0).AND.(ITYBLK.EQ.0)) THEN + WRITE (6,240) NAMT + ENDIF + WRITE (6,'(/)') + IF((ITYBLK.EQ.1).OR.(ITYBLK.EQ.3).OR.(ITYBLK.EQ.5)) THEN + DEALLOCATE(IARA) + ELSE IF(ITYBLK.EQ.2) THEN + DEALLOCATE(ARA) + ELSE IF(ITYBLK.EQ.4) THEN + DEALLOCATE(DARA) + ELSE IF(ITYBLK.EQ.6) THEN + DEALLOCATE(CARA) + ENDIF + ELSE IF(TEXT4.EQ.'ERAS') THEN +* ERASE THE CONTENTS OF THE LCM OR XSM OBJECT. + IF(IND.EQ.2) CALL XABORT('DRVUTL: ERAS IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + IF(LCM) THEN + MEDIUM=1 + ELSE + MEDIUM=2 + ENDIF + CALL LCMCL(IPLIST,3) + CALL LCMOP(IPLIST,NAMLCM,1,MEDIUM,IMPX) + ELSE IF(TEXT4.EQ.'COPY') THEN +* COPY AND NAME A BLOCK OR DIRECTORY ON LCM OR XSM. + IF(IND.EQ.2) CALL XABORT('DRVUTL: COPY IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG,ITYBLK) + IF(ILONG.EQ.-1) THEN +* COPY A COMPLETE DIRECTORY. + CALL LCMSIX(IPLIST,NAMT,1) + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMSIX(IPLIST,NAMT2,1) + CALL LCMEXP(IPLIST,0,NUNIT,1,2) + IRC=KDRCLS(NUNIT,2) + IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.') + CALL LCMSIX(IPLIST,' ',2) + ELSE IF(ILONG.GT.0) THEN +* COPY A SINGLE RECORD. + IF((ITYBLK.EQ.4).OR.(ITYBLK.EQ.6)) THEN + ALLOCATE(ARA(2*ILONG)) + CALL LCMGET(IPLIST,NAMT,ARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA) + DEALLOCATE(ARA) + ELSEIF(ITYBLK.EQ.2) THEN + ALLOCATE(ARA(ILONG)) + CALL LCMGET(IPLIST,NAMT,ARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,ARA) + DEALLOCATE(ARA) + ELSE + ALLOCATE(IARA(ILONG)) + CALL LCMGET(IPLIST,NAMT,IARA) + CALL LCMPUT(IPLIST,NAMT2,ILONG,ITYBLK,IARA) + DEALLOCATE(IARA) + ENDIF + ELSE IF(ILONG.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED ON LCM O' + 1 //'R XSM.') + ENDIF + ELSE IF(TEXT4.EQ.'CREA') THEN + IF(IND.EQ.2) CALL XABORT('DRVUTL: CREA IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT) + INDICO=0 + IF(NTYPE.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG0,INDICO) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG0,INDICO) + ELSE + CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF + CALL REDGET(INDIC,ILONG2,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.') + ILONG1=1 + 30 CALL REDGET(INDIC,ILONG,FLOTT,TEXT4,DFLOTT) + IF(INDIC.EQ.1) THEN + IF(ILONG0.EQ.0) CALL XABORT('DRVUTL: LOWER INDEX NOT EXPEC' + 1 //'TED.') + ILONG1=ILONG2 + ILONG2=ILONG + GO TO 30 + ELSE IF((INDIC.NE.3).OR.(TEXT4.NE.'=')) THEN + CALL XABORT('DRVUTL: = SIGN EXPECTED.') + ENDIF + CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT) + IF(INDICO.EQ.99) THEN + INDICO=INDIC + ELSE IF(INDIC.NE.INDICO) THEN + CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(1).') + ENDIF + IF(INDIC.EQ.1) THEN + ALLOCATE(IARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,IARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,IARA) + ENDIF + IARA(ILONG1)=NITMA + ELSE IF(INDIC.EQ.2) THEN + ALLOCATE(ARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + ARA(ILONG1)=FLOAT + ELSE IF(INDIC.EQ.3) THEN + ALLOCATE(HARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA) + ENDIF + HARA(ILONG1)=TEXT4 + ELSE IF(INDIC.EQ.4) THEN + ALLOCATE(DARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,DARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,DARA) + ENDIF + DARA(ILONG1)=DFLOTT + ELSE IF(INDIC.EQ.5) THEN + ALLOCATE(LARA(MAX(ILONG2,ILONG0))) + IF((ILONG0.NE.0).AND.(NTYPE.EQ.1)) THEN + CALL LCMGDL(IPLIST,ISET,LARA) + ELSE IF((ILONG0.NE.0).AND.(NTYPE.EQ.3)) THEN + CALL LCMGET(IPLIST,NAMT,LARA) + ENDIF + IF (NITMA.EQ.1) THEN + LARA(ILONG1)=.TRUE. + ELSE + LARA(ILONG1)=.FALSE. + ENDIF + ENDIF + DO I=ILONG1+1,ILONG2 + CALL REDGET(INDIC,NITMA,FLOAT,TEXT4,DFLOTT) + IF(INDIC.NE.INDICO) THEN + CALL XABORT('DRVUTL: INCONSISTENT DATA TYPE(2).') + ELSE IF(INDIC.EQ.1) THEN + IARA(I)=NITMA + ELSE IF(INDIC.EQ.2) THEN + ARA(I)=FLOAT + ELSE IF(INDIC.EQ.3) THEN + HARA(I)=TEXT4 + ELSE IF(INDIC.EQ.4) THEN + DARA(I)=DFLOTT + ELSE IF(INDIC.EQ.5) THEN + IF (NITMA.EQ.1) THEN + LARA(I)=.TRUE. + ELSE + LARA(I)=.FALSE. + ENDIF + ENDIF + ENDDO + IF(NTYPE.EQ.1) THEN + IF(INDICO.EQ.1) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,IARA) + DEALLOCATE(IARA) + ELSE IF(INDICO.EQ.2) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,ARA) + DEALLOCATE(ARA) + ELSE IF(INDICO.EQ.3) THEN + CALL LCMPLC(IPLIST,ISET,4,MAX(ILONG2,ILONG0),HARA) + DEALLOCATE(HARA) + ELSE IF(INDICO.EQ.4) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,DARA) + DEALLOCATE(DARA) + ELSE IF(INDICO.EQ.5) THEN + CALL LCMPDL(IPLIST,ISET,MAX(ILONG2,ILONG0),INDICO,LARA) + DEALLOCATE(LARA) + ENDIF + ELSE IF(NTYPE.EQ.3) THEN + IF(INDICO.EQ.1) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,IARA) + DEALLOCATE(IARA) + ELSE IF(INDICO.EQ.2) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,ARA) + DEALLOCATE(ARA) + ELSE IF(INDICO.EQ.3) THEN + CALL LCMPTC(IPLIST,NAMT,4,MAX(ILONG2,ILONG0),HARA) + DEALLOCATE(HARA) + ELSE IF(INDICO.EQ.4) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,DARA) + DEALLOCATE(DARA) + ELSE IF(INDICO.EQ.5) THEN + CALL LCMPUT(IPLIST,NAMT,MAX(ILONG2,ILONG0),INDICO,LARA) + DEALLOCATE(LARA) + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'DEL') THEN +* DELETE A BLOCK. + IF(IND.EQ.2) CALL XABORT('DRVUTL: DEL IS A FORBIDDEN OPERATION' + 1 //' IN READ-ONLY MODE.') + IF(ITYPE.GT.1) CALL XABORT('DRVUTL: DEL CAN ONLY BE USED WITH ' + 1 //'LINKED-LISTS.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMDEL(IPLIST,NAMT) + ELSE IF(TEXT4.EQ.'STAT') THEN +* COMPARE TWO BLOCKS STORED ON LCM OR XSM. +* READ RELATIVE OR ABSOLUTE ERROR. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') +* RECOVERY OF THE FIRST BLOCK. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK) + IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT OF' + 1 //' REAL TYPE.') + ALLOCATE(ARA(ILONG1)) + CALL LCMGET(IPLIST,NAMT,ARA) +* RECOVERY OF THE SECOND BLOCK. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG2,IT2BLK) + IF(ILONG2.NE.ILONG1) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH.') + ELSE IF(IT1BLK.NE.IT2BLK) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.') + ENDIF + ALLOCATE(ARA2(ILONG2)) + CALL LCMGET(IPLIST,NAMT,ARA2) +* COMPARE THE TWO BLOCKS. + EPSMAX=0.0 + EPSAVG=0.0 + IF(TEXT4(1:3).EQ.'REL') THEN + WRITE (6,200) 'RELATIVE' + DO I=1,ILONG1 + IF(ARA2(I).NE.0.0) THEN + ABSEP=ABS((ARA(I)-ARA2(I))/ARA2(I)) + ELSE + ABSEP=0.0 + ENDIF + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + ENDDO + EPSMAX=100.0*EPSMAX + EPSAVG=100.0*EPSAVG/REAL(ILONG1) + WRITE (6,210) ILONG1,EPSMAX,INGRO,EPSAVG + ELSE IF(TEXT4(1:3).EQ.'ABS') THEN + WRITE (6,200) 'ABSOLUTE' + DO I=1,ILONG1 + ABSEP=ABS(ARA(I)-ARA2(I)) + IF(EPSMAX.LT.ABSEP) THEN + EPSMAX=ABSEP + INGRO=I + ENDIF + EPSAVG=EPSAVG+ABSEP + ENDDO + EPSAVG=EPSAVG/REAL(ILONG1) + WRITE (6,220) ILONG1,EPSMAX,INGRO,EPSAVG + ELSE + CALL XABORT('DRVUTL: CHOOSE RELATIVE OR ABSOLUTE') + ENDIF + DEALLOCATE(ARA2,ARA) +*---- +* transfer EPSMAX and EPSAVG to output variables if required +*---- + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC .EQ. 3 ) GO TO 20 + IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' + 1 //'maximum error is not a real number') + CALL REDPUT(-INDIC,NITMA,EPSMAX,TEXT4,DFLOTT) + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC .EQ. 3 ) GO TO 20 + IF(INDIC .NE. -2) CALL XABORT('DRVUTL: Output variable for ' + 1 //'average error is not a real number') + CALL REDPUT(-INDIC,NITMA,EPSAVG,TEXT4,DFLOTT) + ELSE IF(TEXT4.EQ.'ADD') THEN +* ADD TWO BLOCKS OR DIRECTORIES STORED ON LCM OR XSM. +* RECOVERY OF THE FIRST BLOCK. + IF(IND.EQ.2) CALL XABORT('DRVUTL: ADD IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL REDGET(INDIC,NITMA,FLOTT,NAMT2,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + CALL LCMLEN(IPLIST,NAMT,ILONG1,IT1BLK) + IF(ILONG1.EQ.-1) THEN +* ADD TWO DIRECTORIES. + NUNIT=KDROPN('DUMMYSQ',0,2,0) + IF(NUNIT.LE.0) CALL XABORT('DRVUTL: KDROPN FAILURE.') + CALL LCMEXP(IPLIST,0,NUNIT,1,1) + REWIND(NUNIT) + CALL LCMOP(IPLIS1,'DUMMYDA',0,1,0) + CALL LCMEXP(IPLIS1,0,NUNIT,1,2) + IRC=KDRCLS(NUNIT,2) + IF(IRC.LT.0) CALL XABORT('DRVUTL: KDRCLS FAILURE.') + CALL LCMSIX(IPLIS1,NAMT,1) + CALL LCMSIX(IPLIST,NAMT2,1) + CALL LCMADD(IPLIS1,IPLIST) + CALL LCMSIX(IPLIS1,' ',2) + CALL LCMSIX(IPLIST,' ',2) + CALL LCMCL(IPLIS1,2) + ELSE IF(ILONG1.GT.0) THEN +* ADD TWO RECORDS. + IF(IT1BLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT' + 1 //' OF REAL TYPE.') + CALL LCMLEN(IPLIST,NAMT2,ILONG2,IT2BLK) + IF(ILONG2.NE.ILONG1) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT LENGTH' + 1 //'S.') + ELSE IF(IT1BLK.NE.IT2BLK) THEN + CALL XABORT('DRVUTL: THE 2 BLOCKS ARE OF DIFFERENT TYPES.') + ENDIF + ALLOCATE(ARA(ILONG1)) + CALL LCMGET(IPLIST,NAMT,ARA) + ALLOCATE(ARA(ILONG2)) + CALL LCMGET(IPLIST,NAMT,ARA2) + ARA2(:ILONG2)=ARA(:ILONG2)+ARA2(:ILONG2) + CALL LCMPUT(IPLIST,NAMT2,ILONG2,IT1BLK,ARA2) + DEALLOCATE(ARA2) + DEALLOCATE(ARA) + ELSE IF(ILONG1.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.') + ENDIF + ELSE IF((TEXT4.EQ.'MULT').OR.(TEXT4.EQ.'SADD')) THEN +* MULTIPLY AN LCM OR XSM BLOCK OR DIRECTORY BY A CONSTANT. +* RECOVERY OF A BLOCK OR DIRECTORY. + IF(IND.EQ.2) CALL XABORT('DRVUTL: MULT IS A FORBIDDEN OPERATIO' + 1 //'N IN READ-ONLY MODE.') + CALL REDGET(NTYPE,ISET,FLOTT,NAMT,DFLOTT) + IF(NTYPE.EQ.1) THEN + CALL LCMLEL(IPLIST,ISET,ILONG1,ITYBLK) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK) + ELSE + CALL XABORT('DRVUTL: INTEGER OR CHARACTER DATA EXPECTED.') + ENDIF +* READ A NUMBER. + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.EQ.3) CALL XABORT('DRVUTL: INTEGER OR REAL NUMBER EX' + 1 //'PECTED.') + IF(INDIC.EQ.1) FLOTT=REAL(NITMA) + CALL LCMLEN(IPLIST,NAMT,ILONG1,ITYBLK) + IF(ILONG1.EQ.-1) THEN +* MULTIPLY A DIRECTORY FLOATTING CONTENT BY A REAL NUMBER. + IF(NTYPE.EQ.1) THEN + IPLIS1=LCMDIL(IPLIST,ISET) + ELSE IF(NTYPE.EQ.3) THEN + IPLIS1=LCMDID(IPLIST,NAMT) + ENDIF + CALL LCMULT(IPLIS1,FLOTT) + ELSE IF(ILONG1.GT.0) THEN +* MULTIPLY A REAL RECORD BY A REAL NUMBER. + IF(ITYBLK.NE.2) CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT' + 1 //' OF REAL TYPE.') + ALLOCATE(ARA(ILONG1)) + IF(NTYPE.EQ.1) THEN + CALL LCMGDL(IPLIST,ISET,ARA) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMGET(IPLIST,NAMT,ARA) + ENDIF + IF(TEXT4.EQ.'MULT') THEN + ARA(:ILONG1)=ARA(:ILONG1)*FLOTT + ELSE IF(TEXT4.EQ.'SADD') THEN + ARA(:ILONG1)=ARA(:ILONG1)+FLOTT + ENDIF + IF(NTYPE.EQ.1) THEN + CALL LCMPDL(IPLIST,ISET,ILONG1,ITYBLK,ARA) + ELSE IF(NTYPE.EQ.3) THEN + CALL LCMPUT(IPLIST,NAMT,ILONG1,ITYBLK,ARA) + ENDIF + DEALLOCATE(ARA) + ELSE IF(ILONG1.EQ.0) THEN + CALL XABORT('DRVUTL: '''//NAMT//''' IS NOT STORED.') + ENDIF + ELSE IF(TEXT4.EQ.'STEP') THEN +* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OR XSM FILE. + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.EQ.'UP') THEN + CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(IMPX.GT.0) WRITE (6,190) NAMT + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.NE.'NEW') THEN + IPLIST=LCMGID(IPLIST,NAMT) + IPKEEP(ILEV)=IPLIST + GO TO 20 + ELSE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN + IPLIST=LCMDID(IPLIST,NAMT) + IPKEEP(ILEV)=IPLIST + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE' + 1 //'D.') + IPLIST=LCMLID(IPLIST,NAMT,NITMA) + IPKEEP(ILEV)=IPLIST + ELSE + CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.') + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'AT') THEN + CALL REDGET(INDIC,ISET,FLOTT,NAMT,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTED.') + IF(IMPX.GT.0) WRITE (6,195) ISET + ILEV=ILEV+1 + IF(ILEV.GT.MAXLEV) CALL XABORT('DRVUTL: MAXLEV OVERFLOW.') + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.3) CALL XABORT('DRVUTL: CHARACTER DATA EXPECTED.') + IF(TEXT4.NE.'NEW') THEN + IPLIST=LCMGIL(IPLIST,ISET) + IPKEEP(ILEV)=IPLIST + GO TO 20 + ELSE + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF((INDIC.EQ.3).AND.(TEXT4.EQ.'DICT')) THEN + IPLIST=LCMDIL(IPLIST,ISET) + IPKEEP(ILEV)=IPLIST + ELSE IF((INDIC.EQ.3).AND.(TEXT4.EQ.'LIST')) THEN + CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT) + IF(INDIC.NE.1) CALL XABORT('DRVUTL: INTEGER DATA EXPECTE' + 1 //'D.') + IPLIST=LCMLIL(IPLIST,ISET,NITMA) + IPKEEP(ILEV)=IPLIST + ELSE + CALL XABORT('DRVUTL: DICT OR LIST KEYWORD EXPECTED.') + ENDIF + ENDIF + ELSE IF(TEXT4.EQ.'DOWN') THEN + IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO PARENT , + 1 6HLEVEL.)') + ILEV=ILEV-1 + IF(ILEV.LT.1) CALL XABORT('DRVUTL: TOO MANY STEPS DOWN.') + IPLIST=IPKEEP(ILEV) + ELSE IF(TEXT4.EQ.'ROOT') THEN + IF(IMPX.GT.0) WRITE (6,'(/29H DRVUTL: STEP DOWN TO ROOT LE, + 1 4HVEL.)') + ILEV=1 + IPLIST=IPKEEP(1) + ENDIF + ELSE IF(TEXT4.EQ.'DIR') THEN +* PRINT THE DIRECTORY OF THE ACTIVE LEVEL. + CALL LCMLIB(IPLIST) + ELSE IF(TEXT4.EQ.'VAL') THEN +* VALIDATE A LCM OBJECT. + CALL LCMVAL(IPLIST,' ') + ELSE IF(TEXT4.EQ.'NAN') THEN +* CHECK FOR NAN IN LCM OBJECT. + CALL LCMNAN(IPLIST) + ELSE IF(TEXT4.EQ.'DUMP') THEN +* DUMP THE ACTIVE AND SON DIRECTORIES ON THE PRINTER. + CALL LCMEXP(IPLIST,0,6,2,1) + ELSE IF(TEXT4.EQ.';') THEN + IF(IMPX.GT.0) THEN + CALL LCMINF(IPLIST,NAMLCM,NAMMY,EMPTY,ILONG,LCM) + WRITE(6,260) NAMMY + ENDIF + RETURN + ELSE + WRITE(HSMG,'(8HDRVUTL: ,A4,30H IS AN INVALID UTILITY ACTION.) + 1 ') TEXT4 + CALL XABORT(HSMG) + ENDIF + GO TO 10 +* + 180 FORMAT (/36H DRVUTL: PERFORM UTILITY ACTIONS ON ,A11,9H OPEN IN , + 1 A9,29H MODE WITH ACTIVE DIRECTORY ',A12,2H'./9X,9HLCM NAME=,A) + 190 FORMAT (/27H DRVUTL: STEP UP TO LEVEL ',A12,2H'.) + 195 FORMAT (/27H DRVUTL: STEP AT COMPONENT ,I5,1H.) + 200 FORMAT (/17H DRVUTL: COMPARE ,A8,26H ERRORS OF THE TWO BLOCKS:/) + 210 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,F8.2,15H % IN COMPONENT,I6/16X, + 1 7HEPSAVG=,F8.2,2H %) + 220 FORMAT (/5H LEN=,I6,5X,7HEPSMAX=,E12.5,13H IN COMPONENT,I6/16X, + 1 7HEPSAVG=,E12.5) + 225 FORMAT (/29H DRVUTL: CONTENT OF COMPONENT,I6,5X,8HLENGTH =,I10, + 1 5X,26HNUMBER OF NON ZERO TERMS =,I10/) + 230 FORMAT (/27H DRVUTL: CONTENT OF BLOCK ',A12,1H',5X,8HLENGTH =, + 1 I10,5X,26HNUMBER OF NON ZERO TERMS =,I10/) + 240 FORMAT (/16H DRVUTL: BLOCK ',A12,21H' IS OF UNKNOWN TYPE./) + 245 FORMAT (/18H DRVUTL: COMPONENT,I6,27H IS NOT STORED ON THE CURRE, + 1 20HNT LCM OR XSM LEVEL./) + 250 FORMAT (/16H DRVUTL: BLOCK ',A12,28H' IS NOT STORED ON THE CURRE, + 1 20HNT LCM OR XSM LEVEL./) + 260 FORMAT (/40H DRVUTL: LEAVING WITH ACTIVE DIRECTORY ',A12,2H'.) + END |