1 : C EXTRSK SOURCE CHAT 11/03/16 21:21:54 6902 2 : SUBROUTINE EXTRSK(IPCHE1,IPMOD1,NS,IPCHS1,IENT4,IERR1) 3 : C----------------------------------------------------------- 4 : C 5 : C EXTRSK 6 : C ------ 7 : C FONCTION: 8 : C SUBROUTINE APPELEE PAR CALP1 OU CALP2 POUR LE CAS DES COQUES MINCES 9 : C AVEC INTEGRATION DANS L'EPAISSEUR 10 : C 11 : C----------------------------------------------------------- 12 : C MODULES UTILISES 13 : C ---------------- 14 : C 15 : IMPLICIT INTEGER(I-N) 16 : -INC SMCHAML 17 : -INC SMMODEL 18 : -INC SMELEME 19 : -INC CCOPTIO 20 : C 21 : C 22 : C 23 : C PARAMETRES: (E)=ENTREE (S)=SORTIE 24 : C ---------- 25 : C 26 : C IPCHE1 (E) POINTEUR SUR UN MCHAML 27 : C IPMOD1 (E) POINTEUR SUR UN IMODEL (ACTIF) 28 : C NS (E) NUMERO DE LA ZONE 29 : C IPCHS1 (E) ET (S) POINTEUR SUR LE MCHAML A REMPLIR (ACTIF) 30 : C IENT4 (E) ENTIER = NUMERO DE LA COUCHE 31 : C IERR1 (E,S) PARAMETRE D'ERREUR 32 : C----------------------------------------------------------- 33 : C 34 : SEGMENT NOTYPE 35 : CHARACTER*16 TYPE(NBTYPE) 36 : ENDSEGMENT 37 : * 38 : SEGMENT MPTVAL 39 : INTEGER IPOS(NS) ,NSOF(NS) 40 : INTEGER IVAL(NCOSOU) 41 : CHARACTER*16 TYVAL(NCOSOU) 42 : ENDSEGMENT 43 : * 44 : INTEGER INFOS(3) 45 : CHARACTER*(NCONCH) CONM 46 : logical lsupde 47 : * 48 : MCHELM = IPCHE1 49 : SEGACT,MCHELM 50 : IMODEL=IPMOD1 51 : MCHEL1=IPCHS1 52 : * 53 : IPMAIL=IMAMOD 54 : CONM=CONMOD 55 : * 56 : *......INFORMATION SUR L'ELEMENT FINI.......... 57 : MELE=NEFMOD 57 : * CALL ELQUOI(MELE,0,5,INFO,IMODEL) 58 : NBG=INFELE(4)/INFMOD(1) 59 : * 60 : *......CREATION DU TABLEAU INFOS....... 60 : CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE1,INFOS,IRTD) 61 : IF (IRTD.EQ.0) THEN 62 : SEGDES MCHELM 63 : IERR1=1 64 : RETURN 65 : ENDIF 66 : * 67 : MCHEL1.INFCHE(NS,1)=1 68 : MCHEL1.INFCHE(NS,2)=0 69 : MCHEL1.INFCHE(NS,3)=NIFOUR 70 : MCHEL1.INFCHE(NS,4)=INFELE(11) 71 : MCHEL1.INFCHE(NS,5)=0 72 : MCHEL1.INFCHE(NS,6)=5 73 : MCHEL1.IMACHE(NS)=IMAMOD 74 : MCHEL1.CONCHE(NS)=CONMOD 75 : * 76 : *...........RECHERCHE DES NOMS COMPOSANTES........... 77 : lsupde=.false. 78 : IF (TITCHE(1:4).EQ.'DEFO') THEN 79 : if(lnomid(5).ne.0) then 80 : nomid=lnomid(5) 81 : segact nomid 82 : mocomp=nomid 83 : else 84 : lsupde=.true. 84 : CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) 85 : endif 86 : ELSE 87 : if(lnomid(4).ne.0) then 88 : nomid=lnomid(4) 89 : segact nomid 90 : mocomp=nomid 91 : ncomp=lesobl(/2) 92 : nfac=lesfac(/2) 93 : else 94 : lsupde=.true. 94 : CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) 95 : endif 96 : ENDIF 97 : * 98 : *...........VERIFICATION DE LEUR PRESENCE............ 99 : NBTYPE=1 100 : SEGINI NOTYPE 101 : MOTYPE=NOTYPE 102 : TYPE(1)='REAL*8' 102 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE, 103 : $ 1,INFOS,3,IVACOM) 104 : IF (IERR.NE.0) THEN 105 : SEGDES MCHELM 106 : IERR1=1 107 : RETURN 108 : ENDIF 109 : * 110 : *...........CREATION DU MCHAM DE LA SOUS ZONE........... 111 : N2=NCOMP 112 : SEGINI MCHAM1 113 : MCHEL1.ICHAML(NS)=MCHAM1 114 : * 115 : *...........RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER..... 116 : N1PTEL=0 117 : N1EL=0 118 : MPTVAL=IVACOM 119 : DO 110 ICOMP=1,NCOMP 120 : MELVAL=IVAL(ICOMP) 121 : M=MAX(N1PTEL,VELCHE(/1)) 122 : IF (M.GT.1) THEN 123 : N1PTEL=M/INFMOD(1) 124 : ELSE 125 : N1PTEL=M 126 : ENDIF 127 : N1EL=MAX(N1EL,VELCHE(/2)) 128 : N2PTEL=0 129 : N2EL=0 130 : SEGINI MELVA1 131 : MCHAM1.IELVAL(ICOMP)=MELVA1 132 : 110 CONTINUE 133 : * 134 : NOMID=MOCOMP 135 : SEGACT NOMID 136 : MPTVAL=IVACOM 137 : *...........BOUCLE SUR LES ELEMENTS....... 138 : DO 20 IB=1,N1EL 139 : * 140 : DO 20 IGAU=1,N1PTEL 141 : * 142 : DO 40 ICOMP=1,NCOMP 143 : MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) 144 : MCHAM1.TYPCHE(ICOMP)=TYPE(1) 145 : MELVAL=IVAL(ICOMP) 146 : SEGACT MELVAL 147 : MELVA1=MCHAM1.IELVAL(ICOMP) 148 : SEGACT MELVA1*MOD 149 : IGMN=MIN(IGAU,VELCHE(/1)) 150 : IBMN=MIN(IB,VELCHE(/2)) 151 : IF (IGMN.EQ.VELCHE(/1)) THEN 152 : MELVA1.VELCHE(IGAU,IB)=VELCHE(IGMN,IBMN) 153 : ELSE 154 : MELVA1.VELCHE(IGAU,IB)=VELCHE(IGAU+NBG* 155 : $ (IENT4-1),IBMN) 156 : ENDIF 157 : SEGDES MELVAL,MELVA1 158 : 40 CONTINUE 159 : 20 CONTINUE 160 : SEGDES MCHAM1,nomid 161 : SEGSUP MPTVAL,NOTYPE 162 : if(lsupde)segsup nomid 163 : * 164 : IPCHS1=MCHEL1 165 : * 166 : SEGDES IMODEL,MCHELM 167 : * SEGSUP INFO 168 : RETURN 169 : END 170 : 171 : 172 : 173 : 174 : 175 : 176 : 177 : 178 : 179 : 180 : 181 : 182 : 183 :
© Cast3M 2003 - All rights reserved.
Disclaimer