SUBROUTINE FILT25(ZI,TM,IPASS) !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . . ! SUBPROGRAM: FILTER FILTERS THE ARRAY ZI ! PRGMMR: DIMEGO ORG: W/NP22 DATE: 86-07-18 ! ABSTRACT: FILTERS AN ARRAY USING A 25PT BLECK FILTER IN THE ! INTERIOR OF THE DOMAIN ! PROGRAM HISTORY LOG: ! 86-07-18 G DIMEGO - ORIGINATOR ! 88-09-23 B SCHMIDT - ADDED THE DOCBLOCK ! 90-11-27 G DIMEGO - LEFT Z AS INTERNAL WORK ARRAY ON CRAY ! 93-06-21 R TREADON - STREAMLINED CODE ! 95-06-21 T BLACK - MODIFIED FOR THE E-GRID ! 99-08-25 T BLACK - MODIFIED FOR DISTRIBUTED MEMORY ! USAGE: CALL FILTER (IDIM1,IDIM2,JDIM1,JDIM2,ZI,IPASS) ! INPUT ARGUMENT LIST: ! ZI - ARRAY CONTAINING THE ARRAY TO BE FILTERED ! TM - ARRAY CONTAINING THE TOPOGRAPHY MASK ! IPASS - NUMBER OF PASSES THROUGH THE FILTER ! OUTPUT ARGUMENT LIST: ! ZI - ARRAY CONTAINING THE FILTERED FIELD ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE: IBM SP !$$$ !---------------------------------------------------------------- INCLUDE "EXCHM.h" INCLUDE "parmeta.f90" INCLUDE "mpp.h" !---------------------------------------------------------------- INCLUDE "COMM_INDX.f90" !---------------------------------------------------------------- REAL :: ZI(IDIM1:IDIM2,JDIM1:JDIM2),Z(IDIM1:IDIM2,JDIM1:JDIM2) REAL :: TM(IDIM1:IDIM2,JDIM1:JDIM2) DATA CF1/0.279372/,CF2/0.171943/,CF3/-0.006918/ & , CF4/0.077458/,CF5/-0.024693/,CF6/-0.012940/ !---------------------------------------------------------------- IPC=IPASS DO J=JDIM1,JDIM2 DO I=IDIM1,IDIM2 Z(I,J)=0. ENDDO ENDDO !*** !*** FILTER THE INTERIOR POINTS WITH 25-PT BLECK FILTER !*** DO 105 IP=1,IPC ! omp parallel do private(htot,i,iihe,iihw,rsumh,sumh) DO 102 J=MYJS4,MYJE4 DO 101 I=MYIS2,MYIE2 IIHE=I+IHE(J) IIHW=I+IHW(J) ! if(mype.eq.6.and.i.eq.16.and.j.eq.34)then ! write(6,12345)tm(i,j),ihe(j),ihw(j),l ! write(6,12346)tm(IIHW,J-1),tm(IIHE,J-1),tm(IIHE,J+1), ! 1 tm(IIHW,J+1) ! write(6,12347)tm(I-1,J-2),tm(I+1,J-2),tm(I+1,J+2), ! 1 tm(I-1,J+2) ! write(6,12348)tm(I,J-2),tm(I,J+2),tm(I+1,J), ! 1 tm(I-1,J) ! write(6,12349)tm(IIHE,J-3),tm(IIHE+1,J-1),tm(IIHW,J-3), ! 1 tm(IIHE+1,J+1) ! write(6,12350)tm(IIHW-1,J-1),tm(IIHE,J+3),tm(IIHW-1,J+1), ! 1 tm(IIHW,J+3) ! write(6,12351)tm(I,J-4),tm(I+2,J),tm(I-2,J), ! 1 tm(I,J+4) 12345 format(' mask=',f2.0,' ihe=',i2,' ihw=',i2,' l=',i2) 12346 format(' 2nd row=',4(1x,f2.0)) 12347 format(' 3rd row=',4(1x,f2.0)) 12348 format(' 4th row=',4(1x,f2.0)) 12349 format(' 5th row=',4(1x,f2.0)) 12350 format(' 6th row=',4(1x,f2.0)) 12351 format(' 7th row=',4(1x,f2.0)) ! endif HTOT=TM(I,J) & +TM(IIHW,J-1)+TM(IIHE,J-1)+TM(IIHE,J+1)+TM(IIHW,J+1) & +TM(I-1,J-2)+TM(I+1,J-2)+TM(I+1,J+2)+TM(I-1,J+2) & +TM(I,J-2)+TM(I,J+2)+TM(I+1,J)+TM(I-1,J) & +TM(IIHE,J-3)+TM(IIHE+1,J-1)+TM(IIHW,J-3)+TM(IIHE+1,J+1) & +TM(IIHW-1,J-1)+TM(IIHE,J+3)+TM(IIHW-1,J+1)+TM(IIHW,J+3) & +TM(I,J-4)+TM(I+2,J)+TM(I-2,J)+TM(I,J+4) IF(HTOT > 0.)THEN SUMH=CF1*TM(I,J) & +CF2*(TM(IIHW,J-1)+TM(IIHE,J-1)+TM(IIHE,J+1)+TM(IIHW,J+1)) & +CF3*(TM(I-1,J-2)+TM(I+1,J-2)+TM(I+1,J+2)+TM(I-1,J+2)) & +CF4*(TM(I,J-2)+TM(I,J+2)+TM(I+1,J)+TM(I-1,J)) & +CF5*(TM(IIHE,J-3)+TM(IIHE+1,J-1)+TM(IIHW,J-3)+TM(IIHE+1,J+1) & +TM(IIHW-1,J-1)+TM(IIHE,J+3)+TM(IIHW-1,J+1)+TM(IIHW,J+3)) & +CF6*(TM(I,J-4)+TM(I+2,J)+TM(I-2,J)+TM(I,J+4)) RSUMH=1./SUMH Z(I,J)=(CF1*ZI(I,J)*TM(I,J) & +CF2*(ZI(IIHW,J-1)*TM(IIHW,J-1)+ZI(IIHE,J-1)*TM(IIHE,J-1) & +ZI(IIHE,J+1)*TM(IIHE,J+1)+ZI(IIHW,J+1)*TM(IIHW,J+1)) & +CF3*(ZI(I-1,J-2)*TM(I-1,J-2)+ZI(I+1,J-2)*TM(I+1,J-2) & +ZI(I+1,J+2)*TM(I+1,J+2)+ZI(I-1,J+2)*TM(I-1,J+2)) & +CF4*(ZI(I,J-2)*TM(I,J-2)+ZI(I,J+2)*TM(I,J+2) & +ZI(I+1,J)*TM(I+1,J)+ZI(I-1,J)*TM(I-1,J)) & +CF5*(ZI(IIHE,J-3)*TM(IIHE,J-3)+ZI(IIHE+1,J-1)*TM(IIHE+1,J-1) & +ZI(IIHW,J-3)*TM(IIHW,J-3)+ZI(IIHE+1,J+1)*TM(IIHE+1,J+1) & +ZI(IIHW-1,J-1)*TM(IIHW-1,J-1)+ZI(IIHE,J+3)*TM(IIHE,J+3) & +ZI(IIHW-1,J+1)*TM(IIHW-1,J+1)+ZI(IIHW,J+3)*TM(IIHW,J+3)) & +CF6*(ZI(I,J-4)*TM(I,J-4)+ZI(I+2,J)*TM(I+2,J) & +ZI(I-2,J)*TM(I-2,J)+ZI(I,J+4)*TM(I,J+4))) & *RSUMH ENDIF 101 END DO 102 END DO ! omp parallel do DO J=MYJS4,MYJE4 DO I=MYIS2,MYIE2 IF(TM(I,J) > 0.5)THEN ZI(I,J)=Z(I,J) ENDIF ENDDO ENDDO CALL EXCH(ZI,1,4,4) 105 END DO RETURN END SUBROUTINE FILT25