Télécharger kres9.eso

Retour à la liste

kres9
C KRES9     SOURCE    MB234859  26/07/31    21:15:02     12613          
      SUBROUTINE KRES9(MRIGID,INORMU)
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
C***********************************************************************
C NOM         : KRES9
C DESCRIPTION : - Assemblage comme par RESOU
C
C
C LANGAGE     : ESOPE
C AUTEUR      : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF)
C               mél : gounand@semt2.smts.cea.fr
C***********************************************************************
C VERSION    : v1, 04/08/2011, version initiale
C HISTORIQUE : v1, 04/08/2011, création
C HISTORIQUE : JCARDO 16/07/2013, ajout de INORMU (cf LDMT2)
C HISTORIQUE :
C***********************************************************************
      REAL*8 XKT,PREC
-INC SMRIGID
-INC SMMATRI
 
-INC PPARAM
-INC CCOPTIO
C ... Ces variables ont pour but, de diriger le comportement de LDMT2 ...
C       TRSUP  - TRiangle SUPérieur
C       MENAGE - évident
C       LDIAG  - initialisation et remplissage de MDIAG et MDNOR demandés
C
      LOGICAL TRSUP,MENAGE,LDIAG
*
* Executable statements
*
*      WRITE(IOIMP,*) 'Entrée dans kres8.eso'
*
      INSYM=1
*
      SEGACT MRIGID
      ICHOLX=ICHOLE
      SEGDES MRIGID
      IF (ICHOLX.NE.0) RETURN
* Ici l'assemblage proprement dit recopié de LDMT1
      IF (IIMPI.EQ.1)THEN
        CALL GIBTEM(XKT)
        INTERR(1)=INT(XKT)
        CALL ERREUR(-259)
        WRITE(IOIMP,10)
 10     FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT ASSEM1')
      ENDIF
 
C ... MMATRI est initialisé dans ASSEM1 et renvoyé en tant que résultat
C     dans la variable MMATRX, il est désactivé à la sortie ...
      CALL ASSEM1(MRIGID,INSYM,MMATRX,INUINX,
     &            ITOPOX,IPOX,IITOPX,INCTRX,
     &            ITOPOZ,IPOZ,IITOPZ,INCTRZ)
      IF(IERR.NE.0) RETURN
 
      IF (IIMPI.EQ.1) THEN
        CALL GIBTEM(XKT)
        INTERR(1)=INT(XKT)
        CALL ERREUR(-259)
        WRITE(IOIMP,11)
 11     FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LDMT2')
      ENDIF
C ... On initialise IJMAX ici et non dans LDMT2, car celui-ci est
C     appelé deux fois ...
      MMATRI=MMATRX
      SEGACT,MMATRI*MOD
      IJMAX=0
      SEGDES,MMATRI
C
      TRSUP =.FALSE.
      MENAGE=.FALSE.
      LDIAG =.TRUE.
      njtot=0
*      write(6,*) ' premier appel'
      CALL LDMT2(MRIGID,ITOPOX,INUINX,IMINIX,MMATRX,IPOX,INCTRX,INCTRZ,
     &     IITOPX,TRSUP,MENAGE,LDIAG,IITOPZ,ITOPOZ,IPOZ,njtot,INORMU)
      IF(IERR.NE.0) RETURN
      TRSUP =.TRUE.
      MENAGE=.TRUE.
      LDIAG =.FALSE.
*      write(6,*) ' deucxieme appel'
      CALL LDMT2(MRIGID,ITOPOX,INUINX,IMINIX,MMATRX,IPOX,INCTRX,INCTRZ,
     &     IITOPX,TRSUP,MENAGE,LDIAG,IITOPZ,ITOPOZ,IPOZ,njtot,INORMU)
      IF(IERR.NE.0) RETURN
 
      IF (IIMPI.EQ.1)THEN
        CALL GIBTEM(XKT)
        INTERR(1)=INT(XKT)
        CALL ERREUR(-259)
        WRITE(IOIMP,12)
 12     FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LA FIN DE KRES9')
      ENDIF
      IF(IERR.NE.0) RETURN
*
* Analyse de la structure
*
C      MMATRI=MMATRX
C      SEGACT MMATRI
C      WRITE(IOIMP,*) 'IJMAX=',IJMAX
C      WRITE(IOIMP,*) 'IDIAG=',IDIAG
C      WRITE(IOIMP,*) 'IGEOMA=',IGEOMA
C      WRITE(IOIMP,*) 'IINCPO=',IINCPO
C      WRITE(IOIMP,*) 'IIDUA=',IIDUA
C      WRITE(IOIMP,*) 'IIMIK=',IIMIK
C      WRITE(IOIMP,*) 'INEG=',INEG
C      WRITE(IOIMP,*) 'IDNORM=',IDNORM
C      WRITE(IOIMP,*) 'IILIGN=',IILIGN
C      WRITE(IOIMP,*) 'IILIGS=',IILIGS
C      WRITE(IOIMP,*) 'NENS=',NENS
C      WRITE(IOIMP,*) 'IHARK=',IHARK
C      WRITE(IOIMP,*) 'IASLIG=',IASLIG
C      WRITE(IOIMP,*) 'IASDIA=',IASDIA
C      WRITE(IOIMP,*) 'IDUAPO=',IDUAPO
C      WRITE(IOIMP,*) 'IHARDU=',IHARDU
C      WRITE(IOIMP,*) 'IDNORD=',IDNORD
C      WRITE(IOIMP,*) 'PRCHLV=',PRCHLV
C*      SEGPRT,MMATRI
C      IF (IGEOMA.NE.0) THEN
C         MELEME=IGEOMA
C         WRITE(IOIMP,*) 'IGEOMA'
C         CALL ECMAIL(MELEME,0)
C      ENDIF
C      IF (IIMIK.NE.0) THEN
C         MIMIK=IIMIK
C         SEGACT MIMIK
C         N=IMIK(/2)
C         WRITE(IOIMP,*) 'IIMIK  N=',N
C         WRITE(IOIMP,2019) (IMIK(I),I=1,N)
C      ENDIF
C      IF (IIDUA.NE.0) THEN
C         MIDUA=IIDUA
C         SEGACT MIDUA
C         N=IDUA(/2)
C         WRITE(IOIMP,*) 'IIDUA  N=',N
C         WRITE(IOIMP,2019) (IDUA(I),I=1,N)
C      ENDIF
C      IF (IINCPO.NE.0) THEN
C         MINCPO=IINCPO
C         SEGACT MINCPO
C         MAXI=INCPO(/1)
C         NNOE=INCPO(/2)
C         WRITE(IOIMP,*) 'IINCPO  MAXI=',MAXI,'  NNOE=',NNOE
C         WRITE(IOIMP,*) 'Tableau de correspondance Inconnue-Point'
C     $        ,'-> DDL'
C         DO 146 L=1,MAXI,10
C            WRITE(IOIMP,'(8X,A)') 'Inconnue'
C            LH = MIN(L+9,MAXI)
C            WRITE(IOIMP,*)  'LH=',LH
C            WRITE (IOIMP,147) 'Point',(M,M=L,LH)
C 147        FORMAT (A8,10I8)
C            DO 148 J=1,NNOE
C               WRITE(IOIMP,149) J,(INCPO(K,J),K=L,LH)
C 149           FORMAT (11I8)
C 148        CONTINUE
C 146     CONTINUE
C      ENDIF
C      IF (IDUAPO.NE.0) THEN
C         MINCPO=IDUAPO
C         SEGACT MINCPO
C         MAXI=INCPO(/1)
C         NNOE=INCPO(/2)
C         WRITE(IOIMP,*) 'IDUAPO  MAXI=',MAXI,'  NNOE=',NNOE
C         WRITE(IOIMP,*) 'Tableau de correspondance Inconnue-Point'
C     $        ,'-> DDL'
C         DO 246 L=1,MAXI,10
C            WRITE(IOIMP,'(8X,A)') 'Inconnue'
C            LH = MIN(L+9,MAXI)
C            WRITE (IOIMP,247) 'Point',(M,M=L,LH)
C 247        FORMAT (A8,10I8)
C            DO 248 J=1,NNOE
C               WRITE(IOIMP,249) J,(INCPO(K,J),K=L,LH)
C 249           FORMAT (11I8)
C 248        CONTINUE
C 246     CONTINUE
C      ENDIF
C      IF (IDIAG.NE.0) THEN
C         MDIAG=IDIAG
C         SEGACT MDIAG
C         WRITE(IOIMP,*) 'IDIAG  INC=',DIAG(/1)
C         WRITE(IOIMP,2022) (DIAG(II),II=1,DIAG(/1))
C      ENDIF
C      IF (IDNORM.NE.0) THEN
C         MDNOR=IDNORM
C         SEGACT MDNOR
C         WRITE(IOIMP,*) 'IDNORM  INC=',DNOR(/1)
C         WRITE(IOIMP,2022) (DNOR(II),II=1,DNOR(/1))
C      ENDIF
C      IF (IDNORD.NE.0) THEN
C         MDNOR=IDNORD
C         SEGACT MDNOR
C         WRITE(IOIMP,*) 'IDNORD  INC=',DNOR(/1)
C         WRITE(IOIMP,2022) (DNOR(II),II=1,DNOR(/1))
C      ENDIF
C      IF (IILIGN.NE.0) THEN
C         MILIGN=IILIGN
C         SEGACT MILIGN
C         WRITE(IOIMP,*) 'IILIGN  INC=',IPNO(/1),'  NNOE=',ILIGN(/1)
C         WRITE(IOIMP,*) '   IPNO'
C         WRITE(IOIMP,2020) (IPNO(II),II=1,IPNO(/1))
C         WRITE(IOIMP,*) '   ITTR'
C         WRITE(IOIMP,2020) (ITTR(II),II=1,ITTR(/1))
C         DO INOE=1,ILIGN(/1)
C            WRITE(IOIMP,*) '   Point ', INOE
C            LLIGN=ILIGN(INOE)
C            SEGACT LLIGN
C            WRITE(IOIMP,*) '   LLIGN  NA=',IMMMM(/1),'  LLVVA=',XXVA(/1)
C            WRITE(IOIMP,*) '          NJMAX=',NJMAX
C            WRITE(IOIMP,*) '     IMMMM'
C            WRITE(IOIMP,2020) (IMMMM(II),II=1,IMMMM(/1))
C            WRITE(IOIMP,*) '     LDEB'
C            WRITE(IOIMP,2020) (LDEB(II),II=1,LDEB(/1))
C            WRITE(IOIMP,*) '     IPPO'
C            WRITE(IOIMP,2020) (IPPO(II),II=1,IPPO(/1))
C            WRITE(IOIMP,*) '     LINC'
C            WRITE(IOIMP,2020) (LINC(II),II=1,LINC(/1))
C            WRITE(IOIMP,*) '     XXVA'
C            WRITE(IOIMP,2022) (XXVA(II),II=1,XXVA(/1))
C         ENDDO
C      ENDIF
C      IF (IILIGS.NE.0) THEN
C         MILIGN=IILIGS
C         SEGACT MILIGN
C         WRITE(IOIMP,*) 'IILIGS  INC=',IPNO(/1),'  NNOE=',ILIGN(/1)
C         WRITE(IOIMP,*) '   IPNO'
C         WRITE(IOIMP,2020) (IPNO(II),II=1,IPNO(/1))
C         WRITE(IOIMP,*) '   ITTR'
C         WRITE(IOIMP,2020) (ITTR(II),II=1,ITTR(/1))
C         DO INOE=1,ILIGN(/1)
C            WRITE(IOIMP,*) '   Point ', INOE
C            LLIGN=ILIGN(INOE)
C            SEGACT LLIGN
C            WRITE(IOIMP,*) '   LLIGN  NA=',IMMMM(/1),'  LLVVA=',XXVA(/1)
C            WRITE(IOIMP,*) '          NJMAX=',NJMAX
C            WRITE(IOIMP,*) '     IMMMM'
C            WRITE(IOIMP,2020) (IMMMM(II),II=1,IMMMM(/1))
C            WRITE(IOIMP,*) '     LDEB'
C            WRITE(IOIMP,2020) (LDEB(II),II=1,LDEB(/1))
C            WRITE(IOIMP,*) '     IPPO'
C            WRITE(IOIMP,2020) (IPPO(II),II=1,IPPO(/1))
C            WRITE(IOIMP,*) '     LINC'
C            WRITE(IOIMP,2020) (LINC(II),II=1,LINC(/1))
C            WRITE(IOIMP,*) '     XXVA'
C            WRITE(IOIMP,2022) (XXVA(II),II=1,XXVA(/1))
C         ENDDO
C      ENDIF
C 2019 FORMAT (20(2X,A4) )
C 2020 FORMAT (20(2X,I4) )
C 2021 FORMAT (20(2X,L4) )
C 2022 FORMAT(10(1X,1PG12.5))
      SEGACT MRIGID*MOD
      ICHOLE=MMATRX
      SEGDES MRIGID
      RETURN
*
* End of subroutine KRES9
*
      END
 
 

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