Télécharger la plaquette Cast3M


fr en

Télécharger adetat.eso

Retour à la liste

Numérotation des lignes : 

adetat

  1. C ADETAT    SOURCE    PV090527  25/01/07    12:39:18     12114          
  2.  
  3. *
  4. * on ne travaille que sur les formulations mecanique et poreux,
  5. *  thermique, diffusion (, electrostatique) et LIAISON (kich)
  6. *
  7.       subroutine adetat
  8.  
  9.       implicit real*8(a-h,o-Z)
  10.       implicit integer (i-n)
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC SMCOORD
  15.  
  16. -INC SMCHAML
  17. -INC SMCHPOI
  18. -INC SMMODEL
  19. -INC SMCHARG
  20. -INC SMTABLE
  21.       segment limode(0)
  22.       parameter (nnonom=16, nnoind=8, nnofor=10)
  23.       character*22 indic(nnoind)
  24.       dimension ilo(nnoind)
  25.       character*16 mformu(nnofor)
  26.       character*8 ctyp,mtyp,chai1
  27.       logical ibo
  28.       character*4 init(1),nomc,nonom(nnonom)
  29.       data nonom/'MECA','DIMP','TIMP','TERA','TECO',
  30.      $           'Q   ','DEFI','REAC','CIMP','UIMP',
  31.      $           'FORC','MODE','MATE','BLOD','BLOM','BLOT'/
  32.       data init/'NOUV'/
  33.       data indic /'DEPLACEMENTS          ','CONTRAINTES           ',
  34.      &            'TEMPERATURES          ','VARIABLES_INTERNES    ',
  35.      &            'DEFINELA              ','PROPORTIONS_PHASE     ',
  36.      &            'CONCENTRATIONS        ','POTENTIELS_ELECTRIQUES'/
  37.       data ilo / 12, 11, 12, 18, 8, 17, 14, 22 /
  38.       data mformu /'MECANIQUE       ','POREUX          ',
  39.      &             'LIAISON         ','DIFFUSION       ',
  40.      &             'ELECTROSTATIQUE ','THERMIQUE       ',
  41.      &             'CHARGEMENT      ','METALLURGIE     ',
  42.      &             'CHANGEMENT_PHASE','MELANGE         '/
  43.  
  44.       call lirmot(init,1,initia,0)
  45.  
  46.       call LIROBJ('MMODEL  ',IPMODL,1,iretou)
  47.       call ACTOBJ('MMODEL  ',IPMODL,1)
  48.       IF (IERR.NE.0) RETURN
  49. C     Extension du MMODEL en cas de modele de MELANGE
  50.       CALL MODETE(IPMODL,MMODEL,IMELAN)
  51.       IF (IERR.NE.0) RETURN
  52.  
  53. *  On cree un modele contenant les formulations dans mformu traitees par adetat
  54.       NSOUS=MMODEL.KMODEL(/1)
  55.       N1   =NSOUS
  56.       segini,MMODE1
  57.       NZON=0
  58.       DO I = 1, NSOUS
  59.         IMODEL=mmodel.KMODEL(I)
  60.         NFOR  =FORMOD(/2)
  61.         IF    (NFOR.EQ.1) THEN
  62.           CALL PLACE(mformu,nnofor,iplac,FORMOD(1))
  63.           if (iplac.EQ.0) GOTO 1119
  64.         ELSEIF(NFOR.EQ.2) THEN
  65.           CALL PLACE(mformu,2,iplac,FORMOD(1))
  66.           if (iplac.EQ.0) GOTO 1119
  67.           CALL PLACE(mformu,2,iplac,FORMOD(2))
  68.           if (iplac.EQ.0) GOTO 1119
  69.         ELSE
  70.           GOTO 1119
  71.         ENDIF
  72.         NZON=NZON+1
  73.         MMODE1.KMODEL(NZON) =  IMODEL
  74. 1119    CONTINUE
  75.       ENDDO
  76.       if (nzon.ne.nsous) then
  77.         n1 = nzon
  78.         segadj,MMODE1
  79.       endif
  80. c*      NSOUS=MMODE1.KMODEL(/1)
  81.       NSOUS=nzon
  82.  
  83.       if (initia.eq.0)then
  84.         mchelm=0
  85.         call LIROBJ('MCHAML  ',mchelm,1,iretou)
  86.         CALL ACTOBJ('MCHAML  ',mchelm,1)
  87.         if (ierr.ne.0) return
  88.         segini,mchel2=mchelm
  89.         n1=mchel2.ichaml(/1)
  90.         n3=mchel2.infche(/2)
  91.         l1=16
  92.         segadj,mchel2
  93.       else
  94.         n1=0
  95.         n3=6
  96.         l1=16
  97.         segini mchel2
  98.         mchel2.ifoche=ifour
  99.       endif
  100.       mchel2.TITCHE='cree par adetat'
  101.       n1io = n1
  102.  
  103. *-DEBUT de la boucle sur les arguments a lire pus a traiter
  104.       do i = 1, 1000
  105.         ctyp='  '
  106.         CALL QUETYP(CTYP,0,IRETOU)
  107. *        write(6,*) ' iretou ctyp' , iretou,ctyp
  108.          if (iretou.eq.0) go to 2
  109.  
  110.       if(ctyp.eq.'FLOTTANT'.or.ctyp.eq.'ENTIER') then
  111.          call lirree(xva,1,iret)
  112.          ctyp='FLOTTANT'
  113.          call lircha(nomc,1,iretou)
  114.       elseif(ctyp.eq.'MOT' ) then
  115.          call lircha(nomc,1,iretou)
  116.          call lirree(xva,1,iret)
  117.          ctyp='FLOTTANT'
  118.       else
  119.          call LIROBJ(ctyp,ipo,1,iretou)
  120.          call actobj(ctyp,ipo,1)
  121.       endif
  122.       if(ierr.ne.0) return
  123.  
  124.       if(ctyp.eq.'CHPOINT') then
  125.         CALL ACTOBJ('CHPOINT ',IPO,1)
  126.         CALL CHAME1(0,MMODE1,IPO,' ',Ipche2,5)
  127.         if (ierr.ne.0) return
  128.         ipo=ipche2
  129.  
  130.       elseif(ctyp.eq.'FLOTTANT') then
  131.          call ecrcha('STRESSES')
  132.          call ecrree(xva)
  133.          call ecrcha(nomc)
  134.          call ECROBJ('MMODEL  ',mmode1)
  135.          call ecrcha('CHML')
  136.          call manuel
  137.          if(ierr.ne.0) return
  138.          call LIROBJ('MCHAML  ',ipo,1,iretou)
  139.          call ACTOBJ('MCHAML  ',ipo,1)
  140.          if (ierr.ne.0) return
  141.  
  142.       elseif(ctyp.eq.'CHARGEME') then
  143.          mcharg=ipo
  144.          call lirree(xva,1,iret)
  145.          if(ierr.ne.0) return
  146.          segact mcharg
  147.          ika=0
  148.          do k=1,kcharg(/1)
  149.            nomc=chanom(k)
  150.            do  ka=1,nnonom
  151.              if( nomc.eq.nonom(ka) ) go to 10
  152.            enddo
  153.            ika=ika+1
  154.            call ecrcha(nomc)
  155.            call ecrree (xva)
  156.            call ECROBJ('CHARGEME',mcharg)
  157.            call tire
  158.            segact mcharg
  159.            call quetyp(ctyp,1,iretou)
  160.            if(ierr.ne.0) return
  161.            call LIROBJ(ctyp,ipa,1,iretou)
  162.            ipche2=ipa
  163.            if(ctyp.eq.'CHPOINT ') then
  164.               CALL ACTOBJ('CHPOINT ',IPA,1)
  165.               CALL CHAME1(0,MMODE1,IPA,' ',Ipche2,5)
  166.               IF (IERR.NE.0) RETURN
  167.            elseif (ctyp.eq.'MCHAML') then
  168. *
  169. *  AM  21/5/08
  170. *  SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  171. *  SI CE N'EST PAS POSSIBLE, ON VA EN 10
  172. *
  173.                CALL ACTOBJ('MCHAML  ',IPA,1)
  174.                CALL REDUAF(IPA,MMODE1,IPA2,0,IRET,KERRE)
  175.                IF(IRET.EQ.0) GO TO 10
  176.                CALL CHASUP(MMODE1,IPA2,IPche2,IRET,5)
  177.            else
  178. C SP 11/06/20
  179. C Si autre type (MMODEL par ex.), on itere :
  180. C            write(6,*) ' Objet tire du charg. de type', ctyp
  181.              GOTO 10
  182.            endif
  183.            mchel3=ipche2
  184.            n13= mchel3.ichaml(/1)
  185.            n33= mchel3.infche(/2)
  186.            iy=n1
  187.            n1 = n1 + n13
  188.            n3= max(n3,n33)
  189.            segadj mchel2
  190.            do kk=1,n13
  191.              mchel2.conche(iy+kk)=mchel3.conche(kk)
  192.              mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  193.              mchel2.imache(iy+kk)=mchel3.imache(kk)
  194.              do jk=1,n33
  195.                mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  196.              enddo
  197.            enddo
  198.    10      continue
  199.         enddo
  200.         go to 1
  201.  
  202.       elseif(ctyp.eq.'TABLE') then
  203.         ika=0
  204.         mtable=ipo
  205.         segact mtable
  206.         ika=0
  207.         do k=1,nnoind
  208.           mtyp=' '
  209.           call ACCTAB(mtable,'MOT     ',IJ,XJ,indic(k)(1:ilo(k)),ibo,IU,
  210.      $                    MTYP,IK,XK,CHAI1,IBO,IPA)
  211.           segact mtable
  212.           if(MTYP.EQ.' ') go to  11
  213.           if(MTYP.eq.'CHPOINT ') then
  214.               CALL ACTOBJ('CHPOINT ',IPA,1)
  215.               CALL CHAME1(0,MMODE1,IPA,' ',Ipche2,5)
  216.               IF (IERR.NE.0) RETURN
  217.           elseif(mtyp.eq.'MCHAML' ) then
  218. *
  219. *  AM  21/5/08
  220. *  SI C'EST UN MCHAML, ON LE REDUIT D'ABORD SUR LE MODELE
  221. *  SI CE N'EST PAS POSSIBLE, ON VA EN 11
  222. *
  223.                CALL ACTOBJ('MCHAML  ',IPA,1)
  224.                CALL REDUAF(IPA,MMODE1,IPA2,0,IRET,KERRE)
  225.                IF(IRET.EQ.0) GO TO 11
  226. *
  227.               CALL CHASUP(MMODE1,IPA2,IPche2,IRET,5)
  228.           else
  229.               go to 11
  230.           endif
  231.           mchel3=ipche2
  232.           n13= mchel3.ichaml(/1)
  233.           n33= mchel3.infche(/2)
  234.           iy=n1
  235.           n1 = n1 + n13
  236.           n3= max(n3,n33)
  237.           segadj mchel2
  238.           do kk=1,n13
  239.             mchel2.conche(iy+kk)=mchel3.conche(kk)
  240.             mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  241.             mchel2.imache(iy+kk)=mchel3.imache(kk)
  242.             do jk=1,n33
  243.               mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  244.             enddo
  245.           enddo
  246.    11     continue
  247.         enddo
  248.         go to 1
  249.       endif
  250.       mchel3=ipo
  251. *  PV
  252.       CALL CHASUP(MMODE1,mchel3,mchpv,IRET,5)
  253.       IF (IRET.NE.0) CALL ERREUR(IRET)
  254.       if (ierr.ne.0) return
  255.       mchel3=mchpv
  256.       n13= mchel3.ichaml(/1)
  257.       n33= mchel3.infche(/2)
  258.       iy=n1
  259.       n1 = n1 + n13
  260.       n3= max(n3,n33)
  261.       segadj mchel2
  262.       do kk=1,n13
  263.          mchel2.conche(iy+kk)=mchel3.conche(kk)
  264.          mchel2.ichaml(iy+kk)=mchel3.ichaml(kk)
  265.          mchel2.imache(iy+kk)=mchel3.imache(kk)
  266.          do jk=1,n33
  267.             mchel2.infche(iy+kk,jk)=mchel3.infche(kk,jk)
  268.          enddo
  269.       enddo
  270.  
  271.    1  continue
  272.       enddo
  273. *-FIN de la boucle sur les arguments
  274.  
  275. * Fin du traitement
  276.    2  continue
  277.       if (n1.eq.0) then
  278.         mchel1 = mchel2
  279.       else
  280. * on va essayer de regrouper les supports de chamelem car plusieurs
  281. * operateurs partent du principes que si un modele a n sous-zones le
  282. * chamelem doit avoir le meme nombre de sous zones
  283.         iprio=5
  284. *        call zpchel (mchel2,1)
  285.         call confor(mchel2,mchel1, mmodel,iprio)
  286. *        call zpchel( mchel1,1)
  287.       endif
  288.       call actobj('MCHAML  ',mchel1,1)
  289.       call ECROBJ('MCHAML  ',mchel1)
  290.  
  291.       segsup,mmode1
  292.  
  293. c      return
  294.       end
  295.  
  296.  
  297.  
  298.  
  299.  

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