Télécharger la plaquette Cast3M


fr en

Télécharger comcre.eso

Retour à la liste

Numérotation des lignes : 

comcre

  1. C COMCRE    SOURCE    CB215821  24/04/12    21:15:20     11897          
  2.       SUBROUTINE COMCRE(iqmod,ipcon,irang,mocomp,lscont,IPMINT,
  3.      &                  lesupp,iwrk53,jluc,iretou)
  4. *-
  5. * cree les deche necessaires associees aux noms de composantes
  6. *       et au rang argument (en sortie a priori)
  7. *   garde les adresses dans une pile
  8. *-
  9. *----------------------------------------------------------------
  10.       IMPLICIT INTEGER(I-N)
  11.       IMPLICIT REAL*8(A-H,O-Z)
  12. *
  13.  
  14. -INC PPARAM
  15. -INC CCOPTIO
  16. -INC SMMODEL
  17. -INC SMCHAML
  18. -INC DECHE
  19. *
  20.       imodel = iqmod
  21.       wrk53 = iwrk53
  22.  
  23.       lilcon = ipcon
  24.       iilcon=lilcon(/1)
  25.       ijlcon=iilcon
  26.  
  27.       pilnec = lscont
  28.       mobl = pilobl(/1)
  29.       mfac = pilfac(/1)
  30.  
  31. *-------------------------------------------------
  32. ***  jecree=0 veut dire de ne pas recreer le champ s'il existe en entrée
  33. ***   mais le récupérer.
  34.       jecree = 1
  35.       jtestj = 0
  36.       if (jluc.eq.2.or.jluc.eq.15) then
  37.         jecree=0
  38.       else if (jluc.eq.14) then
  39.         jecree=0
  40.       else if(jluc.eq.13) then
  41.         if (formod(1).eq.'MECANIQUE       ') then
  42.           jecree=0
  43.         else if (formod(1).eq.'POREUX          ') then
  44.           if (inplas.ge.0) jecree=0
  45.         else if (formod(1).eq.'LIAISON         ') then
  46.            jecree=0
  47. *        else if (formod(1).eq.'MELANGE         ') then
  48. *           if (cmate.eq.'PARALLEL') jecree=0
  49.         else if (formod(1).eq.'DIFFUSION       ') then
  50.           jecree=0
  51.         endif
  52. * specifique pour endommagement sic_sic
  53.         if (inplas.eq. 88) jtestj=15
  54. * specifique pour viscoplastique parfait
  55.         if (inplas.eq. 43) jtestj=6
  56. * specifique pour plastique isotrope tuyau
  57.         if (inplas.eq. 5) jtestj=3
  58. * specifique pour orthotrope viscoplastique mistral
  59.         if (inplas.eq. 94) jtestj=15
  60.       else if(jluc.eq.23) then
  61.         if (formod(1).eq.'MELANGE         ') then
  62.            if (cmate.eq.'PARALLEL') jecree=0
  63.         endif
  64.       else if(jluc.eq.26) then
  65.         jecree = 0        
  66.       endif
  67.  
  68.         nomid = mocomp
  69.         if (nomid.le.0) return
  70.  
  71.          nobl = lesobl(/2)
  72.          nfac = lesfac(/2)
  73.          call cotype(iqmod,jluc,motype,iwrk53,nobl,nfac)
  74.         notype = motype
  75.  
  76.         nbtype = 0
  77.         if (notype.NE.0) then
  78.          nbtype = type(/2)
  79.         ENDIF
  80.  
  81.         if (nbtype.ne.0) GOTO 200
  82. *
  83.             do jm =1,mobl
  84.               dec1=pilobl(jm,2)
  85.               if(dec1.eq.0) then
  86.                 dec1=pilobl(jm,1)
  87.               endif
  88.               if(FORMOD(1).EQ.'MELANGE         '.and.cmate.eq.'PARALLEL'
  89.      &           .and.pilobl(jm,3).gt.0 ) dec1 = pilobl(jm,3)
  90.              if (dec1.gt.0) then
  91.                 segini,deche=dec1
  92.                 indec = irang
  93.                 ijlcon=ijlcon+1
  94.                 if(ijlcon.gt.iilcon) then
  95.                    iilcon=iilcon+mobl+mfac
  96.                    segadj lilcon
  97.                 endif
  98.                 lilcon(ijlcon) = deche
  99.                 if (jecree.eq.1) then
  100.                   if (typree) then
  101.                        N1PTEL=NBPTEL
  102.                        N1EL=NEL
  103.                        N2PTEL=0
  104.                        N2EL=0
  105.                   else
  106.                        N2PTEL=NBPTEL
  107.                        N2EL=NEL
  108.                        N1PTEL=0
  109.                        N1EL=0
  110.                   endif
  111.                 segini melval
  112.                 ieldec = melval
  113.                 else
  114. c           if (cmate.eq.'PARALLEL'.and.jluc.eq.23) 
  115. c     &write(6,*) 'deche imite',nomdec,ieldec,n1ptel,n1el,condec,jecree
  116.                 endif
  117.                 pilobl(jm,irang)= deche
  118.               endif
  119.             enddo
  120.  
  121.             do jm =1,mfac
  122.               dec1=pilfac(jm,2)
  123.               if (dec1.gt.0) then
  124.                 segini,deche=dec1
  125.                 indec = irang
  126.                 ijlcon=ijlcon+1
  127.                 if(ijlcon.gt.iilcon) then
  128.                    iilcon=iilcon+mfac
  129.                    segadj lilcon
  130.                 endif
  131.                 lilcon(ijlcon) = deche
  132.                 if(jecree.eq.1) then
  133.                   if (typree) then
  134.                     N1PTEL=NBPTEL
  135.                     N1EL=NEL
  136.                     N2PTEL=0
  137.                     N2EL=0
  138.                   else
  139.                     N2PTEL=NBPTEL
  140.                     N2EL=NEL
  141.                     N1PTEL=0
  142.                     N1EL=0
  143.                   endif
  144.                   segini melval
  145.                   ieldec = melval
  146. **                  segdes melval
  147.                 endif
  148. **                segdes deche
  149.                 pilfac(jm,irang)= deche
  150.               endif
  151.             enddo
  152.  
  153.         GOTO 50
  154.  
  155.  200    CONTINUE
  156.         deche = lilcon(1)
  157. * n3 a revoir
  158.         n3 = infdec(/1)
  159. **        segdes deche
  160.         do 30 jm = 1, mobl
  161.             dec1=pilobl(jm,irang-1)
  162.             if(FORMOD(1).EQ.'MELANGE         '.and.cmate.eq.'PARALLEL'
  163.      &           .and.pilobl(jm,3).gt.0 ) dec1 = pilobl(jm,3)
  164.             if(dec1.eq.0) dec1=pilobl(jm,1)
  165.             segini deche
  166.             ijlcon=ijlcon+1
  167.             if( ijlcon.gt.iilcon) then
  168.                iilcon=iilcon + mobl + mfac
  169.                segadj lilcon
  170.             endif
  171.             lilcon(ijlcon) = deche
  172.             pilobl(jm,irang)=deche
  173.             nomdec = lesobl(jm)
  174.             imadec = imamod
  175.             ICMN=MIN(jm,NBTYPE)
  176.             typdec = type(icmn)
  177.             typree = typdec(1:6).eq.'REAL*8'
  178.  
  179.             condec = conmod
  180.             ifodec = IFOUR
  181.             indec = irang
  182.             infdec(1) = 0
  183.             infdec(2) = 0
  184.             infdec(3) = NIFOUR
  185.             infdec(4) = IPMINT
  186.             infdec(5) = 0
  187.             infdec(6) = lesupp
  188. *
  189.             if(jecree.eq.0) then
  190.             if(jm.le.jtestj.and.jluc.eq.13)go to 356
  191.              if(dec1.ne.0) then
  192.                ieldec = dec1.ieldec
  193. c           if (cmate.eq.'PARALLEL'.and.jluc.eq.23) 
  194. c     &write(6,*) 'dec rep', nomdec, ieldec, deche,dec1.condec,dec1.indec
  195.                go to 345
  196.              endif
  197.             endif
  198.   356  continue
  199.             if (type(icmn)(1:6).eq.'REAL*8') then
  200.               N1PTEL=NBPTEL
  201.               N1EL=NEL
  202.               N2PTEL=0
  203.               N2EL=0
  204.             else
  205.               N2PTEL=NBPTEL
  206.               N2EL=NEL
  207.               N1PTEL=0
  208.               N1EL=0
  209.             endif
  210.             segini melval
  211. *            write(6,*) 'cree ',nomdec,melval,n1ptel,n1el,condec
  212.             ieldec = melval
  213. **            segdes melval
  214.   345    continue
  215. **         segdes deche
  216.    30    continue
  217.  
  218.         do 31 jm =1,mfac
  219.             dec1=pilfac(jm,irang-1)
  220.             if(dec1.eq.0) dec1=pilfac(jm,1)
  221.             if (jluc.eq.20) then
  222.               if (formod(1).eq.'LIAISON         ') goto 340
  223. * kich : composantes facultatives MODAL / STATIQUE
  224.             else if (jluc.eq.11) then
  225.                if (imatee.eq.9 .or. imatee.eq.10) goto 340
  226.             endif
  227.             if(dec1.eq.0) go to 31
  228.  340        segini deche
  229.             ijlcon=ijlcon+1
  230.             if(ijlcon.gt.iilcon) then
  231.                iilcon = iilcon+mfac
  232.                segadj lilcon
  233.             endif
  234.             lilcon(ijlcon) = deche
  235.             pilfac(jm,irang)=deche
  236.             nomdec = lesfac(jm)
  237.             imadec = imamod
  238.             ICMN=MIN(jm+nobl,NBTYPE)
  239.             typdec = type(icmn)
  240.             typree = typdec(1:6).eq.'REAL*8'
  241.             condec = conmod
  242.             ifodec = IFOUR
  243.             indec = irang
  244.             infdec(1) = 0
  245.             infdec(2) = 0
  246.             infdec(3) = NIFOUR
  247.             infdec(4) = IPMINT
  248.             infdec(5) = 0
  249.             infdec(6) = lesupp
  250.             if(jecree.eq.0.and.dec1.gt.0) then
  251. C             segact dec1
  252.              ieldec=dec1.ieldec
  253. **             segdes dec1
  254. *           write(6,*) 'dec fac rep', nomdec, ieldec, deche,condec
  255.              go to 346
  256.             endif
  257.             if (type(icmn)(1:6).eq.'REAL*8') then
  258.               N1PTEL=NBPTEL
  259.               N1EL  =NEL
  260.               N2PTEL=0
  261.               N2EL  =0
  262.             else
  263.               N2PTEL=NBPTEL
  264.               N2EL  =NEL
  265.               N1PTEL=0
  266.               N1EL  =0
  267.             endif
  268. *
  269.          segini melval
  270. *           write(6,*) 'cree fac',cmatee,nomdec,melvaln1ptel,n1el,condec
  271.          ieldec = melval
  272.   346    continue
  273.   31    continue
  274.  
  275.   50  CONTINUE
  276.       segsup notype
  277. *
  278.       if (iilcon.ne.ijlcon) then
  279.         iilcon=ijlcon
  280.         segadj lilcon
  281.       endif
  282.  
  283.       END
  284.  
  285.  
  286.  
  287.  
  288.  

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