1 : C KRES9 SOURCE JC220346 13/12/16 21:15:51 7884 2 : SUBROUTINE KRES9(MRIGID,INORMU) 3 : IMPLICIT REAL*8 (A-H,O-Z) 4 : IMPLICIT INTEGER (I-N) 5 : C*********************************************************************** 6 : C NOM : KRES9 7 : C DESCRIPTION : - Assemblage comme par RESOU 8 : C 9 : C 10 : C LANGAGE : ESOPE 11 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 12 : C mél : gounand@semt2.smts.cea.fr 13 : C*********************************************************************** 14 : C VERSION : v1, 04/08/2011, version initiale 15 : C HISTORIQUE : v1, 04/08/2011, création 16 : C HISTORIQUE : JCARDO 16/07/2013, ajout de INORMU (cf LDMT2) 17 : C HISTORIQUE : 18 : C*********************************************************************** 19 : REAL*8 XKT,PREC 20 : -INC SMRIGID 21 : -INC SMMATRI 22 : -INC CCOPTIO 23 : C ... Ces variables ont pour but, de diriger le comportement de LDMT2 ... 24 : C TRSUP - TRiangle SUPérieur 25 : C MENAGE - évident 26 : C LDIAG - initialisation et remplissage de MDIAG et MDNOR demandés 27 : C 28 : LOGICAL TRSUP,MENAGE,LDIAG 29 : * 30 : * Executable statements 31 : * 32 : * WRITE(IOIMP,*) 'Entrée dans kres8.eso' 33 : * 34 : SEGACT MRIGID 35 : ICHOLX=ICHOLE 36 : SEGDES MRIGID 37 : IF(ICHOLX.NE.0) RETURN 38 : * Ici l'assemblage proprement dit recopié de LDMT1 39 : IF(IIMPI.EQ.1)THEN 39 : CALL GIBTEM(XKT) 40 : INTERR(1)=INT(XKT) 40 : CALL ERREUR(-259) 41 : ENDIF 42 : IF(IIMPI.EQ.1)WRITE(IOIMP,10) 43 : 10 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT ASNS1 ') 44 : 45 : C ... MMATRI est initialisé dans ASSEM1 et renvoyé en tant que résultat 46 : C dans la variable MMATRX, il est désactivé à la sortie ... 46 : CALL ASNS1(MRIGID,MMATRX,INUINX,ITOPOX,IMINIX,IPOX,INCTRX,INCTRZ, 47 : & IITOPX,ITOPOD,IITOPD,IPODD) 48 : IF(IERR.NE.0) RETURN 49 : 50 : IF(IIMPI.EQ.1) THEN 50 : CALL GIBTEM(XKT) 51 : INTERR(1)=INT(XKT) 51 : CALL ERREUR(-259) 52 : ENDIF 53 : IF(IIMPI.EQ.1)WRITE(IOIMP,11) 54 : 11 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LDMT2') 55 : C ... On initialise IJMAX ici et non dans LDMT2, car celui-ci est 56 : C appelé deux fois ... 57 : MMATRI=MMATRX 58 : SEGACT,MMATRI*MOD 59 : IJMAX=0 60 : SEGDES,MMATRI 61 : C 62 : TRSUP =.FALSE. 63 : MENAGE=.FALSE. 64 : LDIAG =.TRUE. 65 : njtot=0 66 : * write(6,*) ' premier appel' 66 : CALL LDMT2(MRIGID,ITOPOX,INUINX,IMINIX,MMATRX,IPOX,INCTRX,INCTRZ, 67 : & IITOPX,TRSUP,MENAGE,LDIAG,IITOPD,ITOPOD,IPODD,njtot,INORMU) 68 : IF(IERR.NE.0) RETURN 69 : TRSUP =.TRUE. 70 : MENAGE=.TRUE. 71 : LDIAG =.FALSE. 72 : * write(6,*) ' deucxieme appel' 72 : CALL LDMT2(MRIGID,ITOPOX,INUINX,IMINIX,MMATRX,IPOX,INCTRX,INCTRZ, 73 : & IITOPX,TRSUP,MENAGE,LDIAG,IITOPD,ITOPOD,IPODD,njtot,INORMU) 74 : IF(IERR.NE.0) RETURN 75 : 76 : IF(IIMPI.EQ.1)THEN 76 : CALL GIBTEM(XKT) 77 : INTERR(1)=INT(XKT) 77 : CALL ERREUR(-259) 78 : ENDIF 79 : IF(IIMPI.EQ.1) WRITE(IOIMP,12) 80 : 12 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LA FIN DE KRES9') 81 : IF(IERR.NE.0) RETURN 82 : * 83 : * Analyse de la structure 84 : * 85 : C MMATRI=MMATRX 86 : C SEGACT MMATRI 87 : C WRITE(IOIMP,*) 'IJMAX=',IJMAX 88 : C WRITE(IOIMP,*) 'IDIAG=',IDIAG 89 : C WRITE(IOIMP,*) 'IGEOMA=',IGEOMA 90 : C WRITE(IOIMP,*) 'IINCPO=',IINCPO 91 : C WRITE(IOIMP,*) 'IIDUA=',IIDUA 92 : C WRITE(IOIMP,*) 'IIMIK=',IIMIK 93 : C WRITE(IOIMP,*) 'INEG=',INEG 94 : C WRITE(IOIMP,*) 'IDNORM=',IDNORM 95 : C WRITE(IOIMP,*) 'IILIGN=',IILIGN 96 : C WRITE(IOIMP,*) 'IILIGS=',IILIGS 97 : C WRITE(IOIMP,*) 'NENS=',NENS 98 : C WRITE(IOIMP,*) 'IHARK=',IHARK 99 : C WRITE(IOIMP,*) 'IASLIG=',IASLIG 100 : C WRITE(IOIMP,*) 'IASDIA=',IASDIA 101 : C WRITE(IOIMP,*) 'IDUAPO=',IDUAPO 102 : C WRITE(IOIMP,*) 'IHARDU=',IHARDU 103 : C WRITE(IOIMP,*) 'IDNORD=',IDNORD 104 : C WRITE(IOIMP,*) 'PRCHLV=',PRCHLV 105 : C* SEGPRT,MMATRI 106 : C IF (IGEOMA.NE.0) THEN 107 : C MELEME=IGEOMA 108 : C WRITE(IOIMP,*) 'IGEOMA' 108 : C CALL ECMAIL(MELEME,0) 109 : C ENDIF 110 : C IF (IIMIK.NE.0) THEN 111 : C MIMIK=IIMIK 112 : C SEGACT MIMIK 113 : C N=IMIK(/2) 114 : C WRITE(IOIMP,*) 'IIMIK N=',N 115 : C WRITE(IOIMP,2019) (IMIK(I),I=1,N) 116 : C ENDIF 117 : C IF (IIDUA.NE.0) THEN 118 : C MIDUA=IIDUA 119 : C SEGACT MIDUA 120 : C N=IDUA(/2) 121 : C WRITE(IOIMP,*) 'IIDUA N=',N 122 : C WRITE(IOIMP,2019) (IDUA(I),I=1,N) 123 : C ENDIF 124 : C IF (IINCPO.NE.0) THEN 125 : C MINCPO=IINCPO 126 : C SEGACT MINCPO 127 : C MAXI=INCPO(/1) 128 : C NNOE=INCPO(/2) 129 : C WRITE(IOIMP,*) 'IINCPO MAXI=',MAXI,' NNOE=',NNOE 130 : C WRITE(IOIMP,*) 'Tableau de correspondance Inconnue-Point' 131 : C $ ,'-> DDL' 132 : C DO 146 L=1,MAXI,10 133 : C WRITE(IOIMP,'(8X,A)') 'Inconnue' 134 : C LH = MIN(L+9,MAXI) 135 : C WRITE(IOIMP,*) 'LH=',LH 136 : C WRITE (IOIMP,147) 'Point',(M,M=L,LH) 137 : C 147 FORMAT (A8,10I8) 138 : C DO 148 J=1,NNOE 139 : C WRITE(IOIMP,149) J,(INCPO(K,J),K=L,LH) 140 : C 149 FORMAT (11I8) 141 : C 148 CONTINUE 142 : C 146 CONTINUE 143 : C ENDIF 144 : C IF (IDUAPO.NE.0) THEN 145 : C MINCPO=IDUAPO 146 : C SEGACT MINCPO 147 : C MAXI=INCPO(/1) 148 : C NNOE=INCPO(/2) 149 : C WRITE(IOIMP,*) 'IDUAPO MAXI=',MAXI,' NNOE=',NNOE 150 : C WRITE(IOIMP,*) 'Tableau de correspondance Inconnue-Point' 151 : C $ ,'-> DDL' 152 : C DO 246 L=1,MAXI,10 153 : C WRITE(IOIMP,'(8X,A)') 'Inconnue' 154 : C LH = MIN(L+9,MAXI) 155 : C WRITE (IOIMP,247) 'Point',(M,M=L,LH) 156 : C 247 FORMAT (A8,10I8) 157 : C DO 248 J=1,NNOE 158 : C WRITE(IOIMP,249) J,(INCPO(K,J),K=L,LH) 159 : C 249 FORMAT (11I8) 160 : C 248 CONTINUE 161 : C 246 CONTINUE 162 : C ENDIF 163 : C IF (IDIAG.NE.0) THEN 164 : C MDIAG=IDIAG 165 : C SEGACT MDIAG 166 : C WRITE(IOIMP,*) 'IDIAG INC=',DIAG(/1) 167 : C WRITE(IOIMP,2022) (DIAG(II),II=1,DIAG(/1)) 168 : C ENDIF 169 : C IF (IDNORM.NE.0) THEN 170 : C MDNOR=IDNORM 171 : C SEGACT MDNOR 172 : C WRITE(IOIMP,*) 'IDNORM INC=',DNOR(/1) 173 : C WRITE(IOIMP,2022) (DNOR(II),II=1,DNOR(/1)) 174 : C ENDIF 175 : C IF (IDNORD.NE.0) THEN 176 : C MDNOR=IDNORD 177 : C SEGACT MDNOR 178 : C WRITE(IOIMP,*) 'IDNORD INC=',DNOR(/1) 179 : C WRITE(IOIMP,2022) (DNOR(II),II=1,DNOR(/1)) 180 : C ENDIF 181 : C IF (IILIGN.NE.0) THEN 182 : C MILIGN=IILIGN 183 : C SEGACT MILIGN 184 : C WRITE(IOIMP,*) 'IILIGN INC=',IPNO(/1),' NNOE=',ILIGN(/1) 185 : C WRITE(IOIMP,*) ' IPNO' 186 : C WRITE(IOIMP,2020) (IPNO(II),II=1,IPNO(/1)) 187 : C WRITE(IOIMP,*) ' ITTR' 188 : C WRITE(IOIMP,2020) (ITTR(II),II=1,ITTR(/1)) 189 : C DO INOE=1,ILIGN(/1) 190 : C WRITE(IOIMP,*) ' Point ', INOE 191 : C LLIGN=ILIGN(INOE) 192 : C SEGACT LLIGN 193 : C WRITE(IOIMP,*) ' LLIGN NA=',IMMMM(/1),' LLVVA=',XXVA(/1) 194 : C WRITE(IOIMP,*) ' NJMAX=',NJMAX 195 : C WRITE(IOIMP,*) ' IMMMM' 196 : C WRITE(IOIMP,2020) (IMMMM(II),II=1,IMMMM(/1)) 197 : C WRITE(IOIMP,*) ' LDEB' 198 : C WRITE(IOIMP,2020) (LDEB(II),II=1,LDEB(/1)) 199 : C WRITE(IOIMP,*) ' IPPO' 200 : C WRITE(IOIMP,2020) (IPPO(II),II=1,IPPO(/1)) 201 : C WRITE(IOIMP,*) ' LINC' 202 : C WRITE(IOIMP,2020) (LINC(II),II=1,LINC(/1)) 203 : C WRITE(IOIMP,*) ' XXVA' 204 : C WRITE(IOIMP,2022) (XXVA(II),II=1,XXVA(/1)) 205 : C ENDDO 206 : C ENDIF 207 : C IF (IILIGS.NE.0) THEN 208 : C MILIGN=IILIGS 209 : C SEGACT MILIGN 210 : C WRITE(IOIMP,*) 'IILIGS INC=',IPNO(/1),' NNOE=',ILIGN(/1) 211 : C WRITE(IOIMP,*) ' IPNO' 212 : C WRITE(IOIMP,2020) (IPNO(II),II=1,IPNO(/1)) 213 : C WRITE(IOIMP,*) ' ITTR' 214 : C WRITE(IOIMP,2020) (ITTR(II),II=1,ITTR(/1)) 215 : C DO INOE=1,ILIGN(/1) 216 : C WRITE(IOIMP,*) ' Point ', INOE 217 : C LLIGN=ILIGN(INOE) 218 : C SEGACT LLIGN 219 : C WRITE(IOIMP,*) ' LLIGN NA=',IMMMM(/1),' LLVVA=',XXVA(/1) 220 : C WRITE(IOIMP,*) ' NJMAX=',NJMAX 221 : C WRITE(IOIMP,*) ' IMMMM' 222 : C WRITE(IOIMP,2020) (IMMMM(II),II=1,IMMMM(/1)) 223 : C WRITE(IOIMP,*) ' LDEB' 224 : C WRITE(IOIMP,2020) (LDEB(II),II=1,LDEB(/1)) 225 : C WRITE(IOIMP,*) ' IPPO' 226 : C WRITE(IOIMP,2020) (IPPO(II),II=1,IPPO(/1)) 227 : C WRITE(IOIMP,*) ' LINC' 228 : C WRITE(IOIMP,2020) (LINC(II),II=1,LINC(/1)) 229 : C WRITE(IOIMP,*) ' XXVA' 230 : C WRITE(IOIMP,2022) (XXVA(II),II=1,XXVA(/1)) 231 : C ENDDO 232 : C ENDIF 233 : C 2019 FORMAT (20(2X,A4) ) 234 : C 2020 FORMAT (20(2X,I4) ) 235 : C 2021 FORMAT (20(2X,L4) ) 236 : C 2022 FORMAT(10(1X,1PG12.5)) 237 : SEGACT MRIGID*MOD 238 : ICHOLE=MMATRX 239 : SEGDES MRIGID 240 : RETURN 241 : * 242 : * End of subroutine KRES9 243 : * 244 : END 245 : 246 : 247 :
© Cast3M 2003 - All rights reserved.
Disclaimer