C G2LLG2 SOURCE CHAT 06/03/29 21:21:50 5360 C C SUBROUTINE G2LLG2(IGR1,NBLIG1,NBCOL1, > IGR2,NBLIG2,NBCOL2, > COORD,NBCOOR,IDIMC,INDICE,RAPP, > ITVL,NITMAX, > IGRI,NBLIGI,NBCOLI,ITRACE,iarr) C ********************************************************************** C OBJET G2LLG2 : CREER UNE GRILLE INTERMEDIAIRE (ENTRE 2 GRILLES) C C EN ENTREE : C C IGR1(NBLIG1,NBCOL1) : LA PREMIERE GRILLE C IGR CONTIENT LES NUMEROS DES NOEUDS C IGR2(NBLIG2,NBCOL2) : LA DEUXIEME GRILLE C COORD,NBCOORD,IDIMC : POSITION DES NOEUDS C C RAPP : RAPPORT DES DISTANCES ENTRE LES GRILLES C (IGRI-IGR1) / (IGR2-IGR1) C C ITVL : TABLEAU D'ENTIERS POUR LES CALCULS C NITMAX : TAILLE DE ITVL C ON A BESOIN DU TABLEAU DE TRAVAIL POUR COMPLETER IGR1 C LA PLACE NECESSAIRE EST DE : NBCOL1*NBLIG2 C C EN SORTIE : C C IGRI(NBLIGI,NBCOLI) : GRILLE SURFACIQUE INTERMEDIAIRE C NBLIGI = NBLIG2, NBCOLI = NBCOL1 C C INDICE : DU DERNIER NOEUD CREE C C iarr : CODE D'ERREUR -1 SI DONNEES INCORRECTES C -2 SI TABLEAUX INSUFFISANTS C C REMARQUES : LES GRILLES IGR1 ET IGR2 SONT ORIENTEES DE LA MEME FACON C AVEC UNE ORIGINE COMPATIBLE (VOIR G2ORIG, G2ORIE) C AVEC NBCOL2 >= NBCOL1 ET NBLIG2 <= NBLIG1 C C ********************************************************************** IMPLICIT INTEGER(I-N) INTEGER IGR1(*),NBLIG1,NBCOL1 INTEGER IGR2(*),NBLIG2,NBCOL2 REAL*8 COORD(*),RAPP INTEGER IDIMC,NBCOOR,ITVL(*),NITMAX INTEGER INDICE INTEGER IGRI(*),NBLIGI,NBCOLI,ITRACE,iarr C INTEGER NBCO11,NBLG11,IGR11 INTEGER NBCOAJ(2),INCOAJ(2),NBLGAJ(2),INLGAJ(2),NBAJ(2) INTEGER INDXYZ,INCREM,ITRAV,I,J,K,NUM1,NUM2,IDECAL C REAL*8 COEF,CNBLG,CNBCO, REAL*8 XO,V12 C C =============================================== C --- 0. VERIFICATIONS DES CONDITIONS D'APPLICATION --- C =============================================== IF(NBCOL1.GT.NBCOL2)THEN iarr = -1 CALL DSERRE(1,iarr,'G2LLG2',' INVERSER LES 2 GRILLES ') GOTO 9999 ENDIF C IF( ( MOD(NBCOL1+NBCOL2,2).NE.0 ).OR. > ( MOD(NBLIG1+NBLIG2,2).NE.0 ))THEN iarr = -1 CALL DSERRE(1,iarr,'G2LLG2',' UNE COUCHE INSUFFISANTE ') GOTO 9999 ENDIF C IF((NBCOL1.LE.NBCOL2).AND.(NBLIG1.GE.NBLIG2))THEN iarr = -1 CALL DSERRE(1,iarr,'G2LLG2',' UNE COUCHE SUFFISANTE ') GOTO 9999 ENDIF C IF(ITRACE.GT.0) > CALL ESECHA(1,'-> RACCORD EN 2 COUCHES',' ') C C =============================================== C --- 1. CALCUL DE LA SURFACE INTERMEDIAIRE : GRI --- C GRI -> GR2 : ON AUGMENTE SEULEMENT LES COLONNES C GR1 -> GRI : ON AUGMENTE SEULEMENT LES LIGNES C =============================================== NBLIGI = NBLIG2 NBCOLI = NBCOL1 C ------------------------------------ C ---- 1.1 ON COMPLETE LES LIGNES DE GR1 --- C ------------------------------------ NBAJ(1) = 0 NBAJ(2) = 2 INLGAJ(1) = 1 NBLGAJ(1) = (NBLIG2-NBLIG1) / 2 NBLGAJ(2) = (NBLIG2-NBLIG1) / 2 INLGAJ(2) = -NBLIG1 C IGR11 = 1 ITRAV = 1 IF( NITMAX.LT. (IGR11-1+ NBCOL1*NBLIG2))THEN iarr = -2 CALL DSERRE(1,iarr,'G2LLG2',' POUR COMPLETER LA GRILLE ') CALL ESEINT(1,'PLACE NECESSAIRE ',NBCOL1*NBLIG2,1) GOTO 9999 ENDIF C INDICE = NBCOOR+1 INCREM = 1 IF(ITRACE.GT.0)THEN CALL ESECHA(1,'-> NOUVEAUX NOEUDS',' ') CALL ESEINT(1,'A PARTIR DU NUMERO ',INDICE,1) ENDIF C CALL G2POLC(IGR1,NBLIG1,NBCOL1, > NBAJ,NBCOAJ,INCOAJ,NBLGAJ,INLGAJ, > INDICE,INCREM,COORD,NBCOOR,IDIMC, > ITVL(ITRAV),0, > ITVL(IGR11),NBLG11,NBCO11,iarr) C IF(iarr.NE.0)THEN CALL DSERRE(1,iarr,'G2LLG2',' APPEL G2POLC ') GOTO 9999 ENDIF C IF(ITRACE.GT.0)THEN CALL ESECHA(1,'-> GRILLE 1 COMPLETEE',' ') CALL ESEINT(1,'COLONNES ',NBCO11,1) CALL ESEINT(1,'LIGNES ',NBLG11,1) ENDIF C C ----------------------------------------- C --- 1.2 CREATION D'UNE GRILLE 2D ET COLLAGE --- C ----------------------------------------- C IF(ITRACE.GT.0) > CALL ESECHA(1, > '2. CREATION DE LA GRILLES 3D ET COLLAGE : ',' ') C C CALL G2CRSP( NBLIGI,NBCOLI,INDICE,INCREM,IGRI ) DO 710 JG=1,(NBLIGI*NBCOLI) IGRI(JG)=INDICE INDICE = INDICE + INCREM 710 CONTINUE C ---------------------------- C --- 1.3 INTERPOLATION LINEAIRE C POUR LA GRILLE 2D --- C ---------------------------- C INDXYZ = NBCOOR + 1 IF(ITRACE.GT.0) > CALL ESECHA(1,'-> COORDONNEES GRILLE 2D ',' ') C IDECAL = ( NBCOL2 - NBCOL1 ) / 2 C C --- INTERPOLATION REMPLISSAGE PAR LIGNE --- C DO 110 I=1,NBLG11 NUM1 = ITVL((I-1)*NBCO11+1+IGR11-1) NUM2 = IGR2((I-1)*NBCOL2+1) DO 70 K=1,IDIMC XO = COORD((NUM1-1)*IDIMC+K) V12 = COORD((NUM2-1)*IDIMC+K) - XO COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO 70 CONTINUE INDXYZ = INDXYZ + 1 DO 90 J=2,NBCOL1-1 C CORRECTION DU BUG : 1 => J NUM1 = ITVL((I-1)*NBCO11+J+IGR11-1) NUM2 = IGR2((I-1)*NBCOL2+J+IDECAL) DO 80 K=1,IDIMC XO = COORD((NUM1-1)*IDIMC+K) V12 = COORD((NUM2-1)*IDIMC+K) - XO COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO 80 CONTINUE INDXYZ = INDXYZ + 1 90 CONTINUE NUM1 = ITVL(I*NBCO11+IGR11-1) NUM2 = IGR2(I*NBCOL2) DO 100 K=1,IDIMC XO = COORD((NUM1-1)*IDIMC+K) V12 = COORD((NUM2-1)*IDIMC+K) - XO COORD((INDXYZ-1)*IDIMC+K) = V12*RAPP + XO 100 CONTINUE INDXYZ = INDXYZ + 1 110 CONTINUE C C 9999 END