C MELAND SOURCE FANDEUR 22/05/02 21:15:25 11359 SUBROUTINE MELAND(GPMELS, $ MAICOM, $ IMPR,IRET) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C*********************************************************************** C NOM : MELAND C DESCRIPTION : Renvoie le maillage de points (POI1) MAICOM des C points appartenant à tous les maillages de gpmels. C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : - C APPELE PAR : MELCOM C*********************************************************************** C ENTREES : GPMELS C SORTIES : MAICOM C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 12/05/99, version initiale C HISTORIQUE : v1, 12/05/99, 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 SMCOORD -INC SMELEME POINTEUR MELCOU.MELEME POINTEUR SOUMEL.MELEME INTEGER NBELEM,NBNN,NBREF,NBSOUS POINTEUR MAICOM.MELEME -INC SMLENTI INTEGER JG POINTEUR IWORK.MLENTI * * Includes persos * SEGMENT MELS POINTEUR LISMEL(NBMEL).MELEME ENDSEGMENT POINTEUR GPMELS.MELS * INTEGER IMPR,IRET * LOGICAL BSAME INTEGER BEGI,LAST,ILAST,IPREC,LDG,ILDG,NUMNO INTEGER IELEM,IPOEL,ISOUS,IMEL INTEGER NELEM,NPOEL,NSOUS,NMEL * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans meland.eso' SEGACT GPMELS NMEL=GPMELS.LISMEL(/1) IF (NMEL.LE.0) THEN WRITE(IOIMP,*) 'Nombre de MELEMEs négatif ou nul' GOTO 9999 ENDIF * On cherche le cas évident : * - Maillage tous identiques de POI1 MELCOU=GPMELS.LISMEL(1) SEGACT MELCOU BSAME=.FALSE. IF (MELCOU.ITYPEL.EQ.1) THEN BSAME=.TRUE. DO 1 IMEL=2,NMEL IF (GPMELS.LISMEL(IMEL).NE.MELCOU) THEN BSAME=.FALSE. ENDIF 1 CONTINUE ENDIF SEGDES MELCOU IF (BSAME) THEN SEGINI,MAICOM=MELCOU SEGDES MAICOM ELSE * - On construit la liste chaînée avec le premier maillage JG=nbpts SEGINI IWORK * degré, fin de la liste chaînée LDG=0 BEGI=nbpts+1 LAST=BEGI MELCOU=GPMELS.LISMEL(1) SEGACT MELCOU NSOUS=MELCOU.LISOUS(/1) DO 3 ISOUS=1,MAX(1,NSOUS) IF (NSOUS.EQ.0) THEN SOUMEL=MELCOU ELSE SOUMEL=MELCOU.LISOUS(ISOUS) SEGACT SOUMEL ENDIF NPOEL=SOUMEL.NUM(/1) NELEM=SOUMEL.NUM(/2) DO 32 IELEM=1,NELEM DO 322 IPOEL=1,NPOEL NUMNO=SOUMEL.NUM(IPOEL,IELEM) IF (IWORK.LECT(NUMNO).EQ.0) THEN LDG=LDG+1 IWORK.LECT(NUMNO)=LAST LAST=NUMNO ENDIF 322 CONTINUE 32 CONTINUE IF (NSOUS.NE.0) THEN SEGDES SOUMEL ENDIF 3 CONTINUE SEGDES MELCOU * - On réduit la liste chaînée des points des autres maillages * qui ne sont pas déjà dedans *COMM write(ioimp,*) 'nmel=',nmel DO 5 IMEL=2,NMEL *COMM write(ioimp,*) 'last,ldg,imel',LAST,LDG,IMEL *COMM SEGPRT,IWORK * On attribue le signe - à tous les points de la liste chaînée NUMNO=LAST DO 52 ILDG=1,LDG IPREC=IWORK.LECT(NUMNO) IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO) NUMNO=IPREC 52 CONTINUE *COMM write(ioimp,*) 'négativation' *COMM SEGPRT,IWORK MELCOU=GPMELS.LISMEL(IMEL) * On attribue le signe + aux points de la liste chaînée * qui sont dans le IMEL ième maillage SEGACT MELCOU NSOUS=MELCOU.LISOUS(/1) DO 54 ISOUS=1,MAX(1,NSOUS) IF (NSOUS.EQ.0) THEN SOUMEL=MELCOU ELSE SOUMEL=MELCOU.LISOUS(ISOUS) SEGACT SOUMEL ENDIF NPOEL=SOUMEL.NUM(/1) NELEM=SOUMEL.NUM(/2) DO 542 IELEM=1,NELEM DO 5422 IPOEL=1,NPOEL NUMNO=SOUMEL.NUM(IPOEL,IELEM) IF (IWORK.LECT(NUMNO).LT.0) THEN IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO) ENDIF 5422 CONTINUE 542 CONTINUE IF (NSOUS.NE.0) THEN SEGDES SOUMEL ENDIF 54 CONTINUE SEGDES MELCOU *COMM write(ioimp,*) 'positivation' *COMM SEGPRT,IWORK * On nettoie la liste chaînée des points qui sont restés * avec le signe négatif * * D'abord, on cherche la fin de ce qui sera la nouvelle liste * If (LAST.EQ.BEGI), la liste résultat est vide IF (LAST.NE.BEGI) THEN NUMNO=LAST 56 CONTINUE IPREC=IWORK.LECT(NUMNO) IF (IPREC.LT.0) THEN LDG=LDG-1 IWORK.LECT(NUMNO)=0 NUMNO=-IPREC IF (NUMNO.NE.BEGI) THEN GOTO 56 ENDIF ENDIF LAST=NUMNO ENDIF *COMM write(ioimp,*) 'Fin de la liste=',LAST * Une fois obtenue la fin de la liste résultat, on continue * If (LAST.EQ.BEGI), la liste résultat est vide IF (LAST.NE.BEGI) THEN ILAST=LAST NUMNO=LAST * IPREC est forcément positif sinon, LAST n'aurait pas la bonne valeur IPREC=IWORK.LECT(NUMNO) NUMNO=IPREC *COMM write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC IF (NUMNO.NE.BEGI) THEN 58 CONTINUE IPREC=IWORK.LECT(NUMNO) *COMM write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC IF (IPREC.LT.0) THEN LDG=LDG-1 IWORK.LECT(NUMNO)=0 NUMNO=-IPREC ELSE IWORK.LECT(ILAST)=NUMNO ILAST=NUMNO NUMNO=IPREC ENDIF IF (NUMNO.NE.BEGI) THEN GOTO 58 ENDIF ENDIF IWORK.LECT(ILAST)=BEGI *COMM write(ioimp,*) 'nettoyage' *COMM SEGPRT,IWORK ENDIF 5 CONTINUE * Créer le maillage de points correspondant à la liste chaînée NBNN=1 NBELEM=LDG NBSOUS=0 NBREF=0 SEGINI MAICOM MAICOM.ITYPEL=1 NUMNO=LAST DO 7 ILDG=1,LDG IPREC=IWORK.LECT(NUMNO) MAICOM.NUM(1,ILDG)=NUMNO NUMNO=IPREC 7 CONTINUE SEGDES MAICOM SEGSUP IWORK ENDIF SEGDES GPMELS IF (IMPR.GT.2) THEN WRITE(IOIMP,*) 'On a créé MAICOM=',MAICOM IF (IMPR.GT.3) THEN SEGPRT,MAICOM ENDIF ENDIF * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine meland' RETURN * * End of subroutine MELAND * END