*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