1 : C KMEC SOURCE CHAT 05/01/13 00:57:13 5004 2 : SUBROUTINE KMEC(MTABP,MATRAK) 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************ 6 : C Operateur KMEC 7 : C 8 : C OBJET : Cree un objet de type MATRAK 9 : C APPELE PAR KMAC 10 : C SYNTAXE : RESU = KMAC RVP; 11 : C 12 : C RVP : TABLE de soustype EQPR (cree par EQPR) 13 : C IMPR : impression du contenu de l'objet' 14 : C 15 : C REMARQUE : Cet objet n'est pas un objet STANDART CASTEM2000 16 : C Il n'est donc pas listable 17 : C Il est tout juste bon a mettre dans la table RVP pour etre utilise 18 : C par les operateurs de résolution de la matrice de contrainte 19 : C*********************************************************************** 20 : -INC CCOPTIO 21 : -INC SMCHPOI 22 : POINTEUR IZCH2.MCHPOI,IZCCH2.MPOVAL 23 : POINTEUR IZDV.MCHPOI,IZDDV.MPOVAL 24 : C-INC SMMATRAKANC 25 : C************************************************************************* 26 : C 27 : C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees 28 : C 29 : 30 : * LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange 31 : * (points CENTRE ) pour chaque operateur de contrainte 32 : * KGEOC SPG pour la totalite des points CENTRE. 33 : * KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse) 34 : * KLEMC Connectivites de l'ensemble des contraintes 35 : * LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones 36 : 37 : SEGMENT MATRAK 38 : INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP) 39 : INTEGER LIZAFM(NBSOUS) 40 : INTEGER IKAM0 (NBSOUS) 41 : INTEGER IMEM (NBELC) 42 : INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC 43 : ENDSEGMENT 44 : 45 : SEGMENT IZAFM 46 : REAL*8 AM(NNELP,NP,IESP),RPGI(NELAX) 47 : ENDSEGMENT 48 : 49 : POINTEUR IPMJ.IZAFM,IPMK.IZAFM 50 : 51 : C******************************************************************* 52 : -INC SMLENTI 53 : POINTEUR IZIPAD.MLENTI 54 : -INC SMLMOTS 55 : -INC SMTABLE 56 : POINTEUR MTABP.MTABLE,MTABX.MTABLE,MTABZ.MTABLE 57 : -INC SMELEME 58 : POINTEUR MELEMZ.MELEME,MELEMB.MELEME 59 : POINTEUR MELEM1.MELEME,MELES1.MELEME 60 : POINTEUR IGEOM.MELEME 61 : POINTEUR IZLEMC.MELEME 62 : 63 : LOGICAL*1 BVAL,VRAI 64 : PARAMETER (NBOPER=4) 65 : CHARACTER*8 LIOPER(NBOPER),TYPE,TYPC,NOML,NOMO,NOM,LMOT(1) 66 : C 67 : DATA LIOPER/'PRESSIO ','VNIMP ','VTIMP ','DPDQ '/ 68 : C*** 69 : IMPR=0 70 : TYPE=' ' 70 : CALL ACMO(MTABP,'LISTOPER',TYPE,MLMOTS) 71 : IF(TYPE.NE.'LISTMOTS')THEN 72 : RETURN 73 : ENDIF 74 : SEGACT MLMOTS 75 : NBOP=MOTS(/2) 76 : 77 : IZLEMC=0 78 : NBSOUS=0 79 : NBELC=0 80 : KM=1 81 : KMS=1 82 : SEGINI MATRAK 83 : 84 : DO 1 M=1,NBOP 85 : 86 : NOML=MOTS(M) 87 : TYPE=' ' 87 : CALL ACMO(MTABP,NOML,TYPE,MTABX) 88 : IF(TYPE.NE.'TABLE ')GO TO 90 89 : SEGACT MTABX 90 : TYPE=' ' 90 : CALL ACMO(MTABX,'DOMZ',TYPE,MTABZ) 91 : IF(TYPE.NE.'TABLE ')GO TO 90 92 : SEGACT MTABZ 93 : TYPE=' ' 93 : CALL ACMO(MTABZ,'CENTRE',TYPE,MELEM1) 94 : IF(TYPE.NE.'MAILLAGE')GO TO 90 95 : 96 : IF(M.LT.10)THEN 97 : NOMO=MOTS(M)(2:8) 98 : ELSE 99 : NOMO=MOTS(M)(3:8) 100 : ENDIF 100 : CALL OPTLI(IP,LIOPER,NOMO,NBOPER) 101 : C write(6,*)' NOMO=',NOMO,':',' IP=',IP 102 : IF(IP.EQ.0)THEN 103 : WRITE(6,*)' Operateur : ',NOMO,' inconnu ' 104 : RETURN 105 : ENDIF 106 : 107 : IAXI = 0 108 : IF(IFOMOD.EQ.0)IAXI=2 109 : 110 : C On va chercher ou on construit MELEMZ et MELEMB 111 : 112 : 113 : TYPE=' ' 113 : CALL ACMO(MTABZ,'MAILLAGE',TYPE,MELEMZ) 114 : IF(TYPE.NE.'MAILLAGE')GO TO 90 114 : CALL KNBEL(MELEMZ,NBELCN) 115 : 116 : C pour MELEMB c'est plus complique 117 : 118 : LGEOC(M)=MELEM1 119 : 120 : IF(IP.EQ.2.OR.IP.EQ.3)THEN 120 : CALL ECRCHA('POI1') 120 : CALL ECROBJ('MAILLAGE',MELEMZ) 120 : CALL PRCHAN 121 : TYPE='MAILLAGE' 121 : CALL LIROBJ(TYPE,MELES1,1,IRET) 122 : IF(IRET.EQ.0)GO TO 90 123 : SEGACT MELES1 124 : IF(IRET.EQ.0)GO TO 90 124 : CALL KAMLPT(MELES1,MELEMZ,IRET) 125 : SEGDES MELES1 126 : MELEMZ=IRET 127 : SEGACT MELEMZ 128 : NBPZ=MELEMZ.NUM(/2) 129 : NBREF=MELEMZ.LISREF(/1) 130 : MELEMB=MELEMZ.LISREF(NBREF) 131 : LGEOC(M)=MELEMB 132 : C il semble que la numerotation soit meilleure sans l'appel de ORDOTA 133 : C au moins pour l'utilisation de VNSIMP et VTSIMP avec des CHPOINTs 133 : C CALL ORDOTA(MELEMZ.NUM,NBPZ) 133 : CALL KRIPAD(MELEMZ,IZIPAD) 134 : 135 : TYPE='CENTRE' 135 : CALL CRCHPT(TYPE,MELEMB,1,IZCH2) 135 : CALL ECMO(MTABX,'IZCH2','CHPOINT ',IZCH2) 135 : CALL LICHT(IZCH2,IZCCH2,TYPE,IGEOM) 136 : 137 : ENDIF 138 : 139 : C La on peut dire qu'on a MELEMZ et MELEMB 140 : 141 : MELEMB=LGEOC(M) 142 : SEGACT MELEMB 143 : NNELB=MELEMB.NUM(/2) 144 : IDEBS(M)=KMS 145 : IFINS(M)=KMS+NNELB-1 146 : KMS=KMS+NNELB 147 : SEGDES MELEMB 148 : 148 : CALL CATMEL(IZLEMC,MELEMZ) 149 : 150 : SEGACT MELEMZ 151 : NBSOUZ=MELEMZ.LISOUS(/1) 152 : IF(NBSOUZ.EQ.0)NBSOUZ=1 153 : NBSOU0=LIZAFM(/1) 154 : NBSOUS=NBSOU0+NBSOUZ 155 : NBELC=IMEM(/1) 156 : SEGADJ MATRAK 157 : 158 : DO 11 L=1,NBSOUZ 159 : IPT1=MELEMZ 160 : IF(NBSOUZ.NE.1)IPT1=MELEMZ.LISOUS(L) 161 : SEGACT IPT1 162 : NNELP=IPT1.NUM(/2) 163 : NELAX=0 164 : NP=IPT1.NUM(/1) 165 : IESP=IDIM 166 : NBELC0=IMEM(/1) 167 : NBELC=NBELC0+NNELP 168 : SEGADJ MATRAK 169 : 169 : CALL INITI(IMEM(KM),NNELP,NBSOU0+L) 170 : SEGINI IZAFM 171 : KAM0=KM 172 : LIZAFM(NBSOU0+L)=IZAFM 173 : IKAM0 (NBSOU0+L)=KAM0 174 : C write(6,*)' KAS kmac IP=',IP 175 : 176 : GO TO (10,20,30,40),IP 177 : 10 CONTINUE 178 : C write(6,*)' Appel a KPRESS' 178 : CALL KPRESS(IPT1,IZAFM,IAXI,IMPR) 179 : C write(6,*)' Retour de KPRESS ' 180 : GO TO 9 181 : 20 CONTINUE 182 : 183 : C write(6,*)' Appel a VNSIMP' 183 : CALL VNSIMP(IPT1,IZAFM,IZCCH2,IZIPAD) 184 : C write(6,*)' Retour de VNSIMP' 185 : SEGDES IZCH2,IZCCH2 186 : SEGSUP IZIPAD 187 : GO TO 9 188 : 30 CONTINUE 189 : 189 : CALL VTSIMP(IPT1,IZAFM,IZCCH2,IZIPAD) 190 : SEGDES IZCH2,IZCCH2 191 : SEGSUP IZIPAD 192 : GO TO 9 193 : 194 : 40 CONTINUE 195 : 195 : C CALL KDPDQ(IPT1,IZAFM,HK,IAXI,IMPR) 196 : C SEGDES IZCH2,IZCCH2 197 : C SEGSUP IZIPAD 198 : write(6,*)' Operateur hors service ' 199 : GO TO 9 200 : 201 : 9 CONTINUE 202 : 203 : SEGDES IZAFM 204 : SEGDES IPT1 205 : KM=KM+NNELP 206 : 11 CONTINUE 207 : SEGDES MELEMZ 208 : SEGDES MTABX,MTABZ 209 : 210 : 1 CONTINUE 211 : 212 : IGEO1=LGEOC(1) 213 : 214 : IF(NBOP.GT.1)THEN 215 : IGEO1=0 216 : DO 2 M=1,NBOP 217 : MLGEOC=LGEOC(M) 217 : CALL FUSSPG(MLGEOC,IGEO1) 218 : 2 CONTINUE 219 : ENDIF 220 : 221 : KGEOC=IGEO1 222 : 223 : KLEMC=IZLEMC 224 : 225 : TYPE=' ' 225 : CALL ACMO(MTABP,'DIAGV',TYPE,IZDV) 226 : IF(TYPE.NE.'CHPOINT')THEN 227 : WRITE(6,*)' l''entree DIAGV n''existe pas dans la table EQPR' 228 : RETURN 229 : ENDIF 229 : CALL LICHT(IZDV,IZDDV,TYPC,IGEOM) 230 : SEGDES IZDV,IZDDV 231 : 232 : INK=1 232 : CALL KRIPAD(IGEOM,IZIPAD) 233 : NBPT=IZIPAD.LECT(/1) 234 : SEGACT IZLEMC 235 : NBSOUS=IZLEMC.LISOUS(/1) 236 : IF(NBSOUS.EQ.0)NBSOUS=1 237 : DO 401 L=1,NBSOUS 238 : IPT1=IZLEMC 239 : IF(NBSOUS.NE.1)IPT1=IZLEMC.LISOUS(L) 240 : SEGACT IPT1 241 : NP=IPT1.NUM(/1) 242 : NEL=IPT1.NUM(/2) 243 : MLENTI=IZIPAD 244 : DO 402 K=1,NEL 245 : DO 402 I=1,NP 246 : j=IPT1.NUM(I,K) 247 : IF(LECT(J).EQ.0)THEN 248 : INK=0 249 : C write(6,*)' Objet non inclus ' 250 : return 251 : endif 252 : 402 CONTINUE 253 : SEGDES IPT1 254 : 401 CONTINUE 255 : SEGDES IZLEMC 256 : SEGSUP IZIPAD 257 : 258 : KGEOS=IGEOM 259 : 260 : SEGDES MLMOTS 261 : SEGDES MATRAK 262 : RETURN 263 : 90 CONTINUE 264 : MATRAK=0 265 : RETURN 266 : 1001 FORMAT(20(1X,I5)) 267 : END 268 : 269 : 270 : 271 :
© Cast3M 2003 - All rights reserved.
Disclaimer