1 : C KOMCHA SOURCE FANDEUR 11/07/19 21:16:13 7039 2 : SUBROUTINE KOMCHA(IPTR,IPMAIL,CONM,IPNOMC,MOTYPE,ICOND,INFOS, 3 : & NINFO,IPTVAL) 4 : * 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8(A-H,O-Z) 7 : *--------------------------------------------------------------------* 8 : * * 9 : * Recherche des valeurs des composantes dans les MELVAL d'un * 10 : * CHAMELEM. On distingue les composantes obligatoires des * 11 : * composantes facultatives. * 12 : * * 13 : *--------------------------------------------------------------------* 14 : * * 15 : * Entrées: * 16 : * * 17 : * IPTR pointeur sur le MCHAML * 18 : * IPMAIL sous zone élémentaire de l'objet MAILLAGE * 19 : * pointée par le MODELE * 20 : * CONM nom du constituant de la sous-zone * 21 : * IPNOMC pointeur sur les listes de composantes * 22 : * obligatoires et facultatives (ACTIF E/S) * 23 : * MOTYPE pointeur sur un segment definissant les types des * 24 : * composantes cherchees (ACTIF E/S) * 25 : * Si le segment est vide, on ne fait pas la * 26 : * verification sur les types * 27 : * ICOND lecture impérative ou non des composantes * 28 : * obligatoires ( 1 si oui, 0 sinon ) * 29 : * AM 8/12/93 ( on ajoute le cas icond = 2 qui est une lecture * 30 : * imperative mais sans test sur le nom de la * 31 : * composante si le MCHAML n'a qu'une composante * 32 : * et que l'on ne cherche qu'une composante) * 33 : * ( utilisé dans MATER et MANU ) * 34 : * INFOS les INFOS à comparer à INFCHE * 35 : * NINFO leur nombre * 36 : * * 37 : * SORTIES: * 38 : * * 39 : * IPTVAL pointeur pointant sur le tableau de pointeur * 40 : * associé a tous les MELVAL correspondant à la * 41 : * sous zone (ACTIF S) * 42 : * = 0 en cas d'ERREUR (et IERR est aussi non nul) * 43 : * * 44 : *--------------------------------------------------------------------* 45 : * * 46 : * Remarques * 47 : * * 48 : * on commence par ne tester l'identité des géométries que sur les * 49 : * pointeurs. Sans succès, on teste ensuite sur le contenu des * 50 : * maillages. Ainsi, dans le cas où des pointeurs conviennent, * 51 : * on s'arrête sans regarder si d'autres maillages conviendraient * 52 : * aussi, sans pour autant avoir le bon pointeur. * 53 : * * 54 : * on ne teste le constituant que s'il y a plusieurs sous-chamelem * 55 : * éligibles * 56 : * * 57 : *--------------------------------------------------------------------* 58 : * * 59 : * PM : 08/08/2006 * 60 : * si lecture facultative seulement et aucune composante lue * 61 : * alors renvoie un segment vide (NSR=0,NCOSOR=0) * 62 : * * 63 : *--------------------------------------------------------------------* 64 : -INC CCOPTIO 65 : * 66 : -INC SMCHAML 67 : * 68 : SEGMENT NOMID 69 : CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC) 70 : ENDSEGMENT 71 : * 72 : SEGMENT NOTYPE 73 : CHARACTER*16 TYPE(NBTYPE) 74 : ENDSEGMENT 75 : * 76 : SEGMENT MPTVAL 77 : INTEGER IPOS(NSR) ,NSOF(NSR) 78 : INTEGER IVAL(NCOSOR) 79 : CHARACTER*16 TYVAL(NCOSOR) 80 : ENDSEGMENT 81 : * 82 : LOGICAL LOG 83 : * 84 : CHARACTER*4 NOHA 85 : CHARACTER*(NCONCH) CONM 86 : INTEGER INFOS(*) 87 : * 88 : IF (IIMPI.GT.0) write (IOIMP,*) 'komcha' 89 : * 90 : NOMID=IPNOMC 91 : SEGACT NOMID 92 : NBROBL=LESOBL(/2) 93 : NBRFAC=LESFAC(/2) 94 : * 95 : NOTYPE=MOTYPE 96 : SEGACT NOTYPE 97 : NBTYPE=TYPE(/2) 98 : * 99 : NSR = 10 100 : NCOSOR = NSR * ( NBROBL + NBRFAC ) 101 : SEGINI MPTVAL 102 : 103 : IPTVAL=MPTVAL 104 : * 105 : MCHELM=IPTR 106 : SEGACT,MCHELM 107 : N1 = IMACHE(/1) 108 : N3 = INFCHE(/2) 109 : NN3 = MIN(N3,NINFO) 110 : * 111 : * Recherche du ICHAML correspondant à la zone élémentaire 112 : * pointée par le modèle 113 : * 114 : * Nombre de sous-zones du chamelem éligibles 115 : INS=0 116 : LOG = .FALSE. 117 : DO I=1,N1 118 : IF (IPMAIL.EQ.IMACHE(I)) INS=INS+1 119 : IF (CONCHE(I).NE.' ') LOG = .TRUE. 120 : ENDDO 121 : * 122 : * AM 16/03/07 123 : * EN CAS DE CONSTITUANTS TOUS ' ', ON APELLE 124 : * TESTMA AVEC LOG = .FALSE. AU LIEU DE .TRUE. 125 : * 126 : NS = 0 127 : * 128 : DO 1 I=1,N1 129 : * ON IDENTIFIE LE ICHAML 130 : * 131 : * on ne teste l'identité des géométries que sur les pointeurs 132 : * on ne teste le constituant que s'il y a plusieurs sous-chamelem éligibles 133 : * write (6,*) ' komcha i conm conche',i,conm,conche(i) 134 : IF ( IPMAIL.NE.IMACHE(I) .OR. 135 : & (INS.NE.1.AND.CONM.NE.CONCHE(I)) ) GO TO 1 136 : * 137 : * ON VERIFIE LA COMPATIBILITE DES INFOS 138 : * 139 : IF (NN3.EQ.0) THEN 140 : NS=NS+1 141 : * write (6,*) ' komcha-1 ns i ',ns,i 142 : ELSE 143 : DO J=1,NN3 144 : * test numéro d'harmonique 145 : WRITE(NOHA,FMT='(A4)') INFCHE(I,J) 146 : IF (INFOS(J).NE.INFCHE(I,J).AND.(NOHA.NE.'NOHA')) GOTO 1 147 : ENDDO 148 : NS=NS+1 149 : * write (6,*) ' komcha-2 ns i j ',ns,i,j 150 : ENDIF 151 : IF (NS.GT.NSR) THEN 152 : NSR = NS+100 153 : SEGADJ MPTVAL 154 : ENDIF 155 : IPOS(NS) = I 156 : 1 CONTINUE 157 : * 158 : IF (NS.EQ.0) THEN 159 : * Aucun pointeur ne correspond 160 : * On teste alors les maillages eux-mêmes et leurs points 160 : CALL TESTMA(IPTR,IPMAIL,LOG,CONM,IPTRET,IMODI) 161 : 162 : MCHELM=IPTR 163 : SEGDES,MCHELM 164 : 165 : IF (IERR.NE.0) GOTO 9999 166 : IF (IPTRET.EQ.0) THEN 167 : * On n'a pas trouvé, dans un CHAMELEM, de zone géométrique ou 168 : * de constituant correspondant à l'objet MODELE 168 : CALL ERREUR(472) 169 : GOTO 9999 170 : ENDIF 171 : 172 : * on a trouvé un sous-maillage 173 : MCHELM=IPTRET 174 : SEGACT,MCHELM 175 : N1 = IMACHE(/1) 176 : N3 = INFCHE(/2) 177 : NN3 = MIN(N3,NINFO) 178 : * 179 : * ON VERIFIE A NOUVEAU LA COMPATIBILITE DES INFOS 180 : * 181 : DO 11 I=1,N1 182 : IF (NN3.EQ.0) THEN 183 : NS=NS+1 184 : * write (6,*) ' komcha-3 ns i ',ns,i 185 : ELSE 186 : DO J=1,NN3 187 : * test numéro d'harmonique 188 : WRITE(NOHA,FMT='(A4)') INFCHE(I,J) 189 : IF (INFOS(J).NE.INFCHE(I,J).AND.(NOHA.NE.'NOHA')) GOTO 11 190 : ENDDO 191 : NS=NS+1 192 : * write (6,*) ' komcha-4 ns i j ',ns,i,j 193 : ENDIF 194 : IF (NS.GT.NSR) THEN 195 : NSR = NS+100 196 : SEGADJ MPTVAL 197 : ENDIF 198 : IPOS(NS) = I 199 : 11 CONTINUE 200 : ENDIF 201 : * 202 : * TEST SUR LA NULLITE DE NS AM 203 : IF (NS.EQ.0) THEN 204 : * la sous zone de maillage %i1 et de constituant %m1:16 a des 205 : * informations relatives au champ ( infche) erronnées 206 : MOTERR = CONM 207 : INTERR(1) = IPMAIL 207 : CALL ERREUR(877) 208 : GOTO 9999 209 : ENDIF 210 : 211 : *-- Identification sur les autres critères 212 : * 213 : NSR = NS 214 : NCOSOR = NS * ( NBROBL + NBRFAC ) 215 : SEGADJ,MPTVAL 216 : * 217 : LECAPA=0 218 : IF (ICOND.EQ.2 .AND. NS.EQ.1 .AND. NBROBL.EQ.1 .AND. NBRFAC.EQ.0) 219 : & LECAPA=1 220 : * 221 : DO JJ=1,NS 222 : ITAB=1 223 : * 224 : * Activation du ICHAML 225 : * 226 : MCHAML=ICHAML(IPOS(JJ)) 227 : SEGACT,MCHAML 228 : IF(NOMCHE(/2).NE.1) LECAPA=0 229 : * 230 : * Composantes obligatoires 231 : NSOF(JJ)=0 232 : DO IC1=1,nbrobl 232 : CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESOBL(IC1-ITAB+1)) 233 : IF (IPLAC.EQ.0.AND.LECAPA.EQ.1) IPLAC=1 234 : IF (IPLAC.NE.0) THEN 235 : * une seule zone autorisee PV 236 : if (ival(ic1).ne.0) then 237 : interr(1)=ipmail 238 : moterr=conm 238 : call erreur(769) 239 : GOTO 9999 240 : endif 241 : NSOF(JJ)=NSOF(JJ)+1 242 : IVAL(IC1)=IELVAL(IPLAC) 243 : MELVAL=IELVAL(IPLAC) 244 : SEGACT,MELVAL 245 : * Vérification du type si donné 246 : IF (NBTYPE.EQ.0) GO TO 7 247 : ICMN=MIN(IC1,NBTYPE) 248 : IF (TYPE(ICMN).NE.TYPCHE(IPLAC) 249 : $ .AND.TYPE(ICMN).NE.' ') THEN 250 : MOTERR(1:16) = TYPCHE(IPLAC) 251 : MOTERR(17:24) = LESOBL(IC1-ITAB+1) 252 : MOTERR(25:40) = TITCHE 252 : CALL ERREUR(552) 253 : SEGDES,MCHAML 254 : SEGDES,MCHELM 255 : GOTO 9999 256 : ENDIF 257 : 7 TYVAL(IC1)=TYPCHE(IPLAC) 258 : * SEGDES,MELVAL 259 : ENDIF 260 : ENDDO 261 : * 262 : * Composantes facultatives 263 : NBOFAC=0 264 : ITAB=ITAB+NBROBL 265 : DO IC2=ITAB,NBRFAC+ITAB-1 266 : IVAL(IC2)=0 266 : CALL PLACE(NOMCHE,NOMCHE(/2),IPLAC,LESFAC(IC2-ITAB+1)) 267 : IF (IPLAC.NE.0) THEN 268 : if (ival(ic2).ne.0) then 269 : interr(1)=ipmail 270 : moterr=conm 270 : call erreur(769) 271 : GOTO 9999 272 : ENDIF 273 : NSOF(JJ)=NSOF(JJ)+1 274 : IVAL(IC2)=IELVAL(IPLAC) 275 : MELVAL=IELVAL(IPLAC) 276 : SEGACT,MELVAL 277 : * Vérification du type si donné 278 : IF(NBTYPE.EQ.0) GO TO 8 279 : ICMN=MIN(IC2,NBTYPE) 280 : IF (TYPE(ICMN).NE.TYPCHE(IPLAC) 281 : $ .AND.TYPE(ICMN).NE.' ') THEN 282 : MOTERR(1:16)=TYPCHE(IPLAC) 283 : MOTERR(17:24)=LESFAC(IC2-ITAB+1) 284 : MOTERR(25:40)=TITCHE 284 : CALL ERREUR(552) 285 : SEGDES,MCHAML 286 : SEGDES,MCHELM 287 : GOTO 9999 288 : ENDIF 289 : 8 TYVAL(IC2)=TYPCHE(IPLAC) 290 : NBOFAC=NBOFAC+1 291 : ** SEGDES,MELVAL 292 : ENDIF 293 : ENDDO 294 : 295 : *PM si lecture facultative seulement et aucune composante lue 296 : *PM alors renvoie un segment vide (NS=0,NCOSOU=0) 297 : IF (NBROBL.EQ.0 .AND. NBRFAC.GT.0) THEN 298 : IF (NS.EQ.0 .AND. NBOFAC.EQ.0) THEN 299 : NSR = 0 300 : NCOSOR = 0 301 : SEGADJ, MPTVAL 302 : ENDIF 303 : ENDIF 304 : 305 : *PM ITAB n'est plus utilisé par la suite. 306 : *PM ITAB=ITAB+NBRFAC 307 : * 308 : ** SEGDES,MCHAML 309 : ENDDO 310 : * verification que les composantes obligatoires sont toutes presentes 311 : DO IC1=1,NBROBL 312 : if (ival(ic1).eq.0) then 313 : IF (ICOND.EQ.1.OR.ICOND.EQ.2) THEN 314 : MOTERR(1:8)=LESOBL(IC1) 315 : MOTERR(9:16)=TITCHE 315 : CALL ERREUR(77) 316 : ELSE 317 : * Données incompatibles 317 : CALL ERREUR(21) 318 : ENDIF 319 : GOTO 9999 320 : ENDIF 321 : ENDDO 322 : * 323 : 9999 CONTINUE 324 : ** SEGDES,MCHELM 325 : ** SEGDES,NOMID,NOTYPE 326 : IF (IERR.NE.0) THEN 326 : CALL DTMVAL(IPTVAL,1) 327 : IPTVAL = 0 328 : ENDIF 329 : * 330 : RETURN 331 : END 332 : 333 :
© Cast3M 2003 - All rights reserved.
Disclaimer