C KRES9 SOURCE PV 20/09/26 21:18:24 10724 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' * 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) ENDIF IF(IIMPI.EQ.1)WRITE(IOIMP,10) 10 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT ASNS1 ') 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 ASNS1(MRIGID,MMATRX,INUINX,ITOPOX,IMINIX,IPOX,INCTRX,INCTRZ, & IITOPX,ITOPOD,IITOPD,IPODD) IF(IERR.NE.0) RETURN IF(IIMPI.EQ.1) THEN CALL GIBTEM(XKT) INTERR(1)=INT(XKT) CALL ERREUR(-259) ENDIF IF(IIMPI.EQ.1)WRITE(IOIMP,11) 11 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LDMT2') 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,IITOPD,ITOPOD,IPODD,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,IITOPD,ITOPOD,IPODD,njtot,INORMU) IF(IERR.NE.0) RETURN IF(IIMPI.EQ.1)THEN CALL GIBTEM(XKT) INTERR(1)=INT(XKT) CALL ERREUR(-259) ENDIF IF(IIMPI.EQ.1) WRITE(IOIMP,12) 12 FORMAT(' L''IMPRESSION PRECEDENTE EST AVANT LA FIN DE KRES9') 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