C EXTRSK SOURCE CB215821 20/11/04 21:17:14 10766 SUBROUTINE EXTRSK(IPCHE1,IPMOD1,NS,IPCHS1,IENT4,IERR1) C----------------------------------------------------------- C C EXTRSK C ------ C FONCTION: C SUBROUTINE APPELEE PAR CALP1 OU CALP2 POUR LE CAS DES COQUES MINCES C AVEC INTEGRATION DANS L'EPAISSEUR C C----------------------------------------------------------- C MODULES UTILISES C ---------------- C IMPLICIT INTEGER(I-N) -INC SMCHAML -INC SMMODEL -INC SMELEME -INC PPARAM -INC CCOPTIO C C C C PARAMETRES: (E)=ENTREE (S)=SORTIE C ---------- C C IPCHE1 (E) POINTEUR SUR UN MCHAML C IPMOD1 (E) POINTEUR SUR UN IMODEL (ACTIF) C NS (E) NUMERO DE LA ZONE C IPCHS1 (E) ET (S) POINTEUR SUR LE MCHAML A REMPLIR (ACTIF) C IENT4 (E) ENTIER = NUMERO DE LA COUCHE C IERR1 (E,S) PARAMETRE D'ERREUR C----------------------------------------------------------- C SEGMENT NOTYPE CHARACTER*16 TYPE(NBTYPE) ENDSEGMENT * SEGMENT MPTVAL INTEGER IPOS(NS) ,NSOF(NS) INTEGER IVAL(NCOSOU) CHARACTER*16 TYVAL(NCOSOU) ENDSEGMENT * INTEGER INFOS(3) CHARACTER*(NCONCH) CONM logical lsupde * MCHELM = IPCHE1 SEGACT,MCHELM IMODEL=IPMOD1 MCHEL1=IPCHS1 * IPMAIL=IMAMOD CONM=CONMOD * *......INFORMATION SUR L'ELEMENT FINI.......... MELE=NEFMOD * CALL ELQUOI(MELE,0,5,INFO,IMODEL) NBG=INFELE(4)/INFMOD(1) * *......CREATION DU TABLEAU INFOS....... CALL IDENT(IPMAIL,CONM,IPCHE1,IPCHE1,INFOS,IRTD) IF (IRTD.EQ.0) THEN SEGDES MCHELM IERR1=1 RETURN ENDIF * MCHEL1.INFCHE(NS,1)=1 MCHEL1.INFCHE(NS,2)=0 MCHEL1.INFCHE(NS,3)=NIFOUR MCHEL1.INFCHE(NS,4)=INFELE(11) MCHEL1.INFCHE(NS,5)=0 MCHEL1.INFCHE(NS,6)=5 MCHEL1.IMACHE(NS)=IMAMOD MCHEL1.CONCHE(NS)=CONMOD * *...........RECHERCHE DES NOMS COMPOSANTES........... lsupde=.false. IF (TITCHE(1:4).EQ.'DEFO') THEN if(lnomid(5).ne.0) then nomid=lnomid(5) segact nomid mocomp=nomid else lsupde=.true. CALL IDDEFO(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) endif ELSE if(lnomid(4).ne.0) then nomid=lnomid(4) segact nomid mocomp=nomid ncomp=lesobl(/2) nfac=lesfac(/2) else lsupde=.true. CALL IDCONT(IMODEL,IFOUR,MOCOMP,NCOMP,NFAC) endif ENDIF * *...........VERIFICATION DE LEUR PRESENCE............ NBTYPE=1 SEGINI NOTYPE MOTYPE=NOTYPE TYPE(1)='REAL*8' CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCOMP,MOTYPE, $ 1,INFOS,3,IVACOM) IF (IERR.NE.0) THEN SEGDES MCHELM IERR1=1 RETURN ENDIF * *...........CREATION DU MCHAM DE LA SOUS ZONE........... N2=NCOMP SEGINI MCHAM1 MCHEL1.ICHAML(NS)=MCHAM1 * *...........RECHERCHE DE LA TAILLE DES MELVAL A ALLOUER..... N1PTEL=0 N1EL=0 MPTVAL=IVACOM DO 110 ICOMP=1,NCOMP MELVAL=IVAL(ICOMP) M=MAX(N1PTEL,VELCHE(/1)) IF (M.GT.1) THEN N1PTEL=M/INFMOD(1) ELSE N1PTEL=M ENDIF N1EL=MAX(N1EL,VELCHE(/2)) N2PTEL=0 N2EL=0 SEGINI MELVA1 MCHAM1.IELVAL(ICOMP)=MELVA1 110 CONTINUE * NOMID=MOCOMP SEGACT NOMID MPTVAL=IVACOM *...........BOUCLE SUR LES ELEMENTS....... DO 20 IB=1,N1EL * DO 20 IGAU=1,N1PTEL * DO 40 ICOMP=1,NCOMP MCHAM1.NOMCHE(ICOMP)=LESOBL(ICOMP) MCHAM1.TYPCHE(ICOMP)=TYPE(1) MELVAL=IVAL(ICOMP) SEGACT MELVAL MELVA1=MCHAM1.IELVAL(ICOMP) SEGACT MELVA1*MOD IGMN=MIN(IGAU,VELCHE(/1)) IBMN=MIN(IB,VELCHE(/2)) IF (IGMN.EQ.VELCHE(/1)) THEN MELVA1.VELCHE(IGAU,IB)=VELCHE(IGMN,IBMN) ELSE MELVA1.VELCHE(IGAU,IB)=VELCHE(IGAU+NBG* $ (IENT4-1),IBMN) ENDIF SEGDES MELVAL,MELVA1 40 CONTINUE 20 CONTINUE SEGDES MCHAM1,nomid SEGSUP MPTVAL,NOTYPE if(lsupde)segsup nomid * IPCHS1=MCHEL1 * SEGDES IMODEL,MCHELM * SEGSUP INFO RETURN END