Esope source files

   1 : C XPXTRA    SOURCE    AM        10/11/23    21:15:01     6797           
   2 :       SUBROUTINE XPXTRA
   3 : C
   4 : C     CREATION DE LA RIGIDITE OBTENU PAR MULTIPLICATION TENSORIELLE
   5 : C              (PONDEREE) DE DEUX CHPOINT ELEMENTAIRES
   6 : C
   7 :       IMPLICIT INTEGER(I-N)
   8 :       IMPLICIT REAL*8 (A-H,O-Z)
   9 : -INC CCOPTIO
  10 : -INC SMRIGID
  11 : -INC SMCHPOI
  12 : -INC SMELEME
  13 : -INC CCHAMP
  14 : C
  15 :       SEGMENT,ITRAV1
  16 :         CHARACTER*4 NDCOMP(NC)
  17 :       ENDSEGMENT
  18 : C
  19 : C     LECTURE D'UN CHPOINT
  20 : C
  20 :       CALL LIROBJ('CHPOINT',MCHPOI,1,IRETOU)
  21 :       IF(IERR.NE.0)RETURN
  22 : C
  23 : C     LECTURE EVENTUELLE D'UN REEL
  24 : C
  24 :       CALL LIRREE(FLO,0,IRETOU)
  25 :       IF(IRETOU.EQ.0)FLO=1.D0
  26 : C
  27 : C     VERIFICATION DU CARACTERE ELEMENTAIRE DU CHPOINT,
  28 : C     SANS SERIE DE FOURIER
  29 : C
  30 :       SEGACT,MCHPOI
  31 :       IF(IPCHP(/1).NE.1)THEN
  32 :         WRITE(IOIMP,*)'XXT: the CHPO should be elementar'
  33 :         GOTO 9999
  34 :       ENDIF
  35 :       IF(IFOPOI.EQ.1)THEN
  36 :         WRITE(IOIMP,*)'XXT: the CHPO should not be FOURIER'
  37 :         GOTO 9999
  38 :       ENDIF
  39 : C
  40 : C     ACTIVATIONS DIVERSES 
  41 : C
  42 :       MSOUPO=IPCHP(1)
  43 :       SEGACT,MSOUPO
  44 :       IPT1=IGEOC
  45 :       MPOVAL=IPOVAL
  46 :       SEGACT,IPT1,MPOVAL
  47 : C
  48 : C     NOM DES COMPOSANTES DE DEPLACEMENTS
  49 : C
  50 :       NC=NOHARM(/1)
  51 :       SEGINI,ITRAV1
  52 :       DO IE1=1,NC
  52 :         CALL PLACE(NOMDU,LNOMDD,IMOT,NOCOMP(IE1))
  53 :         IF(IMOT.EQ.0)THEN
  54 :           WRITE(IOIMP,*)'XXT: one component of the CHPOIN is not'
  55 :           WRITE(IOIMP,*)'        a force'
  56 :           GOTO 9998
  57 :         ENDIF
  58 :         NDCOMP(IE1)=NOMDD(IMOT)
  59 :       ENDDO
  60 : C
  61 : C     CREATION DU SUPERELEMENT ET DESACTIVATION DU MAILLAGE
  62 : C
  63 :       NBSOUS=0
  64 :       NBELEM=1
  65 :       NBNN=IPT1.ICOLOR(/1)
  66 :       NBREF=0
  67 :       SEGINI,MELEME
  68 :       ITYPEL=28
  69 :       DO IE1=1,NBNN
  70 :         NUM(IE1,1)=IPT1.NUM(1,IE1)
  71 :       ENDDO
  72 :       ICOLOR(1)=IPT1.ICOLOR(1)
  73 :       SEGDES,IPT1,MELEME
  74 : C
  75 : C     DECRIPTEUR POUR LA RIGIDITE
  76 : C
  77 :       NLIGRP=NC*NBNN
  78 :       NLIGRD=NLIGRP
  79 :       SEGINI,DESCR
  80 :       DO IE1=1,NBNN
  81 :         IDUM=(IE1-1)*NC
  82 :         DO IE2=1,NC
  83 :           LISINC(IDUM+IE2)=NDCOMP(IE2)
  84 :           LISDUA(IDUM+IE2)=NOCOMP(IE2)
  85 :           NOELEP(IDUM+IE2)=IE1
  86 :           NOELED(IDUM+IE2)=IE1
  87 :         ENDDO
  88 :       ENDDO
  89 :       SEGDES,DESCR,MSOUPO
  90 :       SEGSUP,ITRAV1
  91 : C
  92 : C     CONTENU DE LA RIGIDITE
  93 : C
  94 :       nelrig=1
  95 :       SEGINI,XMATRI
  96 :       DO IE1=1,NLIGRP
  97 :         DO IE2=1,NLIGRP
  98 :           RE(IE1,IE2,1)=VPOCHA((IE1+NC-1)/NC,MOD(IE1+NC-1,NC)+1)
  99 :      >               *VPOCHA((IE2+NC-1)/NC,MOD(IE2+NC-1,NC)+1)
 100 :         ENDDO
 101 :       ENDDO
 102 :       SEGDES,XMATRI,MPOVAL
 103 : *      NELRIG=1
 104 : *      SEGINI,IMATRI
 105 : *      IMATTT(1)=XMATRI
 106 : *      SEGDES,IMATRI
 107 : C
 108 : C     CHAPEAU MRIGID DE LA RIGIDITE
 109 : C
 110 :       NRIGEL=1
 111 :       NRIGE=7
 112 :       SEGINI,MRIGID
 113 :       MTYMAT='RIGIDITE'
 114 :       COERIG(1)=FLO
 115 :       IRIGEL(1,1)=MELEME
 116 :       IRIGEL(2,1)=0
 117 :       IRIGEL(3,1)=DESCR
 118 :       IRIGEL(4,1)=xMATRI
 119 :       IRIGEL(5,1)=0
 120 :       IRIGEL(6,1)=0
 121 :       IRIGEL(7,1)=0
 122 :       ICHOLE=0
 123 :       IMGEO1=0
 124 :       IMGEO2=0
 125 :       IFORIG=IFOPOI
 126 :       ISUPEG=0
 127 :       SEGDES,MRIGID,MCHPOI
 128 : C
 129 : C     RETOUR A GIBIANE
 130 : C
 130 :       CALL ECROBJ('RIGIDITE',MRIGID)
 131 :       RETURN 
 132 : C
 133 : C     ERREURS
 134 : C
 135 :  9998 SEGSUP,ITRAV1
 136 :       SEGDES,IPT1,MPOVAL,MSOUPO
 137 :  9999 SEGDES,MCHPOI
 138 :       RETURN
 139 :       END
 140 :  
 141 :  
 142 :  
 143 :  
 144 :  
 145 :  
 146 :  
 147 :  
 148 :  
 149 :