1 : C KCHT SOURCE CHAT 06/08/24 21:45:57 5529 2 : SUBROUTINE KCHT 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************* 6 : C Operateur KCHT 7 : C 8 : C OBJET : Cree un CHAMPOINT TRIO c'est a dire sous-type 9 : C SOMMET CENTRE ou FACE 10 : C 11 : C SYNTAXE : CH1 = KCHT tabdom TYPC TYPG12 : C ; 13 : C 14 : C tabdom table domaine 15 : C 16 : C TYPC : SCAL TYPG : SOMMET 17 : C VECT CENTRE 18 : C FACE 19 : C nc nom donne a ou aux composantes 20 : C 21 : C 22 : C 23 : C 24 : C 25 : C************************************************************************* 26 : -INC CCOPTIO 27 : -INC SMCOORD 28 : -INC SMCHPOI 29 : -INC SMELEME 30 : -INC SMLENTI 31 : -INC SMLMOTS 32 : 33 : CHARACTER*8 TYPC,TYPG,LTYPC(3),LTYPG(8),MTYP,TYPE,TYPS 34 : CHARACTER*4 NCOS,NCOV(3),NCOSI,NCOVI(3) 35 : 36 : REAL*8 XVAL(3) 37 : 38 : DATA LTYPC/'SCAL ','VECT ','MATR '/ 39 : DATA LTYPG/'SOMMET ','CENTRE ','FACE ','CENTREP0','CENTREP1', 40 : &'MSOMMET ','COMP ','VERIF '/ 41 : DATA NCOSI/'SCAL'/,NCOVI/'UX ','UY ','UZ '/ 42 : C*** 43 : 44 : KVERIF=0 45 : MLENTI=0 46 : NCOS=NCOSI 47 : NCOV(1)=NCOVI(1) 48 : NCOV(2)=NCOVI(2) 49 : NCOV(3)=NCOVI(3) 50 : 51 : XVAL(1) = 0.D0 52 : XVAL(2) = 0.D0 53 : XVAL(3) = 0.D0 54 : MCHPOI = 0 55 : 55 : CALL LITDMD(MMODEL,MTABD,IRET) 56 : IF(IRET.EQ.0)RETURN 56 : IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD) 57 : C INEFMD=1 LINE =2 MACRO =3 QUADRATIQUE =4 LINB 58 : 59 : 60 : C WRITE(*,*)' on cherche les MOT des sous-type du CHPOINT résultat' 61 : C 62 : C SCAL SOMMET 63 : C VECT FACE 64 : C CENTRE 65 : 65 : CALL LIRMOT(LTYPC,3,IPC,1) 66 : IF(IPC.EQ.0)RETURN 66 : CALL LIRMOT(LTYPG,6,IPG,1) 67 : IF(IPG.EQ.0)RETURN 68 : 69 : IF(IPC.EQ.1)THEN 70 : NC=1 71 : ELSEIF(IPC.EQ.2)THEN 72 : NC=IDIM 73 : ELSEIF(IPC.EQ.3)THEN 74 : NC=IDIM*IDIM 75 : ENDIF 76 : 76 : CALL QUETYP(MTYP,0,IRET) 77 : IF(IRET.EQ.0)GO TO 90 78 : IF(MTYP.EQ.'MOT')THEN 78 : CALL LIRMOT(LTYPG(7),2,IPC,1) 79 : IF(IPC.EQ.0)THEN 80 : C Il manque le mot-clé %m1:4 81 : MOTERR(1:4)='COMP' 81 : CALL ERREUR(396) 82 : MOTERR(1:4)='VERI' 82 : CALL ERREUR(396) 83 : 84 : RETURN 85 : ENDIF 86 : 87 : IF(IPC.EQ.1)THEN 88 : IF(NC.EQ.1)THEN 88 : CALL LIRCHA(NCOS,1,IRET) 89 : IF(IRET.EQ.0)RETURN 90 : ELSE 90 : CALL QUETYP(MTYP,0,IRET) 91 : C write(6,*)' MTYP,nc=',MTYP,nc 92 : IF(IRET.EQ.0)RETURN 93 : IF(MTYP.EQ.'LISTMOTS')THEN 93 : CALL LIROBJ('LISTMOTS',MLMOTS,1,IRET) 94 : IF(IRET.EQ.0)RETURN 95 : SEGACT MLMOTS 96 : JGM=MOTS(/2) 97 : DO 128 I=1,NC 97 : C? CALL LIRCHA(NCOV(I),1,IRET) 98 : C? IF(IRET.EQ.0)RETURN 99 : NCOV(I)=MOTS(I) 100 : 128 CONTINUE 101 : 102 : ELSEIF(MTYP.EQ.'MOT')THEN 103 : DO 129 I=1,NC 103 : CALL LIRCHA(NCOV(I),1,IRET) 104 : IF(IRET.EQ.0)RETURN 105 : 129 CONTINUE 106 : ELSE 107 : RETURN 108 : ENDIF 109 : ENDIF 110 : ELSEIF(IPC.EQ.2)THEN 111 : KVERIF=1 112 : ENDIF 113 : 113 : CALL QUETYP(MTYP,0,IRET) 114 : IF(IRET.EQ.0)GO TO 90 115 : 116 : ENDIF 117 : 118 : IF(IPG.GE.4.AND.IPG.NE.6)THEN 119 : IF(INEFMD.NE.2.AND.INEFMD.NE.3.AND.INEFMD.NE.4)THEN 120 : C Option %m1:8 incompatible avec les données 121 : MOTERR( 1: 8) = LTYPG(IPG) 121 : CALL ERREUR(803) 122 : RETURN 123 : ENDIF 124 : ENDIF 125 : 126 : TYPG=LTYPG(IPG) 126 : CALL LEKTAB(MTABD,TYPG,MELEME) 127 : 128 : 129 : NAT=2 130 : NSOUPO=1 131 : SEGACT MELEME 132 : N=NUM(/2) 133 : SEGDES MELEME 134 : SEGINI MCHPOI,MSOUPO,MPOVAL 135 : C write(6,*)' KCHT on initialise MCHPOI n,nc=',n,nc 136 : 137 : MTYPOI=TYPG 138 : MOCHDE=TITREE 139 : JATTRI(1)=2 140 : IPCHP(1)=MSOUPO 141 : IFOPOI=IFOMOD 142 : IF(NC.EQ.1)THEN 143 : C write(6,*)' On attribue le nom de composante :',ncos,' :' 144 : NOCOMP(1)=NCOS 145 : ELSE 146 : DO 127 I=1,NC 147 : C write(6,*)' On attribue le nom de composante :',ncov(i),' :' 148 : NOCOMP(I)=NCOV(I) 149 : 127 CONTINUE 150 : ENDIF 151 : IGEOC=MELEME 152 : IPOVAL=MPOVAL 153 : 154 : IF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER ')THEN 155 : C On initialise le CHPOINT a une constante si c'est un SCAL 156 : IF(NC.NE.1)THEN 157 : WRITE(6,*)' CHPOINT SCAL Initialisation incompatible ' 157 : CALL ERREUR(156) 158 : C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n 159 : C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu 160 : RETURN 161 : ENDIF 162 : 162 : CALL LIRREE(XVAL(1),1,IRET) 162 : CALL INITD(VPOCHA,N,XVAL(1)) 163 : 164 : ELSEIF(MTYP.EQ.'POINT ')THEN 165 : IF(NC.EQ.1)THEN 166 : WRITE(6,*)' CHPOINT VECT Initialisation incompatible ' 166 : CALL ERREUR(156) 167 : C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n 168 : C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu 169 : RETURN 170 : ENDIF 170 : CALL LIROBJ('POINT ',IP,1,IRET) 171 : XVAL(1)=XCOOR((IP-1)*(IDIM+1) +1) 172 : XVAL(2)=XCOOR((IP-1)*(IDIM+1) +2) 173 : IF(NC.EQ.3)XVAL(3)=XCOOR((IP-1)*(IDIM+1) +3) 174 : C On construit le CHPOINT résultat si celui-ci ne l'a pas déjà été ... 174 : CALL INITD(VPOCHA,N,XVAL(1)) 174 : CALL INITD(VPOCHA(1,2),N,XVAL(2)) 174 : IF(NC.EQ.3)CALL INITD(VPOCHA(1,3),N,XVAL(3)) 175 : IF(NC.EQ.4.OR.NC.EQ.9)WRITE(6,*)' Cas non encore implemente' 176 : 177 : ELSEIF(MTYP.NE.'CHPOINT')THEN 178 : WRITE(6,*)' Type d objet incorrect pour l initialisation' 179 : C Indice %m1:8 : Objet de type %m9:16 incorrect 180 : MOTERR(1:8)=' ' 181 : MOTERR(9:16)=MTYP 181 : CALL ERREUR(787) 182 : RETURN 183 : ENDIF 184 : 185 : 186 : C write(6,*)' On cherche les champoints à charger ... ' 186 : CALL KRIPAD(MELEME,MLENTI) 187 : 10 CONTINUE 187 : CALL LIROBJ('CHPOINT',MCHPO1,0,IRET) 188 : IF(IRET.EQ.0)GO TO 11 189 : 190 : SEGACT MCHPO1 191 : NSOUP1=MCHPO1.IPCHP(/1) 192 : 193 : IKCOMP=0 194 : DO 1 L=1,NSOUP1 195 : MSOUP1=MCHPO1.IPCHP(1) 196 : SEGACT MSOUP1 197 : NC1=MSOUP1.NOCOMP(/2) 198 : DO 2 M=1,NC1 199 : DO 3 K=1,NC 200 : C write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K) 201 : 202 : IF(MSOUP1.NOCOMP(M).EQ.NOCOMP(K))THEN 203 : IKCOMP=IKCOMP+1 204 : MELEME=MSOUP1.IGEOC 205 : MPOVA1=MSOUP1.IPOVAL 206 : SEGACT MELEME,MPOVA1 207 : NPT=NUM(/2) 208 : IKVAL=0 209 : DO 4 I=1,NPT 210 : I1=LECT(NUM(1,I)) 211 : IF(I1.EQ.0)GO TO 4 212 : IKVAL=IKVAL+1 213 : VPOCHA(I1,K)=MPOVA1.VPOCHA(I,M) 214 : 4 CONTINUE 215 : SEGDES MELEME,MPOVA1 216 : IF(IKVAL.EQ.0)THEN 217 : write(6,*)' Opérateur KCHT : aucun point pour la composante ', 218 : &NOCOMP(M) 219 : C Le chpoint donné est vide, ou bien son contenu est incompatible avec les noms 220 : Cde composante imposés par le listmots et le mot-clé (donné ou sous-entendu) 220 : CALL ERREUR(156) 221 : RETURN 222 : ENDIF 223 : IF(KVERIF.NE.0)THEN 224 : write(6,*)' Opérateur KCHT : la composante ',NOCOMP(M), 225 : &' a été initialisée' 226 : ENDIF 227 : 228 : ENDIF 229 : 230 : 3 CONTINUE 231 : 2 CONTINUE 232 : SEGDES MSOUP1 233 : 1 CONTINUE 234 : IF(IKCOMP.EQ.0)THEN 235 : write(6,*)' Opérateur KCHT : ' 236 : write(6,*)' Aucune composante n''a été initialisée' 237 : write(6,*)' Liste des composantes : ' 238 : DO 21 L=1,NSOUP1 239 : MSOUP1=MCHPO1.IPCHP(1) 240 : SEGACT MSOUP1 241 : NC1=MSOUP1.NOCOMP(/2) 242 : DO 21 M=1,NC1 243 : DO 21 K=1,NC 244 : write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K) 245 : 21 CONTINUE 246 : SEGDES MSOUP1 247 : C La composante %m1:4 n'existe pas pour le champ %m5:8 248 : MOTERR(1:4)=' ' 249 : MOTERR(5:8)=' ' 249 : CALL ERREUR(77) 250 : 251 : RETURN 252 : ENDIF 253 : SEGDES MCHPO1 254 : 255 : GO TO 10 256 : 257 : 11 CONTINUE 258 : 259 : SEGDES MPOVAL,MSOUPO,MCHPOI 260 : IF(MLENTI.NE.0)SEGSUP MLENTI 260 : CALL ECROBJ('CHPOINT ',MCHPOI) 261 : RETURN 262 : 263 : 90 CONTINUE 264 : WRITE(6,*)' Arret anormal dans KCHT ' 265 : C Tache impossible. Probablement données erronées 265 : CALL ERREUR(26) 266 : 267 : 268 : RETURN 269 : END 270 : 271 : 272 : 273 : 274 : 275 : 276 : 277 : 278 : 279 : 280 :
© Cast3M 2003 - All rights reserved.
Disclaimer