Sources Esope | Cast3M

recof1
C RECOF1    SOURCE    CB215821  20/11/25    13:38:44     10792          
      SUBROUTINE RECOF1(itbst,itbm,ichp1,ipout)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
************************************************************************
*
* CREATION : Joel KICHENIN
* MODIFS :
* Benoit PRABEL, 1/08/2014 : ajout possibilite de n'avoir que itbm
* BP, 11/12/2017 : corrections pour parallelisme
*
************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMTABLE
-INC SMCOORD
 
************************************************************************
*  -INC TMYTAB
*                                                                       
*     SEGMENT POUR "DEBOBINER" UN OBJET DE TYPE 'TABLE' 
*     D'UN SOUSTYPE PARTICULIER PRECISE PAR ITYTAB                                                  
*     Le but est de faciliter la programmation esope notamment en //
*
*     ITYTAB = | BASE_MODALE
*              | LIAISONS_STATIQUES
*              | ... a completer
*
*     KPTREP(i) = POINT_REPERE du ieme mode/solution statique
*     KDEFO(i)  = DEFORMEE_MODALE / DEFORMEE
*     KICPR(#noeud POINT_REPERE) = i^eme mode
*     DDLLIA(i) = composante de la liaison statique
*     KPTLIA(i) = point en jeu dans la liaison statique
*
 
      SEGMENT MYTAB                                                           
        CHARACTER*24       ITYTAB                                                       
        INTEGER            KPTREP(NMY),KDEFO(NMY)
        INTEGER            KICPR(NMY2)
        CHARACTER*(LOCOMP) DDLLIA(NMY3)
        INTEGER            KPTLIA(NMY3)
      ENDSEGMENT                                                                
      POINTEUR MYTAB1.MYTAB,MYTAB2.MYTAB,MYTAB3.MYTAB                                         
 
************************************************************************
 
c     icpr(ip)=nombre de fois ou l'on a vu le noeud POINT_LIAISON ip
      segment icpr(nbpts)
c     ITACH=liste des chpoints, ITAFL.TAFL=liste des coefficients
      SEGMENT ITACH(0)
      SEGMENT/ITAFL/(TAFL(0)*D)
 
      CHARACTER*(LOCOMP)  mocom1
 
 
      ipout =0
      it1=0
      it2=0
      MYTAB1=0
      MYTAB2=0
 
 
************************************************************************
*     ACTIVATION DES TABLES si elles existent 
************************************************************************
c     recup des solutions statiques si la table existe
      if (itbst.gt.0) then
        mtable = itbst
        segact mtable
        segini icpr
        iicpr=icpr
c       DEBOBINAGE DE LA TABLE itbst VERS MYTAB1
        CALL TAB2MY(itbst,2,iicpr,it1)
        MYTAB1=it1
      endif
 
c     recup des modes si la table existe
      itbm2=0
      if (itbm.gt.0) then
        CALL ACCTAB(itbm,'MOT',0,0.0D0,'MODES',.TRUE.,0,
     &        'TABLE',0,0.0D0,' ',.TRUE.,itbm2)
        if (ierr.ne.0) return
        mtable = itbm2
        segact mtable
c       DEBOBINAGE DE LA TABLE itbm2 VERS MYTAB2
        CALL TAB2MY(itbm2,1,0,it2)
        MYTAB2=it2
      endif
 
************************************************************************
*     RECOMBINAISON 
************************************************************************
 
c     creation des segments pour la combinaison lineaire
      segini,ITACH,ITAFL
      NA=0
 
c     recup du chpoint d'entree (de composante ALFA BETA)
      mchpoi = ichp1
      segact mchpoi
      nsoupo = ipchp(/1)
 
c   - boucle sur les zones du chpoint d'entree
      DO 10 is = 1 ,nsoupo
 
       msoupo = ipchp(is)
       segact msoupo
       NC = NOCOMP(/2)
       meleme = igeoc
       mpoval = ipoval
       segact meleme,mpoval
       N = vpocha(/1)
 
c    - boucle sur les composantes
       DO 20 ic = 1,NC
 
        mocom1 = nocomp(ic)
        if (mocom1.eq.'BETA') then
          if(itbst.le.0) goto 20
          MYTAB=MYTAB1
        elseif (mocom1.eq.'ALFA') then
          if(itbm2.le.0) goto 20
          MYTAB=MYTAB2
        elseif (mocom1.eq.'LX') then
          write(ioimp,*) 'LX a recopier tel quel... ',
     &          'mais pas encore fait !'
          goto 20
        else
          write(ioimp,*) 'RECO : le chpoint doit avoir les composantes',
     &                   ' ALFA ou BETA !'
          MOTERR=mocom1
          call erreur(197)
          return
        endif
 
c     - boucle sur les noeuds du chpoint d'entree
        DO 90 ipn = 1,N
          ipts = num(1,ipn)
          sca1 = vpocha(ipn,ic)
 
c           on a deja enregistré tous les modes
            im=KICPR(ipts)
            if (im.le.0) then
              INTERR(1)=ipts
              CALL ERREUR(1072)
              RETURN
            endif
            ichin=KDEFO(im)  
 
c           combinaison lineaire
c             if (ipout.gt.0) then
c               ich1 = ipout
c               call adchpo(ich1,ichin,ipout,1.d0,sca1)
c             else
c               call muchpo(ichin,sca1,ipout,1)
c             endif
c           mutualisation des sources : appel a COMBIL
            ITACH(**)=ichin
            TAFL(**)=sca1
            NA=NA+1
 
 90     CONTINUE
 
 20    CONTINUE
 
       segdes msoupo,meleme,mpoval
 10   CONTINUE
      segdes mchpoi
 
c     combinaison lineaire effective optimisee
      CALL COMBIL(ITACH,ITAFL,NA,ipout)
 
      if (itbst.le.0) goto 999
 
 
************************************************************************
*     CORRECTION DU CHPOINT AUX POINTS DE LIAISON 
************************************************************************
c
c de maniere a ne pas compter plusieurs fois un noeud en commun 
c a plusieurs deformees statiques (ex. du noeud x ci dessous).
c  |---------------x x-----------------|
c        \psi_1            \psi2
c
 
      MYTAB=MYTAB1
c       ima = icpt(/1)
      ima = KPTLIA(/1)
      mchpoi = ipout
      segact mchpoi
      nsoupo = ipchp(/1)
 
      DO is = 1 ,nsoupo
        msoupo = ipchp(is)
        segact msoupo
        NC = NOCOMP(/2)
        meleme = igeoc
        mpoval = ipoval
 
        segact meleme,mpoval*mod
        N = vpocha(/1)
 
        DO ic = 1,NC
          mocom1 = nocomp(ic)
 
          DO 180 ipn = 1 , N
            ipts = num(1,ipn)
            kpt = 0
            if (icpr(ipts).eq.0) goto 180
c           on a repere un point de liaison
            do 170 im = 1,ima
              if (KPTLIA(im).ne.ipts) goto 170
              if (DDLLIA(im).ne.mocom1) goto 170
              kpt = kpt + 1
 170        continue
c           kpt=nombre de fois ou apparait point_liaison + ddl_liaison
            if (kpt.gt.1) vpocha(ipn,ic) = vpocha(ipn,ic)/kpt
 
 180      CONTINUE
 
        ENDDO
        segdes meleme,mpoval,msoupo
 
      ENDDO
      segdes mchpoi
      segsup icpr
 
 
************************************************************************
*     FIN DU PROGRAMME 
************************************************************************
 999  CONTINUE
 
      SEGSUP,ITACH,ITAFL
      IF(MYTAB1.ne.0) SEGSUP MYTAB1
      IF(MYTAB2.ne.0) SEGSUP MYTAB2
c     on ne desactive pas les 2 tables d'entrees (//isation)
 
      RETURN
      END