1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
*DECK DRVREC
SUBROUTINE DRVREC(NENTRY,HENTRY,IENTRY,JENTRY,KENTRY)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Recover one or many LCM objects.
*
*Copyright:
* Copyright (C) 1994 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): A. Hebert
*
*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.
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
INTEGER NENTRY,IENTRY(NENTRY),JENTRY(NENTRY)
TYPE(C_PTR) KENTRY(NENTRY)
CHARACTER HENTRY(NENTRY)*12
*----
* LOCAL VARIABLES
*----
TYPE(C_PTR) IPLIST,JPLIST,KPLIST
CHARACTER HMEDIA*12,TEXT12*12,TEXT4*4,NAMT*12
DOUBLE PRECISION DFLOTT
*
IF(NENTRY.LE.1) CALL XABORT('DRVREC: TWO PARAMETERS EXPECTED.')
ITYPE=0
JPLIST=C_NULL_PTR
DO 10 I=1,NENTRY
IF(JENTRY(I).EQ.2) THEN
ITYPE=IENTRY(I)
IPLIST=KENTRY(I)
HMEDIA=HENTRY(I)
IF((IENTRY(I).NE.1).AND.(IENTRY(I).NE.2)) CALL XABORT('DRVREC:'
1 //' RHS LINKED LIST OR XSM FILE EXPECTED.')
GO TO 20
ENDIF
10 CONTINUE
CALL XABORT('DRVREC: UNABLE TO FIND A BACKUP MEDIA OPEN IN READ-O'
1 //'NLY MODE.')
*
20 IMPX=1
IPOS=0
30 CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
IF(INDIC.EQ.10) GO TO 40
IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECTED.')
IF(TEXT4.EQ.'EDIT') THEN
CALL REDGET(INDIC,IMPX,FLOTT,TEXT4,DFLOTT)
IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER DATA EXPECTED.')
ELSE IF(TEXT4.EQ.'ITEM') THEN
CALL REDGET(INDIC,IPOS,FLOTT,TEXT4,DFLOTT)
IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER DATA EXPECTED.')
ELSE IF(TEXT4.EQ.'STEP') THEN
* CHANGE THE HIERARCHICAL LEVEL ON THE LCM OBJECT.
IF(ITYPE.GT.2) CALL XABORT('DRVREC: UNABLE TO STEP INTO A SE'
1 //'QUENTIAL FILE.')
CALL REDGET(INDIC,NITMA,FLOTT,TEXT4,DFLOTT)
IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECTED.')
IF(TEXT4.EQ.'UP') THEN
CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
IF(INDIC.NE.3) CALL XABORT('DRVREC: CHARACTER DATA EXPECT'
1 //'ED.')
IF(IMPX.GT.0) WRITE (6,100) NAMT
JPLIST=LCMGID(IPLIST,NAMT)
ELSE IF(TEXT4.EQ.'AT') THEN
CALL REDGET(INDIC,NITMA,FLOTT,NAMT,DFLOTT)
IF(INDIC.NE.1) CALL XABORT('DRVREC: INTEGER EXPECTED.')
IF(IMPX.GT.0) WRITE (6,110) NITMA
JPLIST=LCMGIL(IPLIST,NITMA)
ELSE
CALL XABORT('DRVREC: UP OR AT EXPECTED.')
ENDIF
IPLIST=JPLIST
ELSE IF(TEXT4.EQ.';') THEN
GO TO 40
ELSE
CALL XABORT('DRVREC: '//TEXT4//' IS AN INVALID KEY WORD.')
ENDIF
GO TO 30
*
40 CALL LCMGTC(IPLIST,'SIGNATURE',12,TEXT12)
IF(TEXT12.NE.'L_ARCHIVE') THEN
CALL XABORT('DRVREC: SIGNATURE OF '//HMEDIA//' IS '//TEXT12//
1 '. L_ARCHIVE EXPECTED.')
ENDIF
DO 50 I=1,NENTRY-1
IF((JENTRY(I).EQ.0).OR.(JENTRY(I).EQ.1)) THEN
IF(IENTRY(I).GT.2) CALL XABORT('DRVREC: LHS LINKED LIST OR XSM'
1 //' FILE EXPECTED.')
IF(IMPX.GT.0) THEN
IF(IPOS.EQ.0) THEN
WRITE (6,'(/18H DRVREC: RECOVER '',A,8H'' FROM '',A,
1 2H''.)') TRIM(HENTRY(I)),TRIM(HMEDIA)
ELSE
WRITE (6,'(/22H DRVREC: RECOVER ITEM=,I5,5H OF '',A,
1 8H'' FROM '',A,2H''.)') IPOS,TRIM(HENTRY(I)),TRIM(HMEDIA)
ENDIF
ENDIF
TEXT12=HENTRY(I)
CALL LCMLEN(IPLIST,TEXT12,ILEN,ITYLCM)
IF(ILEN.EQ.0) THEN
CALL LCMLIB(IPLIST)
CALL XABORT('DRVREC: UNABLE TO FIND '//TEXT12//' ON THE BA'
1 //'CKUP MEDIA NAMED '//HMEDIA//'.')
ELSE IF(ITYLCM.EQ.0) THEN
IF(IPOS.NE.0) CALL XABORT('DRVREC: RECORD '//TEXT12//' ON '
1 //'THE BACKUP MEDIA NAMED '//HMEDIA//' IS NOT A DIRECTORY.')
CALL LCMSIX(IPLIST,HENTRY(I),1)
CALL LCMEQU(IPLIST,KENTRY(I))
CALL LCMSIX(IPLIST,' ',2)
ELSE IF(ITYLCM.EQ.10) THEN
IF(IPOS.EQ.0) CALL XABORT('DRVREC: RECORD '//TEXT12//' ON '
1 //'THE BACKUP MEDIA NAMED '//HMEDIA//' IS NOT A LIST.')
JPLIST=LCMGID(IPLIST,HENTRY(I))
KPLIST=LCMGIL(JPLIST,IPOS)
CALL LCMEQU(KPLIST,KENTRY(I))
ELSE
CALL LCMLIB(IPLIST)
CALL XABORT('DRVREC: RECORD '//TEXT12//' ON THE BACKUP MED'
1 //'IA NAMED '//HMEDIA//' CANNOT BE COPIED.')
ENDIF
ENDIF
50 CONTINUE
RETURN
*
100 FORMAT (/27H DRVREC: STEP UP TO LEVEL ',A12,2H'.)
110 FORMAT (/26H DRVREC: STEP AT COMPONENT,I6,1H.)
END
|
