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
150
151
152
153
154
155
|
*DECK DEVDGD
SUBROUTINE DEVDGD(IPDEV,NROD,DGRP,IMPX)
*
*-----------------------------------------------------------------------
*
*Purpose:
* Create rod-device group directories on the device data structure.
*
*Copyright:
* Copyright (C) 2007 Ecole Polytechnique de Montreal.
*
*Author(s):
* D. Sekki
*
*Parameters: input
* IPDEV pointer to device information.
* NROD total number of rod-devices.
* DGRP total number of rod-device groups.
* IMPX printing index (=0 for no print).
*
*-----------------------------------------------------------------------
*
USE GANLIB
*----
* SUBROUTINE ARGUMENTS
*----
TYPE(C_PTR) IPDEV
INTEGER NROD,DGRP,IMPX
*----
* LOCAL VARIABLES
*----
PARAMETER(IOUT=6)
CHARACTER TEXT*12
INTEGER RODID(NROD)
DOUBLE PRECISION DFLOT
TYPE(C_PTR) JPDEV,KPDEV
*----
* CREATE GROUPS
*----
JPDEV=LCMLID(IPDEV,'ROD_GROUP',DGRP)
IGRP=0
IF(IMPX.GT.0)WRITE(IOUT,1001)
CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
IF(ITYP.NE.3)CALL XABORT('@DEVDGD: KEYWORD GROUP-ID EXPECTED.')
IF(TEXT.NE.'GROUP-ID')CALL XABORT('@DEVDGD: KEYWORD GROUP-'
1 //'ID EXPECTED.')
10 IGRP=IGRP+1
CALL REDGET(ITYP,JGRP,FLOT,TEXT,DFLOT)
IF(ITYP.NE.1)CALL XABORT('@DEVDGD: INTEGER GROUP-ID NUMBER'
1 //' EXPECTED.')
IF(JGRP.NE.IGRP)THEN
WRITE(IOUT,*)'@DEVDGD: READ GROUP-ID NUMBER #',JGRP
WRITE(IOUT,*)'@DEVDGD: EXPECTED GROUP-ID NUMBER #',IGRP
CALL XABORT('@DEVDGD: WRONG GROUP-ID NUMBER.')
ENDIF
IF(JGRP.GT.DGRP)THEN
WRITE(IOUT,*)'@DEVDGD: GIVEN TOTAL NUMBER OF GROUPS ',DGRP
WRITE(IOUT,*)'@DEVDGD: READ GROUP-ID NUMBER #',JGRP
CALL XABORT('@DEVDGD: WRONG GROUP-ID NUMBER.')
ENDIF
CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
IF(ITYP.NE.3)CALL XABORT('@DEVDGD: KEYWORD EXPECTED.')
*----
* OPTION ALL
*----
IF(TEXT.EQ.'ALL')THEN
KPDEV=LCMDIL(JPDEV,IGRP)
DO 30 ID=1,NROD
RODID(ID)=ID
30 CONTINUE
CALL LCMPUT(KPDEV,'GROUP-ID',1,1,IGRP)
CALL LCMPUT(KPDEV,'NUM-ROD',1,1,NROD)
CALL LCMPUT(KPDEV,'ROD-ID',NROD,1,RODID)
*
CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
IF(ITYP.NE.3)CALL XABORT('@DEVDGD: WRONG INPUT DATA.')
IF(TEXT.EQ.';')THEN
IF(IGRP.EQ.DGRP)THEN
NDG=NROD
GOTO 100
ENDIF
WRITE(IOUT,*)'@DEVDGD: GIVEN TOTAL NUMBER OF GROUPS ',DGRP
WRITE(IOUT,*)'@DEVDGD: CREATED ONLY NUMBER OF GROUPS ',IGRP
CALL XABORT('@DEVDGD: WRONG NUMBER OF GROUPS.')
ELSEIF(TEXT.EQ.'GROUP-ID')THEN
IF(IMPX.GT.0)WRITE(IOUT,1000)IGRP,NROD
GOTO 10
ELSE
CALL XABORT('@DEVDGD: WRONG KEYWORD '//TEXT)
ENDIF
*----
* OPTION ROD-ID
*----
ELSEIF(TEXT.EQ.'ROD-ID')THEN
NDG=0
RODID(:NROD)=0
KPDEV=LCMDIL(JPDEV,IGRP)
*
50 CALL REDGET(ITYP,NITMA,FLOT,TEXT,DFLOT)
IF(ITYP.EQ.3)THEN
IF(TEXT.EQ.';')THEN
IF(IGRP.EQ.DGRP)GOTO 100
WRITE(IOUT,*)'@DEVDGD: GIVEN TOTAL NUMBER OF GROUPS ',DGRP
WRITE(IOUT,*)'@DEVDGD: CREATED ONLY NUMBER OF GROUPS ',IGRP
CALL XABORT('@DEVDGD: WRONG NUMBER OF GROUPS.')
ELSEIF(TEXT.EQ.'GROUP-ID')THEN
IF(IMPX.GT.0)WRITE(IOUT,1000)IGRP,NDG
GOTO 10
ELSE
CALL XABORT('@DEVDGD: WRONG KEYWORD '//TEXT)
ENDIF
*----
* ROD-ID NUMBERS
*----
ELSEIF(ITYP.EQ.1)THEN
ID=NITMA
IF((ID.GT.NROD).OR.(ID.LE.0))THEN
WRITE(IOUT,*)'@DEVDGD: FOR THE GROUP #',IGRP
WRITE(IOUT,*)'@DEVDGD: READ ROD-ID #',ID
CALL XABORT('@DEVDGD: WRONG ROD-ID NUMBER.')
ENDIF
DO I=1,NROD
IF(ID.EQ.RODID(I))THEN
WRITE(IOUT,*)'@DEVDGD: FOR THE GROUP #',IGRP
WRITE(IOUT,*)'@DEVDGD: REPEATED ROD-ID #',ID
CALL XABORT('@DEVDGD: WRONG ROD-ID NUMBER.')
ENDIF
ENDDO
*
NDG=NDG+1
IF(NDG.GT.NROD)THEN
WRITE(IOUT,*)'@DEVDGD: FOR THE GROUP #',IGRP
WRITE(IOUT,*)'@DEVDGD: WRONG TOTAL NUMBER OF RODS ',NDG
CALL XABORT('@DEVDGD: INVALID INPUT OF ROD-DEVICES.')
ENDIF
RODID(NDG)=ID
CALL LCMPUT(KPDEV,'GROUP-ID',1,1,IGRP)
CALL LCMPUT(KPDEV,'NUM-ROD',1,1,NDG)
CALL LCMPUT(KPDEV,'ROD-ID',NDG,1,RODID)
ELSE
CALL XABORT('@DEVDGD: WRONG INPUT DATA.')
ENDIF
GOTO 50
ELSE
CALL XABORT('@DEVDGD: WRONG KEYWORD '//TEXT)
ENDIF
100 IF(IMPX.GT.0)WRITE(IOUT,1000)IGRP,NDG
IF(IMPX.GT.0)WRITE(IOUT,1002)DGRP
RETURN
*
1000 FORMAT(/1X,' => CREATED A GROUP #',I2.2,
1 4X,'INCLUDES TOTAL NUMBER OF RODS:',I3)
1001 FORMAT(/1X,'** CREATING GROUPS FOR ROD-DEVICES **')
1002 FORMAT(/1X,39('-')/1X,'TOTAL NUMBER OF GROUPS CREATED: ',I2)
END
|
