1 : C RELR1B SOURCE GOUNAND 11/05/24 21:16:00 6976 2 : SUBROUTINE RELR1B(DDDNUL, 3 : $ MINCP,KRSPGP,KRINCP, 4 : $ MEL,DES, 5 : $ PMCOU, 6 : $ IMPR,IRET) 7 : IMPLICIT REAL*8 (A-H,O-Z) 8 : IMPLICIT INTEGER (I-N) 9 : C*********************************************************************** 10 : C NOM : RELR1B 11 : C DESCRIPTION : 12 : * construction de la correspondance : 13 : * ieme ddl dual de la matrice assemblée <-> 14 : * (numéros des ddl primaux avec lesquels il est 15 : * en relation). C'est le profil morse (non ordonné) 16 : C 17 : C 18 : C 19 : C LANGAGE : ESOPE 20 : C AUTEUR : Stéphane GOUNAND (CEA/DEN/DM2S/SFME/LTMF) 21 : C mél : gounand@semt2.smts.cea.fr 22 : C*********************************************************************** 23 : C APPELES : 24 : C APPELES (E/S) : 25 : C APPELES (BLAS) : 26 : C APPELES (CALCUL) : 27 : C APPELE PAR : RELR14 28 : C*********************************************************************** 29 : C SYNTAXE GIBIANE : 30 : C ENTREES : 31 : C ENTREES/SORTIES : 32 : C SORTIES : 33 : C CODE RETOUR (IRET) : = 0 si tout s'est bien passé 34 : C*********************************************************************** 35 : C VERSION : v1, 30/06/2003, version initiale 36 : C HISTORIQUE : v1, 30/06/2003, création 37 : C HISTORIQUE : 38 : C HISTORIQUE : 39 : C*********************************************************************** 40 : C Prière de PRENDRE LE TEMPS de compléter les commentaires 41 : C en cas de modification de ce sous-programme afin de faciliter 42 : C la maintenance ! 43 : C*********************************************************************** 44 : -INC CCOPTIO 45 : -INC SMRIGID 46 : POINTEUR DES.DESCR 47 : -INC SMELEME 48 : POINTEUR MEL.MELEME 49 : * Includes persos 50 : CBEGININCLUDE SMMINC 51 : SEGMENT MINC 52 : INTEGER NPOS(NPT+1) 53 : INTEGER MPOS(NPT,NBI+1) 54 : ENDSEGMENT 55 : SEGMENT IMINC 56 : INTEGER LNUPO (NDDL) 57 : INTEGER LNUINC(NDDL) 58 : ENDSEGMENT 59 : CENDINCLUDE SMMINC 60 : POINTEUR MINCP.MINC 61 : CBEGININCLUDE SMPMORS 62 : SEGMENT PMORS 63 : INTEGER IA (NTT+1) 64 : INTEGER JA (NJA) 65 : ENDSEGMENT 66 : CENDINCLUDE SMPMORS 67 : POINTEUR PMCOU.PMORS 68 : * Segment LSTIND (liste séquentielle indexée) 69 : SEGMENT LSTIND 70 : INTEGER IDX(NBM+1) 71 : INTEGER IELRIG(NBTVAL) 72 : INTEGER ILIGR (NBTVAL) 73 : ENDSEGMENT 74 : POINTEUR DDDNUL.LSTIND 75 : * 76 : -INC SMLENTI 77 : POINTEUR KRSPGP.MLENTI 78 : POINTEUR KRINCP.MLENTI 79 : POINTEUR IWORK.MLENTI 80 : POINTEUR DDDNOP.MLENTI 81 : * 82 : INTEGER IMPR,IRET 83 : * 84 : * Executable statements 85 : * 86 : IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans relr1b.eso' 87 : NPOPRI=MINCP.NPOS(/1)-1 88 : NDDLPR=MINCP.NPOS(NPOPRI+1)-1 89 : SEGACT DDDNUL 90 : NDDLDU=DDDNUL.IDX(/1)-1 91 : *a effacer NEL=MEL.NUM(/2) 92 : NDDLOP=DES.NOELEP(/1) 93 : *a effacer NDDLOD=DES.NOELED(/1) 94 : * Segment de travail 95 : JG=NDDLPR 96 : SEGINI IWORK 97 : * 98 : * Passe 1 : construction de la correspondance : 99 : * ieme ddl dual <-> nombre des ddls 100 : * primaux avec lesquels 101 : * il est en relation 102 : * DDDNOP 103 : * 104 : JG=NDDLDU 105 : SEGINI DDDNOP 106 : DO IDDLDU=1,NDDLDU 107 : LDG=0 108 : * Fin de la liste chaînée 109 : LAST=-1 110 : DO JDX=DDDNUL.IDX(IDDLDU), 111 : $ DDDNUL.IDX(IDDLDU+1)-1 112 : IELEM =DDDNUL.IELRIG(JDX) 113 : * a effacer ILIGRD=DDDNUL.ILIGR(JDX) 114 : DO ILIGRP=1,NDDLOP 115 : IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM)) 116 : IINC=KRINCP.LECT(ILIGRP) 117 : IPOS=MINCP.MPOS(IPO,IINC) 118 : IF (IPOS.EQ.0) THEN 119 : WRITE(IOIMP,*) 'Erreur grave no1' 120 : GOTO 9999 121 : ENDIF 122 : IDDLPR=MINCP.NPOS(IPO)+IPOS-1 123 : IF (IWORK.LECT(IDDLPR).EQ.0) THEN 124 : LDG=LDG+1 125 : IWORK.LECT(IDDLPR)=LAST 126 : LAST=IDDLPR 127 : ENDIF 128 : ENDDO 129 : ENDDO 130 : * Le nombre de points distincts trouvés est: 131 : DDDNOP.LECT(IDDLDU)=LDG 132 : * On remet la liste chaînée à 0 133 : DO ILDG=1,LDG 134 : IPREC=IWORK.LECT(LAST) 135 : IWORK.LECT(LAST)=0 136 : LAST=IPREC 137 : ENDDO 138 : ENDDO 139 : * 140 : * Passe 2 : construction de la correspondance : 141 : * ieme ddl dual de la matrice assemblée <-> 142 : * (numéros des ddl primaux avec lesquels il est 143 : * en relation). C'est le profil morse (non ordonné) 144 : * PMCOU 145 : * 146 : * 147 : NTT=NDDLDU 148 : NJA=0 149 : SEGINI PMCOU 150 : IDEPA=1 151 : DO IDDLDU=1,NDDLDU 152 : PMCOU.IA(IDDLDU)=IDEPA 153 : IDEPA=IDEPA+DDDNOP.LECT(IDDLDU) 154 : ENDDO 155 : PMCOU.IA(NDDLDU+1)=IDEPA 156 : SEGSUP DDDNOP 157 : NJA=IDEPA-1 158 : SEGADJ PMCOU 159 : DO IDDLDU=1,NDDLDU 160 : KDX=PMCOU.IA(IDDLDU)-1 161 : DO JDX=DDDNUL.IDX(IDDLDU), 162 : $ DDDNUL.IDX(IDDLDU+1)-1 163 : IELEM =DDDNUL.IELRIG(JDX) 164 : * a effacer ILIGRD=DDDNUL.ILIGR(JDX) 165 : DO ILIGRP=1,NDDLOP 166 : IPO=KRSPGP.LECT(MEL.NUM(DES.NOELEP(ILIGRP),IELEM)) 167 : IINC=KRINCP.LECT(ILIGRP) 168 : IPOS=MINCP.MPOS(IPO,IINC) 169 : IF (IPOS.EQ.0) THEN 170 : WRITE(IOIMP,*) 'Erreur grave no2' 171 : GOTO 9999 172 : ENDIF 173 : IDDLPR=MINCP.NPOS(IPO)+IPOS-1 174 : IF (IWORK.LECT(IDDLPR).EQ.0) THEN 175 : KDX=KDX+1 176 : PMCOU.JA(KDX)=IDDLPR 177 : IWORK.LECT(IDDLPR)=KDX 178 : ENDIF 179 : ENDDO 180 : ENDDO 181 : * On remet le segment de travail a zero 182 : DO KDX=PMCOU.IA(IDDLDU),PMCOU.IA(IDDLDU+1)-1 183 : IWORK.LECT(PMCOU.JA(KDX))=0 184 : ENDDO 185 : ENDDO 186 : SEGDES PMCOU 187 : SEGSUP IWORK 188 : SEGDES DDDNUL 189 : * 190 : * Normal termination 191 : * 192 : IRET=0 193 : RETURN 194 : * 195 : * Format handling 196 : * 197 : * 198 : * Error handling 199 : * 200 : 9999 CONTINUE 201 : IRET=1 202 : WRITE(IOIMP,*) 'An error was detected in subroutine relr1b' 203 : RETURN 204 : * 205 : * End of subroutine RELR1B 206 : * 207 : END 208 : 209 :
© Cast3M 2003 - All rights reserved.
Disclaimer