Télécharger extrsk.eso

Retour à la liste

extrsk
C EXTRSK    SOURCE    CB215821  24/04/12    21:15:53     11897          
      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
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 

© Cast3M 2003 - Tous droits réservés.
Mentions légales