C KONV SOURCE CB215821 20/11/25 13:32:40 10792 SUBROUTINE KONV IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C*********************************************************************** C C CET OPERATEUR DISCRETISE LE TERME DE TRANSPORT C EN 2D SUR LES ELEMENTS QUA4 ET TRI3 PLAN OU AXI C EN 3D SUR LES ELEMENTS CUB8 ET PRI6 C EN 0D SUR LES ELEMENTS POI1 C C EN VOLUMES FINIS, DISCRETISATION DES EQUATIONS D'EULERS C C C SYNTAXE : C --------- C C KONV RO UN INCO TN : C C COEFFICIENTS : C -------------- C C C ALF (SCAL DOMA) DIFFUSIVITE THERMIQUE C (SCAL ELEM) C C INCONNUES : C ----------- C C TN CHAMP DE TEMPERATURE C C************************************************************************ -INC CCVQUA4 -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SMLENTI POINTEUR IZIPAD.MLENTI,IPADI.MLENTI,IPADS.MLENTI,IPADU.MLENTI -INC SMELEME POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEMI.MELEME POINTEUR MELEMA.MELEME,MELEMF.MELEME -INC SMCHAML -INC SMCHPOI POINTEUR MCHPIN.MCHPOI POINTEUR MZUN.MPOVAL,MZUN2.MPOVAL,MZMU.MPOVAL POINTEUR MZDT.MPOVAL,MZPHI.MPOVAL POINTEUR MRO.MCHPOI,MZRO.MPOVAL POINTEUR IZTG2.MCHPOI,IZTG3.MCHPOI POINTEUR IZTGG2.MPOVAL,IZTGG3.MPOVAL POINTEUR IZTU1.MPOVAL,IZTU2.MPOVAL,IZTU3.MPOVAL,IZTU4.MPOVAL POINTEUR IZTG5.MPOVAL POINTEUR IZVOL.MPOVAL,IZTCO.MPOVAL,IZDIAE.MPOVAL,IZTDI.MPOVAL -INC SIZFFB PARAMETER (LRV=64) SEGMENT PETROV REAL*8 WT(LRV,NP,NPG,KDIM),WS(LRV,NP,NPG,KDIM),HK(LRV,IDIM,NP,NPG) REAL*8 UIL(LRV,IDIM,NPG),DUIL(LRV,IDIM,NPG) REAL*8 PGSK(LRV,NPG),RPGK(LRV,NPG),AIRE(LRV),ANUK(LRV),COEFK(LRV) REAL*8 AJK(LRV,IDIM,IDIM,NPG) ENDSEGMENT -INC SMMATRIK POINTEUR IPM.IZAFM SEGMENT IMATRS INTEGER LIZAFS(NBSOUS,NBME) ENDSEGMENT POINTEUR IPS1.IZAFM,IPS2.IZAFM,IPS3.IZAFM,IPMS.IZAFM -INC SMTABLE POINTEUR KIZG.TABLE,MTABX.MTABLE,MTABT.MTABLE POINTEUR KINC.TABLE,RESU.MTABLE POINTEUR MTABZ.MTABLE -INC SMLMOTS POINTEUR LINCO.MLMOTS CHARACTER*8 NOMZ,NOMI,NOMA,TYPE,CHAI,TYPC,TYPCFI,NOM CHARACTER*8 NOM0,NOMII,MTYP,NMACO CHARACTER*4 NOM4(3), CELCAR REAL*8 XYZI(24) LOGICAL LOGI PARAMETER (NTB=2) CHARACTER*8 LTAB(NTB) DIMENSION KTAB(NTB),IXV(3) * save ipas * data ipas/1/ C C**** EN VOLUMES FINIS, KONV est un operatéur normal, C (voir KONV1) C i.e. C C JACO RESI DELTAT = 'KONV' 'VF' ... C C***************************************************************************** CKONV C WRITE(6,*)' Opérateur KONV' C C***************************************************************************** C C Deux traitements différents suivant la discrétisation 2D/3D ou 0D C (respectivement, table d'entrée de soustype KIZX C ou de soustype OPER_0D) C segact mcoord C Nouvelle directive EQUA de EQEX MTYP=' ' CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.0)THEN C% On attend un des objets : %m1:8 %m9:16 %m17:24 %m25:32 %m33:40 MOTERR( 1: 8) = 'CHAI ' MOTERR( 9:16) = 'MMODEL ' C MOTERR(17:24) = 'TABLE ' CALL ERREUR(472) RETURN ENDIF IF(MTYP.EQ.'MMODEL')THEN CALL LIRCHA(CHAI,1,IRET) IF(CHAI.EQ. 'VF ')THEN CALL KONV1 GOTO 9999 ENDIF CALL YTCLSF(' C ','KONV ') RETURN ELSEIF(MTYP.EQ.'MOT ')THEN CALL LIRCHA(CHAI,1,IRET) IF(CHAI.EQ. 'VF ')THEN CALL KONV1 GOTO 9999 ELSE CALL YTCLSF(CHAI,'KONV ') ENDIF RETURN ENDIF C Fin Nouvelle directive EQUA de EQEX LTAB(1) = 'KIZX ' LTAB(2) = 'OPER_0D ' KTAB(1) = 0 KTAB(2) = 0 CALL LITABS(LTAB,KTAB,NTB,0,IRET) IF(IRET.EQ.0)THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)' On attend un ensemble de table soustypes' RETURN ENDIF C C Bifurcation en cas de discrétisation 0D C IF (KTAB(1).NE.0) THEN MTABX = KTAB(1) CALL LEKTAB(MTABX,'EQEX',MTAB1) IF(MTAB1.EQ.0)THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)' On ne trouve pas l''indice EQEX ? ' RETURN ENDIF CALL ACME(MTAB1,'NAVISTOK',NASTOK) IF(NASTOK.EQ.0)THEN CALL ZKONV(MTABX,MTAB1) RETURN ENDIF ELSEIF (KTAB(2).NE.0) THEN IPTAB1 = KTAB(2) CALL TOCONV (IPTAB1) RETURN ELSE WRITE(6,*)' Opérateur KONV :' WRITE(6,*)' On attend une table de soustype KIZX ou OPER_0D' RETURN ENDIF C***************************************************************************** C Traitement des options C KIMPL = 0 -> EXPL 1 -> IMPL 2 -> CN C KFORM = 0 -> SI 1 -> EF 2 -> VF 3 -> EFMC C IDCEN = 0 -> rien 1 -> CENTREE 2 -> HU.BR 3 -> SUPG 4 -> T VISQ C C- Récupération de la table des options KOPT (pointeur KOPTI) C CALL LEKTAB(MTABX,'KOPT',KOPTI) IF (KOPTI.EQ.0) THEN C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 MOTERR( 1: 8) = ' KOPT ' MOTERR( 9:16) = ' KOPT ' MOTERR(17:24) = ' KIZX ' CALL ERREUR(786) RETURN ENDIF IAXI=0 IF(IFOMOD.EQ.0)IAXI=2 KDIM=1 CALL ACME(KOPTI,'IDCEN',IDCEN) IF(IDCEN.EQ.2)KDIM=IDIM CALL ACME(KOPTI,'IKOMP',IKOMP) CALL ACME(KOPTI,'KIMPL',KIMPL) CALL ACME(KOPTI,'KFORM',KFORM) CALL ACME(KOPTI,'ISCHT',ISCHT) CALL ACME(KOPTI,'IDIV',IDIV) CALL ACMF(KOPTI,'CMD',CMD) CALL ACME(KOPTI,'KMACO',KMACO) CALL ACMF(KOPTI,'AIMPL',AIMPL) AG=AIMPL AD=AIMPL-1.D0 IF(ISCHT.EQ.2)THEN AG=1.D0 AD=-1.D0 ENDIF IF (IERR.NE.0) RETURN C***************************************************************************** C***************************************************************************** C C ----- Cas d'un schéma Explicite en Volume Fini : C ---------------------------------------- if (KIMPL .EQ. 0 .and. KFORM . EQ. 2) then call ckon(MTABX) RETURN ENDIF C***************************************************************************** C C- Récupération de la table DOMAINE associée au domaine local C CALL ACMM(MTABX,'NOMZONE',NOMZ) MTYP='MMODEL' CALL QUETYP(MTYP,0,IRET) IF(IRET.EQ.1)THEN CALL LIROBJ('MMODEL',MMDZ,1,IRET) ELSE TYPE=' ' CALL ACMO(MTABX,'DOMZ',TYPE,MMDZ) IF(TYPE.NE.'MMODEL')THEN C Indice %m1:8 : Indice %m9:16 non trouvé dans la table %m17:24 MOTERR( 1: 8) = ' DOMZ ' MOTERR( 9:16) = ' DOMZ ' MOTERR(17:24) = ' KIZX ' CALL ERREUR(786) RETURN ENDIF ENDIF C***************************************************************************** C C- Récupération de la table DOMAINE associée au domaine local C C E/ MMODEL : Pointeur de la table contenant l'information cherchée C /S IPOINT : Pointeur sur la table DOMAINE C /S INEFMD : Type formulation INEFMD=1 LINE,=2 MACRO,=3 QUADRATIQUE C INEFMD=4 LINB CALL LEKMOD(MMDZ,MTABZ,INEFMD) CALL LEKTAB(MTABZ,'MAILLAGE',MELEME) CALL LEKTAB(MTABZ,'SOMMET',MELEMS) CALL LEKTAB(MTABZ,'CENTRE',MELEMC) IF (IERR.NE.0) RETURN C************************************************************************* C VERIFICATIONS SUR LES INCONNUES C write(6,*)' Verification des inconnues ' TYPE='LISTMOTS' CALL ACMO(MTABX,'LISTINCO',TYPE,LINCO) SEGACT LINCO NBINC=LINCO.MOTS(/2) IF((NBINC.NE.1).AND.(KFORM.NE.3))THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 1' RETURN ENDIF IF((NBINC.NE.2).AND.(KFORM.EQ.3))THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)'Nombre d''inconnues incorrecte : ',NBINC,' On attend 2' RETURN ENDIF NOMI=LINCO.MOTS(1) IF (KFORM.EQ.3) NOMII=LINCO.MOTS(2) CALL LEKTAB(MTAB1,'INCO',KINC) IF(KINC.EQ.0)THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)'Il n''y a pas de table INCO ? ?.' RETURN ENDIF TYPE=' ' CALL ACMO(KINC,NOMI,TYPE,MCHPOI) IF(TYPE.NE.'CHPOINT ')THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)' L objet CHPOINT ',NOMI,' n existe pas dans la table' RETURN ELSE CALL LICHTL(MCHPOI,IZTU1,TYPC,MELEMI) MCHPIN=MCHPOI IKT=0 ENDIF NINKO=IZTU1.VPOCHA(/2) NPTI = IZTU1.VPOCHA(/1) IF(NINKO.EQ.1)THEN WRITE(NOM4(1),FMT='(A4)')NOMI(1:4) ELSE DO 15 I=1,NINKO WRITE(NOM4(I),FMT='(I1,A3)')I,NOMI(1:3) 15 CONTINUE ENDIF IF (KFORM.EQ.3) THEN TYPE=' ' CALL ACMO(KINC,NOMII,TYPE,MCHPOI) IF(TYPE.NE.'CHPOINT ')THEN WRITE(6,*)' Opérateur KONV :' WRITE(6,*)' L objet CHPOINT ',NOMII, & ' n existe pas dans la table' RETURN ELSE CALL LICHTL(MCHPOI,IZTU2,TYPCFI,IGEOM0) MZPHI=IZTU2 IKT=0 ENDIF END IF C***************************************************************************** C Le domaine de definition est donne par le SPG de la premiere inconnue C Les inconnues suivantes devront posseder ce meme pointeur C On verifie que les points de la zone sont tous inclus dans ce SPG CALL KRIPAD(MELEMI,IPADI) IPADS=IPADI NPTS=NPTI IF(MELEMI.NE.MELEMS)THEN CALL KRIPAD(MELEMS,IPADS) NPTS=MELEMS.NUM(/2) ENDIF IPADU=IPADI NPTU=NPTI * TC mise en commentaired des lignes suivantes car ipasn'est jamais =0 * IF(IPAS.EQ.0)THEN * IF (KFORM.EQ.3) CALL KRIPAD(MELEMC,MLENT1) * CALL VERPAD(IPADI,MELEME,IRET) * IF(IRET.NE.0)THEN * WRITE(6,*)' Opérateur KONV' * WRITE(6,*)' La zone ',NOMZ,' n''est pas incluse dans le domaine' * IPAS=0 * RETURN * ENDIF * ENDIF C***************************************************************************** IF(KFORM.NE.1)THEN C***************************************************************************** C Lecture du ou des coefficients C Type du coefficient : C IK1=0 CHPOINT IK1=1 scalaire IK1=2 vecteur c write(6,*)' Opérateur KONV lecture des coefficients' CALL ACME(MTABX,'IARG',IARG) ICD=0 IF(ISCHT.EQ.2)ICD=1 IF((IARG.LT.(2+ICD).AND.IDCEN.EQ.1) &.OR.(IARG.LT.(3+ICD).AND.IDCEN.LT.4) &.OR.(IARG.LT.(4+ICD).AND.IDCEN.GE.4))THEN WRITE(6,*)' Opérateur KONV : option incompréssible ' WRITE(6,*)' Nombre d''arguments incorrect : ',IARG WRITE(6,*)' On attend 2 ou plus suivant l''option' RETURN ENDIF c write(6,*)' KONV IARG=',iarg,melemc C 1er coefficient Densité IXV(1)=MELEMC IXV(2)=1 IXV(3)=0 CALL LEKCOF('Opérateur KONV :', & MTABX,KINC,1,IXV,MRO,MZRO,NPT1,NC1,IKR,IRET) IF(IRET.EQ.0)GO TO 90 c write(6,*)' Apres LEKCOF' IZTGG2=MZRO IZTGG3=MZRO C 2ème coefficient UN , champ de vitesse transportant IXV(1)=-MELEMS IXV(2)=0 IXV(3)=1 CALL LEKCOF('Opérateur KONV :', & MTABX,KINC,2,IXV,MUN,MZUN,NPTU,NC2,IKU,IRET) IF(IRET.EQ.0)GO TO 90 IF(IKU.EQ.2)IKU=1 IF(IPADS.EQ.0.AND.IKU.EQ.0)CALL KRIPAD(MELEMS,IPADS) IPADU=IPADS IF(ISCHT.EQ.2)THEN C si ISCHT=2 TN-2 ou UN-2 , champ transporte au temps n-2 IXV(1)=-MELEMS IF(NINKO.EQ.1)IXV(1)=MELEMS IXV(2)=0 IXV(3)=1 CALL LEKCOF('Opérateur KONV :', & MTABX,KINC,(2+ICD),IXV,MUN,MZUN2,NPTU,NC2,IKU,IRET) IF(IRET.EQ.0)GO TO 90 IF(IKU.EQ.2)IKU=1 IF(IPADS.EQ.0.AND.IKU.EQ.0)CALL KRIPAD(MELEMS,IPADS) IPADU=IPADS ENDIF IF(IARG.GE.(3+ICD))THEN C 3ème coefficient viscosité IXV(1)=MELEMC IXV(2)=1 IXV(3)=0 CALL LEKCOF('Opérateur KONV :', & MTABX,KINC,(3+ICD),IXV,MMU,MZMU,NPT3,NC3,IKM,IRET) IF(IRET.EQ.0)GO TO 90 ELSE CALL LEKTAB(MTABX,'ARGS3',MMU) CALL LICHTL(MMU,MZMU,TYPC,IGEOM0) MZMU.VPOCHA(1,1)=1.D0 IKM=1 ENDIF IF(IARG.EQ.(4+ICD))THEN C 4ème coefficient Dt IXV(1)=0 IXV(2)=1 IXV(3)=0 CALL LEKCOF('Opérateur KONV :', & MTABX,KINC,(4+ICD),IXV,MDT,MZDT,NPT4,NC4,IKT,IRET) IF(IRET.EQ.0)RETURN DT=MZDT.VPOCHA(1,1) ELSE DT=0.D0 ENDIF c write(6,*)' Opérateur KONV : Fin lecture Arguments ' C Fin lecture Arguments ************************************************ ENDIF C************************************************************************* IF(KFORM.EQ.0)THEN C CAS FORMULATION EF SI (GRESHO) WRITE(6,*)' Operateur KONV ' WRITE(6,*)' Option invalide ' GO TO 90 C************************************************************************* ELSEIF(KFORM.EQ.1)THEN C CAS FORMULATION EF c write(6,*)' On va appeler YCLS ' NINKO=IZTU1.VPOCHA(/2) IHV=0 IF(NINKO.EQ.IDIM)IHV=1 CALL YCLS('KONV ',MTABX,MTABZ,IHV,MCHPIN,NOMI,MATRIK,MCHPO1) CALL ECROBJ('MATRIK',MATRIK) CALL ECROBJ('CHPOINT',MCHPO1) RETURN C************************************************************************* ELSE IF(KFORM.EQ.2)THEN C CAS FORMULATION VF C CALL LEKTAB(MTABZ,'FACE',MELEMF) C CALL LEKTAB(MTABZ,'CENTRE',MELEMC) CALL LEKTAB(MTABZ,'FACEL',MFACEL) CALL LEKTAB(MTABZ,'ELTFA',MELTFA) CALL LEKTAB(MTABZ,'ELKONV',MELEME) C CALL ELCONV(MELTFA,MFACEL,MELEMF,MELEMC,MELEME) SEGACT MELEME NBSOUS=LISOUS(/1) IF(NBSOUS.EQ.0)NBSOUS=1 NRIGE=7 NKID =9 NKMT =7 NMATRI=1 SEGINI MATRIK IRIGEL(1,1)=MELEME IRIGEL(2,1)=MELEMC IRIGEL(7,1)=2 NBOP=0 NBME=NINKO SEGINI IMATRI,IMATRS IRIGEL(4,1)=IMATRI KSPGP=MELEMC KSPGD=MELEMC IF(NBME.EQ.1)THEN LISPRI(1)=NOMI(1:4)//' ' LISDUA(1)=NOMI(1:4)//' ' ELSE DO 202 I=1,NBME WRITE(NOM,FMT='(I1,A7)')I,NOMI(1:7) LISPRI(I)=NOM(1:4)//' ' LISDUA(I)=NOM(1:4)//' ' 202 CONTINUE ENDIF C* Lecture du tableau donnant le sens des normales par element CALL LEKTAB(MTABZ,'XXNORMAE',MCHELM) IF(MCHELM.EQ.0)GO TO 90 SEGACT MCHELM CALL LEKTAB(MTABZ,'XXSURFAC',MCHPO1) CALL LICHTL(MCHPO1,MPOVA1,TYPE,IGEOM) C* Lecture des connectivites elements/faces CALL LEKTAB(MTABZ,'ELTFA',MELEMA) IF(MELEMA.EQ.0)GO TO 90 SEGACT MELEMA CALL KRIPAD(MELEMF,IPADI) IF(IKR.EQ.0)CALL KRIPAD(MELEMC,MLENT1) KK=0 DO 201 L=1,NBSOUS IPT1=MELEME IPT2=MELEMA IF(NBSOUS.NE.1)IPT1=LISOUS(L) IF(NBSOUS.NE.1)IPT2=MELEMA.LISOUS(L) SEGACT IPT1,IPT2 NP = IPT1.NUM(/1) NBF=NP-1 MP = 1 C write(6,*)' np,nbf,mp=',np,nbf,mp NBEL=IPT1.NUM(/2) SEGINI IPM1,IPMS LIZAFM(L,1)=IPM1 LIZAFS(L,1)=IPMS IPM2=IPM1 IPM3=IPM1 IF(NBME.GE.2)THEN LIZAFM(L,2)=IPM1 ENDIF IF(NBME.GE.3)THEN LIZAFM(L,3)=IPM1 ENDIF MCHAML=ICHAML(L) SEGACT MCHAML MELVAL=IELVAL(1) SEGACT MELVAL C write(6,*)' IKR=',ikr IF(IKR.EQ.1)THEN C write(6,*)' NBEL=',NBEL,' NBF=',NBF DO 210 K=1,NBEL DO 211 I=1,NBF NF=IPT2.NUM(I,K) NF=IPADI.LECT(NF) C write(6,*)' NF=',NF,NP FI=IZTGG2.VPOCHA(NF,1)*MELVAL.VELCHE(I,K)*MPOVA1.VPOCHA(NF,1) &*MZRO.VPOCHA(1,1) IF(FI.LE.0.D0)THEN IPM1.AM(K,I,1)=FI ELSE IPM1.AM(K,NP,1)=IPM1.AM(K,NP,1)+FI ENDIF 211 CONTINUE 210 CONTINUE ELSEIF(IKR.EQ.0)THEN DO 212 K=1,NBEL KK=KK+1 DO 213 I=1,NBF NF=IPT2.NUM(I,K) NF=IPADI.LECT(NF) NCR=MLENT1.LECT(KK) FI=IZTGG2.VPOCHA(NF,1)*MELVAL.VELCHE(I,K)*MPOVA1.VPOCHA(NF,1) &*MZRO.VPOCHA(NCR,1) IF(FI.LE.0.D0)THEN IPM1.AM(K,I,1)=FI ELSE IPM1.AM(K,NP,1)=IPM1.AM(K,NP,1)+FI ENDIF 213 CONTINUE 212 CONTINUE ENDIF SEGDES IPT1,IPM1,IPT2 SEGSUP IPMS C write(6,*)' Fin bcl 201 ' 201 CONTINUE C write(6,*)' Apr bcl 201 ' SEGSUP IPADI SEGDES IMATRI SEGSUP IMATRS SEGDES MELEME,MATRIK IF(IKR.EQ.0)THEN SEGSUP MLENT1 SEGDES MRO,MZRO ENDIF CALL ECMO(MTABX,'MATELM','MATRIK',MATRIK) RETURN C************************************************************************ ENDIF C************************************************************************* 90 CONTINUE WRITE(6,*)' Interuption anormale de KONV' 9999 RETURN END