C CP2CV7 SOURCE GOUNAND 07/07/30 21:15:08 5819 SUBROUTINE CP2CV7(CGEOME,MYLMOT,MYDISC,MYCHPO,MYREAL, $ MYFALS, $ MYMCHA, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : CP2CV7 C DESCRIPTION : Transforme un chpoint en MCHAEL C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : C APPELE PAR : PRLS63 C*********************************************************************** C ENTREES : * CGEOME (type MELEME) : maillage de QUAFs C partitionné. C * MYDISC (type CH*(4)) : nom d'espace de C discrétisation (cf. NOMFA dans l'include C SFALRF) C * MYFALS (type FALRFS) : segment de description C des familles d'éléments de références. C SORTIES : * MYMCHA (type MCHAEL) : champ par éléments de C la grandeur tensorielle (degrés de liberté de C la grandeur). C ENTREES/SORTIES : - C TRAVAIL : C (1, nb. ddl, NCOMPD, NCOMPP, 1, nb. élément) C C CODE RETOUR (IRET) : = 0 si tout s'est bien passé C*********************************************************************** C VERSION : v1, 24/09/03, version initiale C HISTORIQUE : v1, 24/09/03, 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 CCOPTIO -INC SMCOORD -INC SMCHPOI POINTEUR MYCHPO.MCHPOI -INC TMTRAV POINTEUR MYMTRA.MTRAV INTEGER NNIN,NNNOE -INC SMELEME POINTEUR CGEOME.MELEME POINTEUR SOUMAI.MELEME -INC SMLMOTS POINTEUR MYLMOT.MLMOTS INTEGER JGN -INC SMLENTI POINTEUR KRIGEO.MLENTI POINTEUR KRINCO.MLENTI INTEGER JG * * Includes persos * CBEGININCLUDE SMCHAEL SEGMENT MCHAEL POINTEUR IMACHE(N1).MELEME POINTEUR ICHEVA(N1).MCHEVA ENDSEGMENT SEGMENT MCHEVA REAL*8 VELCHE(NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM) ENDSEGMENT SEGMENT LCHEVA POINTEUR LISCHE(NBCHE).MCHEVA ENDSEGMENT CENDINCLUDE SMCHAEL INTEGER N1 POINTEUR MYMCHA.MCHAEL INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM POINTEUR MZMCHA.MCHEVA CBEGININCLUDE SFALRF SEGMENT FALRF CHARACTER*(LNNFA) NOMFA INTEGER NUQUAF(NBLRF) POINTEUR ELEMF(NBLRF).ELREF ENDSEGMENT SEGMENT FALRFS POINTEUR LISFA(0).FALRF ENDSEGMENT CENDINCLUDE SFALRF POINTEUR MYFALS.FALRFS CBEGININCLUDE SELREF SEGMENT ELREF CHARACTER*(LNNOM) NOMLRF CHARACTER*(LNFORM) FORME CHARACTER*(LNTYPL) TYPEL CHARACTER*(LNESP) ESPACE INTEGER DEGRE REAL*8 XCONOD(NDIMEL,NBNOD) INTEGER NPQUAF(NBDDL) INTEGER NUMCMP(NBDDL) INTEGER QUENOD(NBDDL) INTEGER ORDDER(NDIMEL,NBDDL) POINTEUR MBPOLY.POLYNS ENDSEGMENT SEGMENT ELREFS POINTEUR LISEL(0).ELREF ENDSEGMENT CENDINCLUDE SELREF POINTEUR MYLRF.ELREF * CHARACTER*(4) MYDISC INTEGER IMPR,IRET * INTEGER IBEL,IDDL,ISOUS,ITQUAF INTEGER NBEL,NDDL,NSOUS INTEGER NMLOC,NMQUA,NNGLO,NNLOC,NNMDDL,NNQUA INTEGER NTOGPO LOGICAL LDDLEX REAL*8 MYREAL REAL*8 CONTRI LOGICAL LWARN,LVIDE * * Executable statements * IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans cp2cv7' * Transformation du chpoint en un objet MTRAV plus commode * IF (MYCHPO.EQ.0) THEN MYMCHA=0 ELSEIF (MYCHPO.LT.0) THEN SEGACT CGEOME NSOUS=CGEOME.LISOUS(/1) N1=NSOUS SEGINI MYMCHA DO 2 ISOUS=1,NSOUS SOUMAI=CGEOME.LISOUS(ISOUS) SEGACT SOUMAI * On cherche l'élément fini correspondant au QUAF ITQUAF=SOUMAI.ITYPEL CALL KEEF(ITQUAF,MYDISC, $ MYFALS, $ MYLRF, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT MYLRF NDDL=MYLRF.NPQUAF(/1) * NBEL=SOUMAI.NUM(/2) * On initialise le MCHEVA a remplir NBLIG=1 NBCOL=NDDL N2LIG=1 N2COL=1 NBPOI=1 * Astuce ! NBELM=1 SEGINI MZMCHA DO IDDL=1,NDDL MZMCHA.VELCHE(1,IDDL,1,1,1,1)= $ MYREAL ENDDO SEGDES MZMCHA MYMCHA.ICHEVA(ISOUS)=MZMCHA SEGDES MYLRF SEGDES SOUMAI MYMCHA.IMACHE(ISOUS)=SOUMAI 2 CONTINUE SEGDES MYMCHA SEGDES CGEOME ELSE CALL CP2TRA(MYCHPO, $ MYMTRA,LVIDE, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Warning, si aucune valeur du chpoint n'a servi * *Pour débugger * LWARN=.TRUE. LWARN=.FALSE. * * Segments de repérage dans MTRAV * SEGACT MYMTRA JGN=MYMTRA.INCO(/1) NNIN=MYMTRA.INCO(/2) NNNOE=MYMTRA.IGEO(/1) * Création du segment de répérage dans IGEO NTOGPO=XCOOR(/1)/(IDIM+1) JG=NTOGPO SEGINI,KRIGEO CALL RSETEE(MYMTRA.IGEO,NNNOE, $ KRIGEO.LECT,NTOGPO, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * Création du segment de repérage dans INCO SEGACT MYLMOT NNMDDL=MYLMOT.MOTS(/2) JG=NNMDDL SEGINI KRINCO CALL CREPE2(JGN,NNMDDL,NNIN, $ MYLMOT.MOTS,MYMTRA.INCO, $ KRINCO.LECT, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Création et remplissage du champ par éléments * SEGACT CGEOME NSOUS=CGEOME.LISOUS(/1) N1=NSOUS SEGINI MYMCHA DO 1 ISOUS=1,NSOUS SOUMAI=CGEOME.LISOUS(ISOUS) SEGACT SOUMAI * SEGPRT,SOUMAI * On cherche l'élément fini correspondant au QUAF ITQUAF=SOUMAI.ITYPEL CALL KEEF(ITQUAF,MYDISC, $ MYFALS, $ MYLRF, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT MYLRF NDDL=MYLRF.NPQUAF(/1) NBEL=SOUMAI.NUM(/2) * On initialise le MCHEVA a remplir NBLIG=1 NBCOL=NDDL N2LIG=1 N2COL=1 NBPOI=1 NBELM=NBEL SEGINI MZMCHA DO IBEL=1,NBEL DO IDDL=1,NDDL NNQUA=MYLRF.NPQUAF(IDDL) NNGLO=SOUMAI.NUM(NNQUA,IBEL) NNLOC=KRIGEO.LECT(NNGLO) NMQUA=MYLRF.NUMCMP(IDDL) NMLOC=KRINCO.LECT(NMQUA) IF (NNLOC.EQ.0.OR.NMLOC.EQ.0) THEN CONTRI=0.D0 ELSE LDDLEX=MYMTRA.IBIN(NMLOC,NNLOC).EQ.1 IF (.NOT.LDDLEX) THEN CONTRI=0.D0 ELSE LWARN=.FALSE. CONTRI=MYMTRA.BB(NMLOC,NNLOC) ENDIF ENDIF MZMCHA.VELCHE(1,IDDL,1,1,1,IBEL)=CONTRI ENDDO ENDDO SEGDES MZMCHA * SEGPRT,MZMCHA MYMCHA.ICHEVA(ISOUS)=MZMCHA SEGDES MYLRF SEGDES SOUMAI MYMCHA.IMACHE(ISOUS)=SOUMAI 1 CONTINUE SEGDES MYMCHA SEGDES CGEOME SEGSUP KRINCO SEGDES MYLMOT SEGSUP KRIGEO SEGSUP MYMTRA * IMPR=6 IF (IMPR.GT.3) THEN WRITE(IOIMP,*) 'On a créé', $ ' MYMCHA(élément ,1, 1 , 1 ,1, ddl)' CALL PRCAEL(MYMCHA,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF * * Warning * IF (LWARN.AND.(.NOT.LVIDE)) THEN WRITE(IOIMP,*) 'Error : no values of the given CHPOINT', $ ' were used' GOTO 9999 ENDIF ENDIF * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine cp2cv7' RETURN * * End of subroutine CP2CV7 * END