Télécharger recof2.eso

Retour à la liste

recof2
C RECOF2    SOURCE    CB215821  24/04/12    21:17:05     11897          
      SUBROUTINE RECOF2(ipmodl,ipcha1,ichp1,ipout)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMMODEL
-INC SMCHAML
-INC SMCOORD
-INC SMLMOTS
 
      CHARACTER*(LOCOMP)  mocom1
 
      segment icta
        integer icpt(ima)
        character*4 iccomp(ima)
      endsegment
      segment icpr(nbpts)
      segment modsta
       integer pimoda(nmoda),pistat(nstat)
       integer ivmoda(nmoda),ivstat(nstat)
      endsegment
      SEGMENT MSWMIL
        CHARACTER*(LOCOMP)  MOTDDL(IA)
      ENDSEGMENT
*
      PARAMETER(NDEPL=10)
      CHARACTER*4 CMOT
      CHARACTER*8 CMATE
      CHARACTER*(NCONCH) CONM
      CHARACTER*4 MLDREE(ndepl),MLDIMA(ndepl)
      DATA MLDREE/'UX','UY','UZ','UR','UT','RX','RY','RZ','RT','P'/
      DATA MLDIMA/'IUX','IUY','IUZ','IUR','IUT','IRX','IRY','IRZ','IRT'
     &,'IP'/
 
 
       nstat = 100
       kstat = 0
       nmoda = 100
       kmoda = 0
       segini modsta
 
      segini icpr
      ipout = 0
      impou = 0
      IA = 1
      segini mswmil
      motddl(1) = 'LX'
 
      MMODEL = IPMODL
      SEGACT MMODEL
      NSOUS = KMODEL(/1)
 
      MCHELM = IPCHA1
      segact mchelm
 
      DO 50 ISOUS=1,NSOUS
      IMODEL=KMODEL(ISOUS)
      SEGACT IMODEL
      CMATE = cmatee
 
          if (cmate.eq.'STATIQUE'.or.cmate.eq.'MODAL') then
            do im = 1 , imache(/1)
              if (imache(im).eq.imamod) then
                if (conche(im).eq.conmod) then
                 mchaml = ichaml(im)
                 segact mchaml
                 do iv = 1,ielval(/1)
                  if (nomche(iv).eq.'DEFO') then
 
          if (cmate.eq.'STATIQUE') then
           kstat = kstat + 1
           ivstat(kstat) = ielval(iv)
           pistat(kstat) = imamod
                   meleme = imamod
                   segact meleme
            if (itypel.ne.1) call erreur(5)
             if (num(/1).ne.1) call erreur(5)
             do ip =1, num(/2)
                icpr(num(1,ip))=kstat
             enddo
           if (kstat.eq.nstat) then
            nstat = nstat + 100
            segadj modsta
           endif
          endif
          if (cmate.eq.'MODAL') then
           kmoda = kmoda + 1
           ivmoda(kmoda) = ielval(iv)
           pimoda(kmoda) = imamod
                   meleme = imamod
                   segact meleme
             if (itypel.ne.1) then
               call erreur(26)
               goto 99
             endif
             if (num(/1).ne.1) then
               call erreur(26)
               goto 99
             endif
             do ip =1 ,num(/2)
                icpr(num(1,ip))=kmoda
             enddo
           if (kmoda.eq.nmoda) then
            nmoda = nmoda + 100
            segadj modsta
           endif
          endif
                   melval =  ielval(iv)
                   segact melval
 
                  endif
                 enddo
                endif
              endif
            enddo
          endif
 
 50   CONTINUE
      nmoda = kmoda
      nstat = kstat
      segadj modsta
      if (nmoda.eq.0.and.nstat.eq.0) then
        call erreur(26)
        goto 99
      endif
 
      mchpoi = ichp1
      segact mchpoi
      nsoupo = ipchp(/1)
      DO is = 1 ,nsoupo
       msoupo = ipchp(is)
       segact msoupo
       NC = NOCOMP(/2)
       ipt1 = igeoc
       mpoval = ipoval
       segact ipt1,mpoval
       N = vpocha(/1)
       DO ic = 1,NC
        mocom1 = nocomp(ic)
        DO 90 ipn = 1 , N
          ipts = ipt1.num(1,ipn)
          sca1 = vpocha(ipn,ic)
          if (mocom1.eq.'BETA'.or.mocom1.eq.'IBET') then
            kstat = icpr(ipts)
            if (kstat.eq.0) goto 90
             melval = ivstat(kstat)
            meleme = pistat(kstat)
          else if (mocom1.eq.'ALFA'.or.mocom1.eq.'IALF') then
            kmoda = icpr(ipts)
            if (kmoda.eq.0) goto 90
            melval = ivmoda(kmoda)
            meleme = pimoda(kmoda)
          else
           goto 90
          endif
 
        if (mocom1.eq.'BETA'.or.mocom1.eq.'ALFA') then
            do ib = 1,num(/2)
             if (num(1,ib).eq.ipts) then
               ibmn = min(ib,ielche(/2))
               ichin = ielche(1,ibmn)
              if (ipout.gt.0) then
              ich1 = ipout
               call adchpo(ich1,ichin,ipout,1.d0,sca1)
              else
               call muchpo(ichin,sca1,ipout,1)
              endif
             endif
            enddo
        endif
 
        if (mocom1.eq.'IBET'.or.mocom1.eq.'IALF') then
            do ib = 1,num(/2)
             if (num(1,ib).eq.ipts) then
               ibmn = min(ib,ielche(/2))
               ichin = ielche(1,ibmn)
              if (impou.gt.0) then
              ich1 = impou
               call adchpo(ich1,ichin,impou,1.d0,sca1)
              else
               call muchpo(ichin,sca1,impou,1)
              endif
             endif
            enddo
        endif
 
 90     CONTINUE
       ENDDO
 
      ENDDO
 
 
       if (ipout.eq.0) call erreur(26)
       ich1 = ipout
          MCHPOI=ich1
          SEGACT MCHPOI*MOD
          JATTRI(1)=1
           CALL ENLEV5(ICH1,MSWMIL,ipout)
 
       if (impou.gt.0) then
           CALL ENLEV5(impou,MSWMIL,ich2)
         JGN = 4
         JGM = ndepl
         segini mlmot1,mlmot2
         iplm1 = mlmot1
         iplm2 = mlmot2
         do im = 1,JGM
           mlmot1.mots(im) = mldree(im)
           mlmot2.mots(im) = mldima(im)
         enddo
         CALL NOMC2(ich2,IPLM1,IPLM2,impou)
         MCHPOI=impou
         JATTRI(1)=1
         ipout = impou
         CALL FUCHPO(ICH1,impou,IPOUT)
       endif
 99    segsup modsta,icpr
 
      END
 
 
 

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