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

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