C GEOREG SOURCE GOUNAND 21/06/02 21:16:15 11022 SUBROUTINE GEOREG(ITQUAF,MYFALS,MYFPGS, $ JMAREG, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : GEOREG C DESCRIPTION : * * Calcul du jacobien de la transformation : * élément volumique de référence -> élément réguliers * de côté 1 * Cela sert pour l'adaptativité. 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 : 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, 04/10/2005, version initiale C HISTORIQUE : v1, 04/10/2005, 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 CCGEOME -INC TNLIN *-INC SELREF POINTEUR ELCOUR.ELREF *-INC SFALRF POINTEUR MYFALS.FALRFS *-INC SPOGAU POINTEUR MYPGS.POGAUS POINTEUR PGCOUR.POGAU *-INC SFAPG POINTEUR MYFPGS.FAPGS *-INC SMCHAEL INTEGER NBLIG,NBCOL,N2LIG,N2COL,NBPOI,NBELM POINTEUR JCOOR.MCHEVA POINTEUR JMAREG.MCHEVA POINTEUR JMIREG.MCHEVA POINTEUR JDTREG.MCHEVA POINTEUR FFPG.MCHEVA,DFFPG.MCHEVA * SEGMENT NOEREG REAL*8 XNOEUD(NDIM,NNLREG) ENDSEGMENT * CHARACTER*4 CQUAF,METGAU,MYDISC LOGICAL LBID INTEGER IMPR,IRET * * Executable statements * IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans georeg.eso' CQUAF=NOMS(ITQUAF) * * Here : SEGINI NOEREG * IF (CQUAF.EQ.'SEG3') THEN NNLREG=2 NDIM =1 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(1,2)=1.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'TRI7') THEN NNLREG=3 NDIM =2 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(1,3)=0.5D0 XNOEUD(2,3)=SQRT(3.D0)/2.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'QUA9') THEN NNLREG=4 NDIM =2 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(1,3)=1.D0 XNOEUD(2,3)=1.D0 XNOEUD(1,4)=0.D0 XNOEUD(2,4)=1.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'TE15') THEN NNLREG=4 NDIM =3 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(3,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(3,2)=0.D0 XNOEUD(1,3)=0.5D0 XNOEUD(2,3)=SQRT(3.D0)/2.D0 XNOEUD(3,3)=0.D0 XNOEUD(1,4)=0.5D0 XNOEUD(2,4)=SQRT(3.D0)/6.D0 XNOEUD(3,4)=SQRT(6.D0)/3.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'PY19') THEN NNLREG=5 NDIM =3 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(3,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(3,2)=0.D0 XNOEUD(1,3)=1.D0 XNOEUD(2,3)=1.D0 XNOEUD(3,3)=0.D0 XNOEUD(1,4)=0.D0 XNOEUD(2,4)=1.D0 XNOEUD(3,4)=0.D0 XNOEUD(1,5)=0.5D0 XNOEUD(2,5)=0.5D0 XNOEUD(3,5)=SQRT(2.D0)/2.D0 * XNOEUD(3,5)=1.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'PR21') THEN NNLREG=6 NDIM =3 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(3,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(3,2)=0.D0 XNOEUD(1,3)=0.5D0 XNOEUD(2,3)=SQRT(3.D0)/2.D0 XNOEUD(3,3)=0.D0 * XNOEUD(1,4)=0.D0 XNOEUD(2,4)=0.D0 XNOEUD(3,4)=1.D0 XNOEUD(1,5)=1.D0 XNOEUD(2,5)=0.D0 XNOEUD(3,5)=1.D0 XNOEUD(1,6)=0.5D0 XNOEUD(2,6)=SQRT(3.D0)/2.D0 XNOEUD(3,6)=1.D0 * SEGDES NOEREG ELSEIF (CQUAF.EQ.'CU27') THEN NNLREG=8 NDIM =3 SEGINI NOEREG XNOEUD(1,1)=0.D0 XNOEUD(2,1)=0.D0 XNOEUD(3,1)=0.D0 XNOEUD(1,2)=1.D0 XNOEUD(2,2)=0.D0 XNOEUD(3,2)=0.D0 XNOEUD(1,3)=1.D0 XNOEUD(2,3)=1.D0 XNOEUD(3,3)=0.D0 XNOEUD(1,4)=0.D0 XNOEUD(2,4)=1.D0 XNOEUD(3,4)=0.D0 * XNOEUD(1,5)=0.D0 XNOEUD(2,5)=0.D0 XNOEUD(3,5)=1.D0 XNOEUD(1,6)=1.D0 XNOEUD(2,6)=0.D0 XNOEUD(3,6)=1.D0 XNOEUD(1,7)=1.D0 XNOEUD(2,7)=1.D0 XNOEUD(3,7)=1.D0 XNOEUD(1,8)=0.D0 XNOEUD(2,8)=1.D0 XNOEUD(3,8)=1.D0 * SEGDES NOEREG ELSE WRITE(IOIMP,*) CQUAF,' regulier non implemente' GOTO 9999 ENDIF * NBLIG=1 NBCOL=XNOEUD(/2) N2LIG=1 N2COL=XNOEUD(/1) NBPOI=1 NBELM=1 SEGINI JCOOR DO I=1,N2COL DO J=1,NBCOL JCOOR.WELCHE(1,J,1,I,1,1)=XNOEUD(I,J) ENDDO ENDDO * * On suppose la transformation linéaire entre élément de * référence et élément régulier => 1 point de Gauss * METGAU='GAU1' CALL KEPG(ITQUAF,METGAU, $ MYFPGS, $ PGCOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 MYDISC='LINE' CALL KEEF(ITQUAF,MYDISC, $ MYFALS, $ ELCOUR, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KFNREF : SEGINI FFPG * In KFNREF : SEGINI DFFPG CALL KFNREF(ELCOUR,PGCOUR, $ FFPG,DFFPG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * Création des matrices jacobiennes et déterminants * On ne garde que la matrice jacobienne. * In GEOLIN : SEGINI JMAREG * In GEOLIN : SEGINI JMIREG * In GEOLIN : SEGINI JDTREG NBELEM=1 LBID=.FALSE. * CALL GEOLIN(DFFPG,JCOOR,NBELEM, $ JMAREG,JMIREG,JDTREG,LBID, $ IMPR,IRET) IF (IRET.NE.0) THEN IF (LBID) GOTO 9666 GOTO 9999 ENDIF SEGSUP JDTREG SEGSUP JMIREG SEGDES JMAREG SEGSUP DFFPG SEGSUP FFPG SEGSUP JCOOR SEGSUP NOEREG * SEGPRT,JMAREG * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9666 CONTINUE IRET=666 RETURN 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine georeg' RETURN * * End of subroutine GEOREG * END