relr1b
C RELR1B SOURCE GOUNAND 11/05/24 21:16:00 6976 $ MINCP,KRSPGP,KRINCP, $ MEL,DES, $ PMCOU, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : RELR1B C DESCRIPTION : * construction de la correspondance : * ieme ddl dual de la matrice assemblée <-> * (numéros des ddl primaux avec lesquels il est * en relation). C'est le profil morse (non ordonné) C 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 APPELES : C APPELES (E/S) : C APPELES (BLAS) : C APPELES (CALCUL) : C APPELE PAR : RELR14 C*********************************************************************** C SYNTAXE GIBIANE : C ENTREES : C ENTREES/SORTIES : C SORTIES : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 30/06/2003, version initiale C HISTORIQUE : v1, 30/06/2003, création C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC SMRIGID POINTEUR DES.DESCR -INC SMELEME POINTEUR MEL.MELEME * Includes persos CBEGININCLUDE SMMINC SEGMENT MINC INTEGER NPOS(NPT+1) INTEGER MPOS(NPT,NBI+1) ENDSEGMENT SEGMENT IMINC INTEGER LNUPO (NDDL) INTEGER LNUINC(NDDL) ENDSEGMENT CENDINCLUDE SMMINC POINTEUR MINCP.MINC CBEGININCLUDE SMPMORS SEGMENT PMORS INTEGER IA (NTT+1) INTEGER JA (NJA) ENDSEGMENT CENDINCLUDE SMPMORS POINTEUR PMCOU.PMORS * Segment LSTIND (liste séquentielle indexée) SEGMENT LSTIND INTEGER IDX(NBM+1) INTEGER IELRIG(NBTVAL) INTEGER ILIGR (NBTVAL) ENDSEGMENT POINTEUR DDDNUL.LSTIND * -INC SMLENTI POINTEUR KRSPGP.MLENTI POINTEUR KRINCP.MLENTI POINTEUR IWORK.MLENTI POINTEUR DDDNOP.MLENTI * INTEGER IMPR,IRET * * Executable statements * IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1b.eso' NPOPRI=MINCP.NPOS(/1)-1 NDDLPR=MINCP.NPOS(NPOPRI+1)-1 SEGACT DDDNUL NDDLDU=DDDNUL.IDX(/1)-1 *a effacer NEL=MEL.NUM(/2) NDDLOP=DES.NOELEP(/1) *a effacer NDDLOD=DES.NOELED(/1) * Segment de travail JG=NDDLPR SEGINI IWORK * * Passe 1 : construction de la correspondance : * ieme ddl dual <-> nombre des ddls * primaux avec lesquels * il est en relation * DDDNOP * JG=NDDLDU SEGINI DDDNOP DO IDDLDU=1,NDDLDU LDG=0 * Fin de la liste chaînée LAST=-1 DO JDX=DDDNUL.IDX(IDDLDU), $ DDDNUL.IDX(IDDLDU+1)-1 IELEM =DDDNUL.IELRIG(JDX) * a effacer ILIGRD=DDDNUL.ILIGR(JDX) DO ILIGRP=1,NDDLOP IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM)) IINC=KRINCP.LECT(ILIGRP) IPOS=MINCP.MPOS(IPO,IINC) IF (IPOS.EQ.0) THEN WRITE(IOIMP,*) 'Erreur grave no1' GOTO 9999 ENDIF IDDLPR=MINCP.NPOS(IPO)+IPOS-1 IF (IWORK.LECT(IDDLPR).EQ.0) THEN LDG=LDG+1 IWORK.LECT(IDDLPR)=LAST LAST=IDDLPR ENDIF ENDDO ENDDO * Le nombre de points distincts trouvés est: DDDNOP.LECT(IDDLDU)=LDG * On remet la liste chaînée à 0 DO ILDG=1,LDG IPREC=IWORK.LECT(LAST) IWORK.LECT(LAST)=0 LAST=IPREC ENDDO ENDDO * * Passe 2 : construction de la correspondance : * ieme ddl dual de la matrice assemblée <-> * (numéros des ddl primaux avec lesquels il est * en relation). C'est le profil morse (non ordonné) * PMCOU * * NTT=NDDLDU NJA=0 SEGINI PMCOU IDEPA=1 DO IDDLDU=1,NDDLDU PMCOU.IA(IDDLDU)=IDEPA IDEPA=IDEPA+DDDNOP.LECT(IDDLDU) ENDDO PMCOU.IA(NDDLDU+1)=IDEPA SEGSUP DDDNOP NJA=IDEPA-1 SEGADJ PMCOU DO IDDLDU=1,NDDLDU KDX=PMCOU.IA(IDDLDU)-1 DO JDX=DDDNUL.IDX(IDDLDU), $ DDDNUL.IDX(IDDLDU+1)-1 IELEM =DDDNUL.IELRIG(JDX) * a effacer ILIGRD=DDDNUL.ILIGR(JDX) DO ILIGRP=1,NDDLOP IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM)) IINC=KRINCP.LECT(ILIGRP) IPOS=MINCP.MPOS(IPO,IINC) IF (IPOS.EQ.0) THEN WRITE(IOIMP,*) 'Erreur grave no2' GOTO 9999 ENDIF IDDLPR=MINCP.NPOS(IPO)+IPOS-1 IF (IWORK.LECT(IDDLPR).EQ.0) THEN KDX=KDX+1 PMCOU.JA(KDX)=IDDLPR IWORK.LECT(IDDLPR)=KDX ENDIF ENDDO ENDDO * On remet le segment de travail a zero DO KDX=PMCOU.IA(IDDLDU),PMCOU.IA(IDDLDU+1)-1 IWORK.LECT(PMCOU.JA(KDX))=0 ENDDO ENDDO SEGDES PMCOU SEGSUP IWORK SEGDES DDDNUL * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine relr1b' RETURN * * End of subroutine RELR1B * END
© Cast3M 2003 - Tous droits réservés.
Mentions légales