Sources Esope | Cast3M

combt1
C COMBT1    SOURCE    CB215821  20/11/25    13:21:47     10792          
      SUBROUTINE COMBT1 (IPCHP1,IPTABL,COMBIN,IPCHP2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
************************************************************************
*
*                             C O M B T 1
*                             -----------
*
* FONCTION:
* ---------
*
*     EFFECTUER LA COMBINAISON LINEAIRE DE CHPOINTS CONSIGNES DANS UNE
*     TABLE, INDICES PAR DES POINTS.
*
* MODE D'APPEL:
* -------------
*
*     CALL COMBT1 (IPCHP1,IPTABL,COMBIN,IPCHP2)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPCHP1  ENTIER    (E)  POINTEUR SUR LE CHPOINT DES COEFFICIENTS DE
*                            PONDERATION (VOIR LE SOUS-PROGRAMME
*                            "COMBTA" OU L'OPERATEUR "COMBTABLE" POUR LE
*                            DETAIL DE SON CONTENU).
*     IPTABL  ENTIER    (E)  POINTEUR SUR LA TABLE DES CHPOINTS.
*     COMBIN  SUBROUT.  (E)  SOUS-PROGRAMME DE COMBINAISON LINEAIRE DE
*                            2 CHPOINTS. 5 ARGUMENTS:
*                            - CHPOINT N.1 ,
*                            - REEL D.P. N.1 ,
*                            - CHPOINT N.2 ,
*                            - REEL D.P. N.2 ,
*                            - CHPOINT COMBINAISON LINEAIRE.
*     IPCHP2  ENTIER    (S)  POINTEUR SUR LE CHPOINT COMBINE.
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     30 MAI 1985
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS.
*
************************************************************************
*
 
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMELEME
-INC SMTABLE
-INC SMVECTD
*
      LOGICAL FIRST,LBID
      CHARACTER*1 CBID
      EXTERNAL COMBIN
*
*
 
      FIRST = .TRUE.
      MCHPOI = IPCHP1
      SEGACT,MCHPOI
*
      NSOUPO = IPCHP(/1)
      DO 100 IB100=1,NSOUPO
*
         MSOUPO = IPCHP(IB100)
         SEGACT,MSOUPO
         NC = NOCOMP(/2)
         IF (NC .NE. 1) THEN
*           LE CHPOINT DES COEFFICIENTS DE PONDERATION A PLUSIEURS
*           COMPOSANTES: ON NE SAIT PAS QUOI EN FAIRE.
            NUMERR = 180
            CALL ERREUR (NUMERR)
            RETURN
         END IF
*
         MELEME = IGEOC
         SEGACT,MELEME
         NBNN = NUM(/1)
         IF (NBNN .NE. 1) THEN
*           ON NE COMPREND PAS QUE L'OBJET "MAILLAGE" NE CONTIENNE PAS
*           DES ELEMENTS A 1 SEUL NOEUD.
            MOTERR(1:8) = '"COMBT1"'
            NUMERR = 224
            CALL ERREUR (NUMERR)
            RETURN
         END IF
*
         MPOVAL = IPOVAL
         SEGACT,MPOVAL
         NBPOIN = VPOCHA(/1)
         NBELEM = NUM(/2)
         IF (NBPOIN .NE. NBELEM) THEN
*           TYPE DE RELATION ENTRE LE 'CHPOINT' ET SON SUPPORT INCOMPRIS
            MOTERR(1:8) = '"COMBT1"'
            NUMERR = 224
            CALL ERREUR (NUMERR)
            RETURN
         END IF
*
         mtable=iptabl
         segact mtable,mtab1
         DO 110 IB110=1,NBPOIN
            INDICE = NUM(1,IB110)
            do iou=1,mlotab
              if(mtabii(iou).eq.indice) go to 32
            enddo
            call erreur(5)
   32       continue
            ipchp3=mtabiv(iou)
            mvect1= mtab1.mtabiv(iou)
            INDICE = NUM(1,IB110)
               write(6,*) ib110 ,'ieme point numero ' , indice
*            CALL ACCTAB (IPTABL,'POINT',IBID,XBID,CBID,LBID,INDICE
*     &            ,'CHPOINT',IBID,XBID,CBID,LBID,IPCHP3)
*            IF (IERR .NE. 0) RETURN
*           segact mvect1
            COEFF3 = VPOCHA(IB110,1)
            IF (FIRST) THEN
                inc=mvect1.vectbb(/1)
                segini,mvect3
               do iau=1,mvect1.vectbb(/1)
                  mvect3.vectbb(iau)=mvect1.vectbb(iau)*coeff3
               enddo
               FIRST = .FALSE.
*               MULTPL = 1
*               CALL MUCHPO (IPCHP3,COEFF3,  IPCHP2,MULTPL)
*               IF (IERR .NE. 0) RETURN
            ELSE
               do iau=1,inc
                 mvect3.vectbb(iau)=mvect3.vectbb(iau)+
     $                              coeff3*mvect1.vectbb(iau)
               enddo
 
*               COEFF2 = 1.D0
*               CALL COMBIN (IPCHP2,COEFF2,IPCHP3,COEFF3,  IPCHP9)
*               IF (IERR .NE. 0) RETURN
*               CALL DTCHPO (IPCHP2)
*               IPCHP2 = IPCHP9
            END IF
*
  110       CONTINUE
***      call crech2(ipchp2,mvect3,mvecri,1)
***      segsup mvect3
         segdes mtable,mtab1
*        END DO
*
         SEGDES,MELEME
         SEGDES,MPOVAL
         SEGDES,MSOUPO
*
  100    CONTINUE
*     END DO
*
      SEGDES,MCHPOI
*
      END