C MANUR4 SOURCE CHAT 09/10/09 21:20:33 6519 SUBROUTINE MANUR4 (IPELEM,IPDESC,MTEMP4,IPMATR,IANTI) ************************************************************************ * * M A N U R 4 * ----------- * * FONCTION: * --------- * * CONSTRUCTION DES MATRICES ELEMENTAIRES DE RIGIDITE POUR UN OBJET * 'RIGIDITE' CREE MANUELLEMENT. * L'UTILISATION DE CE SOUS-PROGRAMME N'EST PAS UNIVERSELLE. * * MODE D'APPEL: * ------------- * * CALL MANUR4 (IPELEM,IPDESC,MTEMP4,IPMATR,IANTI) * * PARAMETRES: (E)=ENTREE (S)=SORTIE * ----------- * * IPELEM ENTIER (E) POINTEUR DE L'OBJET 'MAILLAGE' SUR LEQUEL * VA S'APPUYER LA 'RIGIDITE'. * IPDESC ENTIER (E) POINTEUR SUR LE SEGMENT DESCRIPTEUR DE * L'OBJET 'RIGIDITE'. * MTEMP4 SEGMENT (E) REGROUPEMENT DE POINTEURS SUR DES * 'LISTREEL'. * SOIT IL N'Y A QU'1 'LISTREEL', QUI CONTIENT * TOUS LES TERMES DE LA * MATRICE ELEMENTAIRE DE RIGIDITE, ECRITS * LIGNE PAR LIGNE, * SOIT IL Y A AUTANT DE 'LISTREEL' QUE DE * LIGNES DANS LA MATRICE ELEMENTAIRE DE * RIGIDITE, LE N-IEME 'LISTREEL' DECRIVANT LA * N-IEME LIGNE DE LA MATRICE . * IPMATR ENTIER (S) POINTEUR SUR LE SEGMENT CONTENANT LA LISTE * DES POINTEURS DES MATRICES ELEMENTAIRES DE * RIGIDITE. * * EXEMPLE DE PRESENTATION DE LA MATRICE ELEMENTAIRE: * * | A B C | * | B D E | PEUT ETRE REPRESENTEE: * | C E F | * * PAR 1 SEUL 'LISTREEL' CONTENANT: A, B,C,B, D,E, C, E, F. * PAR 3 'LISTREEL' CONTENANT: A. B C * B, D. E * C, E, F. * * LEXIQUE: (ORDRE ALPHABETIQUE) * -------- * * LONG ENTIER LONGUEUR DU 'LISTREEL' TRAITE. * NBLREE ENTIER NOMBRE DE 'LISTREEL' REFERENCES PAR "MTEMP4". * * LES AUTRES VARIABLES IMPORTANTES SONT EXPLIQUEES DANS LES MODULES * INCLUS. * * SOUS-PROGRAMMES APPELES: * ------------------------ * * ERREUR. * * AUTEUR, DATE DE CREATION: * ------------------------- * * PASCAL MANIGOT 19 FEVRIER 1985 * * LANGAGE: * -------- * * ESOPE + FORTRAN77 * ************************************************************************ * IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMELEME -INC SMLREEL -INC SMRIGID * SEGMENT /MTEMP4/ (ILREEL(0)) * cdebug LOGICAL TEST * MELEME = IPELEM SEGACT,MELEME NELRIG = NUM(/2) SEGDES,MELEME * DESCR = IPDESC SEGACT,DESCR C ... La distinction entre les deux nombre est un peu artificielle, C car manur3 vérifie si les listmots sont de longueurs égales, C on en a juste besoin pour initialiser XMATRI ... NLIGRP = NOELEP(/1) NLIGRD = NOELED(/1) C ... LVAL = nombre de termes d'une matrice pleine ... LVAL = NLIGRP * NLIGRD SEGDES,DESCR * SEGINI,xMATRI IPMATR = xMATRI * SEGINI,XMATRI * DO 100 IB100=1,NELRIG * IMATTT(IB100) = XMATRI * 100 CONTINUE * END DO * SEGDES,IMATRI * * RQ: "XMATRI" EST GARDE ACTIF. * SEGACT,MTEMP4 NBLREE = ILREEL(/1) * IF (NBLREE .EQ. 1) THEN * MLREEL = ILREEL(1) SEGACT,MLREEL C ... LVA1 = nombre de termes d'une matrice carrée défini par C sa moitié ... LVA1=NLIGRP*(NLIGRP+1)/2 IF (LVAL .NE. PROG(/1).AND.PROG(/1).NE.LVA1 ) THEN NUMERR = 199 CALL ERREUR (NUMERR) RETURN END IF * C ... ILA = N° de ligne de la matrice élémentaire ... ILA=1 C ... ILC = N° de colonne de la matrice élémentaire ... ILC=1 C ... ITRI dit si toutes les composantes ont été données ou C juste le triangle inférieur ... ITRI=0 IF(PROG(/1).EQ.LVA1) ITRI=1 IF(ITRI.EQ.1.AND.IANTI.EQ.2) THEN CALL ERREUR(731) C ... On laisse les cochonneries dans XMATRI ... * SEGDES,XMATRI C ... puis on s'en va ... RETURN ENDIF DO 200 IB200=1,PROG(/1) RE(ILA,ILC,1) = PROG(IB200) IF(ITRI.EQ.1) THEN IF(IANTI.EQ.1) THEN RE(ILC,ILA,1)=-PROG(IB200) ELSE RE(ILC,ILA,1)=PROG(IB200) ENDIF ENDIF cdebugC ... Vérif si les lignes pleines respectent la symétrie spécifiée ... cdebug IF((ITRI.EQ.0) .AND. cdebug & (IANTI.EQ.0.OR.IANTI.EQ.1) .AND. cdebug & (ILC.LE.ILA)) THEN cdebug IF(IANTI.EQ.0) TEST=RE(ILA,ILC,1).EQ.RE(ILC,ILA,1) cdebug IF(IANTI.EQ.1) TEST=RE(ILA,ILC,1).EQ.-RE(ILC,ILA,1) cdebug IF(.NOT.TEST) THEN cdebug write(*,*) 'Erreur : les lignes pleines ne ', cdebug & 'respectent pas la symétrie spécifiée !' cdebugC-à-faire boulot avec les segments cdebug return cdebug ENDIF cdebug ENDIF ILC=ILC+1 C ... On passe à la ligne si on a traversé la diagonale (cas triangulaire) ... IF(ILC.GT.ILA.AND.ITRI.EQ.1) THEN ILC=1 ILA=ILA+1 ENDIF C ... On passe à la ligne si on est au bout (cas plein) ... IF(ILC.GT.NLIGRP) THEN ILC=1 ILA=ILA+1 ENDIF 200 CONTINUE do ib=2,nelrig do io=1,nligrp do iu=1,nligrd re(iu,io,ib)=re(iu,io,1) enddo enddo enddo * END DO * SEGDES,MLREEL * ELSE IF (NBLREE .GT. 1) THEN * IF (NBLREE .EQ. NLIGRD) THEN * MLREEL=ILREEL(1) SEGACT MLREEL C ... Cas triangulaire ? ... ITRI=0 IF(PROG(/1).EQ.1) ITRI=1 IF(ITRI.EQ.1.AND.IANTI.EQ.2) THEN CALL ERREUR(731) C ... On laisse les cochonneries dans XMATRI ... * SEGDES,XMATRI C ... puis on s'en va ... RETURN ENDIF C ... Boucle sur les lignes (IB300 = N° de la ligne) ... DO 300 IB300=1,NBLREE * MLREEL = ILREEL(IB300) SEGACT,MLREEL LONG = PROG(/1) C ... Cas lignes pleines : longueur doit être NLIGRP ... IF (ITRI.EQ.0.AND.LONG .NE. NLIGRP) THEN NUMERR = 200 CALL ERREUR (NUMERR) RETURN END IF C ... Cas triangulaire : longueur doit être N° de la ligne ... IF (ITRI.EQ.1.AND.LONG.NE.IB300) THEN NUMERR = 200 CALL ERREUR (NUMERR) RETURN END IF C ... Boucle sur les colonnes (IB310 = N° de la colonne) ... DO 310 IB310=1,LONG RE(IB300,IB310,1) = PROG(IB310) IF(IANTI.EQ.1.AND.ITRI.EQ.1)RE(IB310,IB300,1)=-RE(IB300,IB310,1) IF(IANTI.EQ.0.AND.ITRI.EQ.1)RE(IB310,IB300,1)=RE(IB300,IB310,1) cdebugC ... Vérif si les lignes pleines respectent la symétrie spécifiée ... cdebug IF((ITRI.EQ.0) .AND. cdebug & (IANTI.EQ.0.OR.IANTI.EQ.1) .AND. cdebug & (IB310.LE.IB300)) THEN cdebug IF(IANTI.EQ.0) TEST=RE(IB300,IB310,1).EQ.RE(IB310,IB300,1) cdebug IF(IANTI.EQ.1) TEST=RE(IB300,IB310,1).EQ.-RE(IB310,IB300,1) cdebug IF(.NOT.TEST) THEN cdebug write(*,*) 'Erreur : les lignes pleines ne ', cdebug & 'respectent pas la symétrie spécifiée !' cdebugC-à-faire boulot avec les segments cdebug return cdebug ENDIF cdebug ENDIF 310 CONTINUE * END DO * SEGDES,MLREEL * 300 CONTINUE do ib=2,nelrig do io=1,nligrp do iu=1,nligrd re(iu,io,ib)=re(iu,io,1) enddo enddo enddo * END DO C ... c.à.d. le nombre de LISTREEL est différent du nombre de variables duales ... ELSE * NUMERR = 201 CALL ERREUR (NUMERR) RETURN * END IF * ELSE * * AUCUN 'LISTREEL' N'A ETE FOURNI EN DONNEE. MOTERR(1:8) = 'LISTREEL' NUMERR = 37 CALL ERREUR (NUMERR) RETURN * END IF * SEGDES,XMATRI SEGDES,MTEMP4 * END