Sources Esope | Cast3M

prlimi
C PRLIMI    SOURCE    CB215821  20/11/25    13:37:01     10792          
C PRLIMI    SOURCE
      SUBROUTINE PRLIMI(CALDYN,IG,ITAB,IFIC1,IRIG,NMOD,IMAI,NNO,IFIC2)
C
C=======================================================================
C      POUR MISS3D : ECRITURE DES MODES SUR FICHIER .chp
C                      ET DU MAILLAGE SUR FICHIER .mail
C
C     Appelle par l'operateur MISE
C=======================================================================
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
      LOGICAL CALDYN
-INC SMTABLE
-INC SMCOORD
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCHPOI
C
      CHARACTER*8 ITYPE
      CHARACTER*72 LEMOT
      PARAMETER (ZERO=0.D0)
      INTEGER ICMP(3)
      INTEGER KN(8)
      DATA KN /0,0,0,0,0,0,0,0/
C
      IF(CALDYN)THEN
C
C Ecriture pour les vrais modes
        WRITE(IFIC1,*)'GROUP 2'
        WRITE(IFIC1,*)'MODE',NMOD
        DO 20 I=1,NMOD
          WRITE(IFIC1,*)'TOUS 0 0 0'
          WRITE(IFIC1,*)'FIN'
  20    CONTINUE
C
C Ecriture des modes statiques
        WRITE(IFIC1,*)'GROUP 1 2'
        MTABLE=ABS(ITAB)
        SEGACT MTABLE
        NB=MLOTAB
        WRITE(IFIC1,*)'MODE',NB-1
 
        IF(IRIG.EQ.1)THEN
C
C Fondation souple, on n'ecrit que le DDL concerne pour chaque mode
          NBP=(NB-1)/3
 
          DO 10 IJ=1,NB
            ITYPE=MTABTI(IJ)
            IF(ITYPE.EQ.'ENTIER')THEN
              IRET=MTABII(IJ)
              MTAB1=MTABIV(IJ)
              CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'POINT_LIAISON',.TRUE.,0,
     &        'POINT',IP,RR,LEMOT,.TRUE.,IPOIN)
              CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DDL_LIAISON',.TRUE.,0,
     &        'MOT',IP,RR,LEMOT,.TRUE.,IZ)
              CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'VALEUR_DDL',.TRUE.,0,
     &        'FLOTTANT',IP,VAL,LEMOT,.TRUE.,IZ)
              IF (VAL.EQ.00013081984) THEN
                CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
     &          'CHPOINT',IP,RR,LEMOT,.TRUE.,JCHP1)
                MCHPOI=JCHP1
                SEGACT MCHPOI
                NSOU=IPCHP(/1)
                DO 71 ISOU=1,NSOU
                  MSOUPO=IPCHP(ISOU)
                  SEGACT MSOUPO
                  IF(NOCOMP(1).EQ.'LX  ')THEN
                      SEGDES MSOUPO
                      GOTO 71
                  ENDIF
                  IPT1=IGEOC
                  SEGACT IPT1
                  NBP=IPT1.NUM(/2)
                  MPOVAL=IPOVAL
                  SEGACT MPOVAL
C
C On ordonne les composantes UX, UY et UZ car bizarrement c'est pas toujours dans l'ordre !
                  NBCOMP=VPOCHA(/2)
                  DO ICOMP=1,NBCOMP
                    IF(NOCOMP(ICOMP).EQ.'UX  ')THEN
                      ICMP(1)=ICOMP
                    ELSEIF(NOCOMP(ICOMP).EQ.'UY  ')THEN
                      ICMP(2)=ICOMP
                    ELSEIF(NOCOMP(ICOMP).EQ.'UZ  ')THEN
                      ICMP(3)=ICOMP
                    ENDIF
                  ENDDO
                  DO 72 IN=1,NBP
                    IPOIN=IPT1.NUM(1,IN)
                    WRITE(IFIC1,110)IPOIN,(VPOCHA(IN,ICMP(IC)),IC=1,3)
 72               CONTINUE
                  SEGDES MPOVAL
                  SEGDES MSOUPO
                  SEGDES IPT1
 71             CONTINUE
                WRITE(IFIC1,*)'FIN'
                SEGDES MCHPOI
              ELSE
C
                IF(LEMOT(1:2).EQ.'UX')THEN
                  WRITE(IFIC1,110)IPOIN,VAL,ZERO,ZERO
                ELSEIF(LEMOT(1:2).EQ.'UY')THEN
                  WRITE(IFIC1,110)IPOIN,ZERO,VAL,ZERO
                ELSE
                  WRITE(IFIC1,110)IPOIN,ZERO,ZERO,VAL
                ENDIF
110             FORMAT(I7,3(1X,E15.6))
                WRITE(IFIC1,*)'FIN'
              ENDIF
            ENDIF
 10       CONTINUE
        ELSE
C
C Fondation rigide, on ecrit tous les ddl pour chaque mode
          DO 60 IJ=1,NB
            ITYPE=MTABTI(IJ)
            IF(ITYPE.EQ.'ENTIER')THEN
              IRET=MTABII(IJ)
              MTAB1=MTABIV(IJ)
              CALL ACCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE',.TRUE.,0,
     &        'CHPOINT',IP,RR,LEMOT,.TRUE.,JCHP1)
              MCHPOI=JCHP1
              SEGACT MCHPOI
              NSOU=IPCHP(/1)
              DO 61 ISOU=1,NSOU
                MSOUPO=IPCHP(ISOU)
                SEGACT MSOUPO
                IF(NOCOMP(1).EQ.'LX  ')THEN
                    SEGDES MSOUPO
                    GOTO 61
                ENDIF
                IPT1=IGEOC
                SEGACT IPT1
                NBP=IPT1.NUM(/2)
                MPOVAL=IPOVAL
                SEGACT MPOVAL
C
C On ordonne les composantes UX, UY et UZ car bizarrement c'est pas toujours dans l'ordre !
                NBCOMP=VPOCHA(/2)
                DO ICOMP=1,NBCOMP
                  IF(NOCOMP(ICOMP).EQ.'UX  ')THEN
                    ICMP(1)=ICOMP
                  ELSEIF(NOCOMP(ICOMP).EQ.'UY  ')THEN
                    ICMP(2)=ICOMP
                  ELSEIF(NOCOMP(ICOMP).EQ.'UZ  ')THEN
                    ICMP(3)=ICOMP
                  ENDIF
                ENDDO
                DO 62 IN=1,NBP
                  IPOIN=IPT1.NUM(1,IN)
                  WRITE(IFIC1,110)IPOIN,(VPOCHA(IN,ICMP(IC)),IC=1,3)
 62             CONTINUE
                SEGDES MPOVAL
                SEGDES MSOUPO
                SEGDES IPT1
 61           CONTINUE
              WRITE(IFIC1,*)'FIN'
              SEGDES MCHPOI
            ENDIF
 60       CONTINUE
        ENDIF
        SEGDES MTABLE
      ELSE
        ID=(IDIM+1)*(IG-1)
        WRITE(IFIC1,*)'GROUP 1'
        WRITE(IFIC1,*)'RIGIDE',XCOOR(ID+1),XCOOR(ID+2),XCOOR(ID+3)
      ENDIF
C
C Ecriture maillage
      MELEME=IMAI
      SEGACT MELEME
      NBEL=NUM(/2)
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.NE.0)STOP 'Plusieurs sous maillages'
C
C coordonnees
      NNOT=nbpts
C      WRITE(IFIC2,310)NNOT,NBEL
      WRITE(IFIC2,310)NNO,NBEL
310   FORMAT('Maillage interface',/,I5,I5,/,'LIBRE')
C      DO 40 IP=1,NNOT
      DO 40 IP=1,NNO
        WRITE(IFIC2,320)(XCOOR((IP-1)*4+K),K=1,3)
320     FORMAT(3(1X,E15.6))
 40   CONTINUE
C
C connectivite maillage interface
cccc????      SEGACT MCOORD
C
      NBN=NUM(/1)
      DO 50 IE=1,NBEL
        IF(NBN.EQ.4)THEN
          KN(1)=NUM(1,IE)
          KN(3)=NUM(2,IE)
          KN(5)=NUM(3,IE)
          KN(7)=NUM(4,IE)
        ELSEIF(NBN.EQ.3)THEN
          KN(1)=NUM(1,IE)
          KN(3)=NUM(2,IE)
          KN(5)=NUM(3,IE)
        ELSE
          WRITE(IOIMP,*) 'Nombre de noeuds par element : ',NBN
          STOP 'pas encore fait dans prlimi.eso'
        ENDIF
        WRITE(IFIC2,330)(KN(K),K=1,8)
330     FORMAT(8I7,' GR 1')
C
 50   CONTINUE
C
      SEGDES MELEME
C
      RETURN
      END