C ZLAP1A SOURCE MAGN 09/07/30 21:23:35 6458 SUBROUTINE ZLAP1A(PROPHY,IROC,ITEMC, $ ITIMP,IRIMP, $ MELEMC,MELEMF,MELEFL,ISURF,INORM,IVOLU,NOMINC, $ IJACO) C*********************************************************************** C NOM : ZLAP1A C DESCRIPTION : Calcul de la matrice jacobienne du résidu du laplacien C VF 2D (termes multi-espèces). 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 : ZLAP1B | Calcul des contributions à la matrice C ZLAP1C | jacobienne du résidu du laplacien VF 2D. C APPELES (UTIL) : LICHT2 : Lecture des pointeurs (maillages, valeurs) C d'un objet de type MCHPOI. C KRIPME : Création d'un tableau de repérage dans un C maillage de points. C ZERMAK : Création d'un objet de type MATRIK vide. C APPELES (STD) : ERREUR : Gestion des erreurs par GIBI. C APPELE PAR : ZLAP11 : Chapeau de l'opérateur Gibiane 'LAPN' C option 'VF'. C*********************************************************************** C ENTREES : PROPHY (type PROPHY) : propriétés des espèces C IROC (type MCHPOI) : masse volumique par élément. C ITEMC (type MCHPOI) : température par élément. C ITIMP (type MCHPOI) : CL de Dirichlet sur la C température. C IRIMP (type MCHPOI) : CL de Dirichlet sur la C densité. C MELEMC (type MELEME) : maillage des centres des C éléments. C MELEMF (type MELEME) : maillage des faces des C éléments. C MELEFL (type MELEME) : connectivités face-(centre C gauche, centre droit). C ISURF (type MCHPOI) : surface des faces. C INORM (type MCHPOI) : normale aux faces. C IVOLU (type MCHPOI) : volume des éléments. C NOMINC (type MLMOTS) : noms des inconnues. C ENTREES/SORTIES : IJACO (type MATRIK) : matrice jacobienne du C résidu du laplacien VF 2D. C SORTIES : - C*********************************************************************** C VERSION : v1, 21/02/2002, version initiale C HISTORIQUE : v1, 21/02/2002, 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*********************************************************************** IMPLICIT INTEGER(I-N) -INC CCOPTIO -INC SMCOORD -INC SMCHPOI POINTEUR IROC.MCHPOI,ITEMC.MCHPOI POINTEUR ICDIFF.MCHPOI,IYKC.MCHPOI,IGRYKF.MCHPOI POINTEUR ITIMP.MCHPOI ,IRIMP.MCHPOI,IYIMP.MCHPOI POINTEUR ISURF.MCHPOI ,INORM.MCHPOI ,IVOLU.MCHPOI POINTEUR MPROC.MPOVAL ,MPTEMC.MPOVAL POINTEUR MPCDIF.MPOVAL,MPYK.MPOVAL,MPGRYK.MPOVAL POINTEUR MPTIMP.MPOVAL,MPRIMP.MPOVAL,MPYIMP.MPOVAL POINTEUR MPSURF.MPOVAL,MPNORM.MPOVAL,MPVOLU.MPOVAL -INC SMELEME POINTEUR MELEMC.MELEME,MELEMF.MELEME,MELEFL.MELEME POINTEUR MELBID.MELEME POINTEUR MLTIMP.MELEME,MLRIMP.MELEME,MLYIMP.MELEME -INC SMLENTI POINTEUR KRTIMP.MLENTI,KRRIMP.MLENTI,KRYIMP.MLENTI POINTEUR KRCENT.MLENTI,KRFACE.MLENTI -INC SMLMOTS POINTEUR NOMINC.MLMOTS -INC SMMATRIK POINTEUR IJACO.MATRIK * INTEGER IMPR,IRET * LOGICAL LCLIMT,LCLIMR,LCLIMY * INTEGER NTOTPO INTEGER NESP SEGMENT PROPHY CHARACTER*4 NOMESP(NESP+1) REAL*8 CV(NESP+1) REAL*8 R(NESP+1) REAL*8 H0K(NESP+1) POINTEUR CDIFF(NESP+1).MCHPOI POINTEUR YK(NESP+1).MCHPOI POINTEUR GRADYK(NESP+1).MCHPOI POINTEUR CGRYK(NESP+1).MCHELM POINTEUR CLYK(NESP+1).MCHPOI ENDSEGMENT SEGMENT PROPH2 POINTEUR MPDIFF(NESP+1).MPOVAL POINTEUR MPVALY(NESP+1).MPOVAL POINTEUR MPGRAD(NESP+1).MPOVAL LOGICAL LCLIM(NESP+1) POINTEUR KRCLIM(NESP+1).MLENTI ENDSEGMENT * INTEGER IESP * * Executable statements * IMPR=0 IF (IMPR.GT.2) WRITE(IOIMP,*) 'Entrée dans zlap1a.eso' * Lecture des données et initialisations de tableaux de travail CALL LICHT2(IROC,MPROC,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL LICHT2(ITEMC,MPTEMC,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL LICHT2(ISURF,MPSURF,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL LICHT2(INORM,MPNORM,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 CALL LICHT2(IVOLU,MPVOLU,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 LCLIMT=(ITIMP.NE.0) LCLIMR=(IRIMP.NE.0) NTOTPO=MCOORD.XCOOR(/1)/(IDIM+1) IF (LCLIMT) THEN CALL LICHT2(ITIMP,MPTIMP,MLTIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KRIPME : SEGINI KRTIMP CALL KRIPME(MLTIMP,NTOTPO,KRTIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF IF (LCLIMR) THEN CALL LICHT2(IRIMP,MPRIMP,MLRIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KRIPME : SEGINI KRRIMP CALL KRIPME(MLRIMP,NTOTPO,KRRIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF * Repérage dans les faces, les centres * In KRIPME : SEGINI KRFACE CALL KRIPME(MELEMF,NTOTPO,KRFACE,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KRIPME : SEGINI KRCENT CALL KRIPME(MELEMC,NTOTPO,KRCENT,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SEGACT PROPHY NESP=PROPHY.CV(/1)-1 SEGINI PROPH2 DO IESP=1,NESP+1 ICDIFF=PROPHY.CDIFF(IESP) CALL LICHT2(ICDIFF,MPCDIF,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 PROPH2.MPDIFF(IESP)=MPCDIF IYKC=PROPHY.YK(IESP) CALL LICHT2(IYKC,MPYK,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 PROPH2.MPVALY(IESP)=MPYK IGRYKF=PROPHY.GRADYK(IESP) CALL LICHT2(IGRYKF,MPGRYK,MELBID,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 PROPH2.MPGRAD(IESP)=MPGRYK IYIMP=PROPHY.CLYK(IESP) LCLIMY=(IYIMP.NE.0) PROPH2.LCLIM(IESP)=LCLIMY IF (LCLIMY) THEN CALL LICHT2(IYIMP,MPYIMP,MLYIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KRIPME : SEGINI KRYIMP CALL KRIPME(MLYIMP,NTOTPO,KRYIMP,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 PROPH2.KRCLIM(IESP)=KRYIMP ENDIF ENDDO SEGDES PROPH2 SEGDES PROPHY * Calcul des contributions suivantes à la matrice jacobienne faisant * intervenir les coefficients pour le calcul des gradients de Yk * (contributions à (d Res_{\rho Yk} / d var) * var prenant successivement les valeurs : * \rho, \rho Yk ) * CALL ZLAP1B(PROPHY,PROPH2,MPROC, $ MPVOLU,MPNORM,MPSURF,MELEFL, $ KRFACE,KRCENT,LCLIMR,KRRIMP,MPRIMP, $ NOMINC, $ IJACO, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * Calcul des contributions suivantes à la matrice jacobienne faisant * intervenir les coefficients pour le calcul des gradients de Yk * (contributions à (d Res_{\rho e_t} / d var) * var prenant successivement les valeurs : * \rho, \rho Yk ) * CALL ZLAP1C(PROPHY,PROPH2,MPROC,MPTEMC, $ MPVOLU,MPNORM,MPSURF,MELEFL, $ KRFACE,KRCENT, $ LCLIMR,KRRIMP,MPRIMP, $ LCLIMT,KRTIMP,MPTIMP, $ NOMINC, $ IJACO, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Destruction des tableaux de travail * SEGACT PROPH2 DO IESP=1,NESP+1 LCLIMY=PROPH2.LCLIM(IESP) IF (LCLIMY) THEN KRYIMP=PROPH2.KRCLIM(IESP) SEGSUP KRYIMP ENDIF ENDDO SEGSUP PROPH2 SEGSUP KRCENT SEGSUP KRFACE IF (LCLIMR) THEN SEGSUP KRRIMP ENDIF IF (LCLIMT) THEN SEGSUP KRTIMP ENDIF * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine zlap1a' CALL ERREUR(5) RETURN * * End of subroutine ZLAP1A * END