1 : C REPICO SOURCE MAGN 09/07/30 21:20:49 6458
2 : SUBROUTINE REPICO(IMATB,IMATC,CHPOD,
3 : $ ICOGLO,ICPRIB,ICDUAB,ICPRIC,ICDUAC,ICPRID,
4 : $ IMPR,IRET)
5 : IMPLICIT INTEGER(I-N)
6 : IMPLICIT REAL*8 (A-H,O-Z)
7 : C***********************************************************************
8 : C NOM : REPICO
9 : C DESCRIPTION : Repérage global des inconnues : ICOGLO (LISTMOTS)
10 : C Noms des inconnues primales et duales de B et C exprimées
11 : C dans ce repérage : IC{PRI,DUA}{B,C}
12 : C (Eventuellement, si CHPOD.NE.0) :
13 : C Noms des inconnues de CHPOD dans ce repérage
14 : C
15 : C LANGAGE : ESOPE
16 : C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
17 : C mél : gounand@semt2.smts.cea.fr
18 : C***********************************************************************
19 : C APPELES : CUNIQ, CREPER
20 : C APPELES (E/S) : ECRCHA, ECROBJ
21 : C APPELE PAR : PROMAT
22 : C***********************************************************************
23 : C ENTREES : IMATB, IMATC, CHPOD
24 : C SORTIES : ICOGLO, ICPRIB, ICDUAB, ICPRIC, ICDUAC, ICPRID
25 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
26 : C***********************************************************************
27 : C VERSION : v1, 28/01/2000, version initiale
28 : C HISTORIQUE : v1, 28/01/2000, création
29 : C HISTORIQUE :
30 : C HISTORIQUE :
31 : C***********************************************************************
32 : C Prière de PRENDRE LE TEMPS de compléter les commentaires
33 : C en cas de modification de ce sous-programme afin de faciliter
34 : C la maintenance !
35 : C***********************************************************************
36 : -INC CCOPTIO
37 : -INC SMLMOTS
38 : INTEGER JGN,JGM
39 : POINTEUR ICOGLO.MLMOTS
40 : POINTEUR GPINCS.MLMOTS
41 : POINTEUR MLPRID.MLMOTS
42 : -INC SMLENTI
43 : INTEGER JG
44 : POINTEUR ICPRIB.MLENTI
45 : POINTEUR ICDUAB.MLENTI
46 : POINTEUR ICPRIC.MLENTI
47 : POINTEUR ICDUAC.MLENTI
48 : POINTEUR ICPRID.MLENTI
49 : -INC SMCHPOI
50 : POINTEUR CHPOD.MCHPOI
51 : -INC SMMATRIK
52 : POINTEUR IMATB.IMATRI
53 : POINTEUR IMATC.IMATRI
54 : *
55 : INTEGER IMPR,IRET
56 : *
57 : INTEGER LNMOTS
58 : PARAMETER (LNMOTS=8)
59 : *
60 : INTEGER NBMB,NBMC,NBMD,NIPRID,NIUNIQ
61 : INTEGER IBMB,IBMC,IBMD,IIPRID,IINC
62 : *
63 : *
64 : * Executable statements
65 : *
66 : IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans repico.eso'
67 : * Enumération de tous les noms d'inconnues
68 : * Extraction éventuelles des composantes du chpoint
69 : * avec modif. pour qu'ils fassent 8 lettres
70 : IF (CHPOD.NE.0) THEN
70 : CALL ECRCHA('COMP')
70 : CALL ECROBJ('CHPOINT ',CHPOD)
70 : CALL EXTRAI
70 : CALL LIROBJ('LISTMOTS',MLPRID,1,IRET)
71 : IF (IRET.EQ.0) THEN
72 : WRITE(IOIMP,*) 'erreur extraction des composantes chpod'
73 : GOTO 9999
74 : ENDIF
75 : SEGACT MLPRID*MOD
76 : NIPRID=MLPRID.MOTS(/2)
77 : JGN=LNMOTS
78 : JGM=NIPRID
79 : SEGADJ,MLPRID
80 : DO 1 IIPRID=1,NIPRID
81 : MLPRID.MOTS(IIPRID)=
82 : $ MLPRID.MOTS(IIPRID)(1:4)//' '
83 : 1 CONTINUE
84 : ELSE
85 : MLPRID=0
86 : ENDIF
87 : SEGACT IMATB
88 : SEGACT IMATC
89 : NBMB=IMATB.LISPRI(/2)
90 : NBMC=IMATC.LISPRI(/2)
91 : JGN=LNMOTS
92 : JGM=2*(NBMB+NBMC)
93 : IF (MLPRID.NE.0) THEN
94 : NBMD=MLPRID.MOTS(/2)
95 : JGM=JGM+NBMD
96 : ENDIF
97 : *
98 : SEGINI GPINCS
99 : IINC=0
100 : DO 2 IBMB=1,NBMB
101 : IINC=IINC+1
102 : GPINCS.MOTS(IINC)=IMATB.LISPRI(IBMB)
103 : 2 CONTINUE
104 : DO 3 IBMC=1,NBMC
105 : IINC=IINC+1
106 : GPINCS.MOTS(IINC)=IMATC.LISPRI(IBMC)
107 : 3 CONTINUE
108 : DO 4 IBMB=1,NBMB
109 : IINC=IINC+1
110 : GPINCS.MOTS(IINC)=IMATB.LISDUA(IBMB)
111 : 4 CONTINUE
112 : DO 5 IBMC=1,NBMC
113 : IINC=IINC+1
114 : GPINCS.MOTS(IINC)=IMATC.LISDUA(IBMC)
115 : 5 CONTINUE
116 : IF (MLPRID.NE.0) THEN
117 : DO 6 IBMD=1,NBMD
118 : IINC=IINC+1
119 : GPINCS.MOTS(IINC)=MLPRID.MOTS(IBMD)
120 : 6 CONTINUE
121 : ENDIF
122 : * Elimination des doublons dans les noms
123 : JGN=LNMOTS
124 : JGM=IINC
125 : SEGINI ICOGLO
125 : CALL CUNIQ(GPINCS.MOTS,LNMOTS,IINC,
126 : $ ICOGLO.MOTS,NIUNIQ,
127 : $ IMPR,IRET)
128 : IF (IRET.NE.0) GOTO 9999
129 : JGN=LNMOTS
130 : JGM=NIUNIQ
131 : SEGADJ,ICOGLO
132 : SEGSUP GPINCS
133 : * Noms des inconnues primales et duales de B et C exprimées
134 : * dans le repérage défini par ICOGLO : IC{PRI,DUA}{B,C}
135 : JG=NBMB
136 : SEGINI ICPRIB
136 : CALL CREPER(LNMOTS,NBMB,NIUNIQ,
137 : $ IMATB.LISPRI,ICOGLO.MOTS,
138 : $ ICPRIB.LECT,
139 : $ IMPR,IRET)
140 : IF (IRET.NE.0) GOTO 9999
141 : SEGDES ICPRIB
142 : JG=NBMB
143 : SEGINI ICDUAB
143 : CALL CREPER(LNMOTS,NBMB,NIUNIQ,
144 : $ IMATB.LISDUA,ICOGLO.MOTS,
145 : $ ICDUAB.LECT,
146 : $ IMPR,IRET)
147 : IF (IRET.NE.0) GOTO 9999
148 : SEGDES ICDUAB
149 : JG=NBMC
150 : SEGINI ICPRIC
150 : CALL CREPER(LNMOTS,NBMC,NIUNIQ,
151 : $ IMATC.LISPRI,ICOGLO.MOTS,
152 : $ ICPRIC.LECT,
153 : $ IMPR,IRET)
154 : IF (IRET.NE.0) GOTO 9999
155 : SEGDES ICPRIC
156 : JG=NBMC
157 : SEGINI ICDUAC
157 : CALL CREPER(LNMOTS,NBMC,NIUNIQ,
158 : $ IMATC.LISDUA,ICOGLO.MOTS,
159 : $ ICDUAC.LECT,
160 : $ IMPR,IRET)
161 : IF (IRET.NE.0) GOTO 9999
162 : SEGDES ICDUAC
163 : IF (MLPRID.NE.0) THEN
164 : JG=NBMD
165 : SEGINI ICPRID
165 : CALL CREPER(LNMOTS,NBMD,NIUNIQ,
166 : $ MLPRID.MOTS,ICOGLO.MOTS,
167 : $ ICPRID.LECT,
168 : $ IMPR,IRET)
169 : IF (IRET.NE.0) GOTO 9999
170 : SEGDES ICPRID
171 : SEGSUP MLPRID
172 : ELSE
173 : ICPRID=0
174 : ENDIF
175 : SEGDES ICOGLO
176 : SEGDES IMATC
177 : SEGDES IMATB
178 : *
179 : * Normal termination
180 : *
181 : IRET=0
182 : RETURN
183 : *
184 : * Format handling
185 : *
186 : *
187 : * Error handling
188 : *
189 : 9999 CONTINUE
190 : IRET=1
191 : WRITE(IOIMP,*) 'An error was detected in subroutine repico'
192 : RETURN
193 : *
194 : * End of subroutine REPICO
195 : *
196 : END
197 :
198 :
199 :
200 :
201 :
© Cast3M 2003 - All rights reserved.
Disclaimer