Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Normal
Revision Log

sint.F @ 3026

Last change on this file since 3026 was 2759, checked in by aslmd, 3 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 20.1 KB

Rev	Line
[2759]	1
	2	SUBROUTINE SINT(XF, &
	3	ims, ime, jms, jme, icmask , &
	4	its, ite, jts, jte, nf, xstag, ystag )
	5	IMPLICIT NONE
	6	INTEGER ims, ime, jms, jme, &
	7	its, ite, jts, jte
	8
	9	LOGICAL icmask( ims:ime, jms:jme )
	10	LOGICAL xstag, ystag
	11
	12	INTEGER nf, ior
	13	REAL one12, one24, ep
	14	PARAMETER(one12=1./12.,one24=1./24.)
	15	PARAMETER(ior=2)
	16	!
	17	REAL XF(ims:ime,jms:jme,NF)
	18	!
	19	REAL Y(ims:ime,jms:jme,-IOR:IOR), &
	20	Z(ims:ime,jms:jme,-IOR:IOR), &
	21	F(ims:ime,jms:jme,0:1)
	22	!
	23	INTEGER I,J,II,JJ,IIM
	24	INTEGER N2STAR, N2END, N1STAR, N1END
	25	!
	26	DATA EP/ 1.E-10/
	27
	28	REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)
	29	REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)
	30	REAL FL(ims:ime,jms:jme,0:1)
	31	REAL XIG(NFNF), XJG(NFNF) ! NF is parent to child grid refinement ratio
	32	INTEGER IFRST
	33	integer rr
	34	COMMON /DEPAR2/ IFRST
	35	DATA IFRST /1/
	36
	37	REAL rioff, rjoff
	38	!
	39	REAL donor, y1, y2, a
	40	DONOR(Y1,Y2,A)=(Y1AMAX1(0.,SIGN(1.,A))-Y2AMIN1(0.,SIGN(1.,A)))*A
	41	REAL tr4, ym1, y0, yp1, yp2
	42	TR4(YM1,Y0,YP1,YP2,A)=AONE12(7.*(YP1+Y0)-(YP2+YM1)) &
	43	-AAONE24(15.(YP1-Y0)-(YP2-YM1))-AAAONE12((YP1+Y0) &
	44	-(YP2+YM1))+AAAAONE24(3.(YP1-Y0)-(YP2-YM1))
	45	REAL pp, pn, x
	46	PP(X)=AMAX1(0.,X)
	47	PN(X)=AMIN1(0.,X)
	48
	49	rr = nint(sqrt(float(nf)))
	50	!! write(6,*) ' nf, rr are ',nf,rr
	51
	52	rioff = 0
	53	rjoff = 0
	54	if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
	55	if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
	56
	57	DO I=1,rr
	58	DO J=1,rr
	59	XIG(J+(I-1)rr)=(float(rr)-1.-rioff)/float(2rr)-FLOAT(J-1)*1./float(rr)
	60	XJG(J+(I-1)rr)=(float(rr)-1.-rjoff)/float(2rr)-FLOAT(I-1)*1./float(rr)
	61	ENDDO
	62	ENDDO
	63	IFRST = 0
	64
	65	N2STAR = jts
	66	N2END = jte
	67	N1STAR = its
	68	N1END = ite
	69
	70	DO 2000 IIM=1,NF
	71	!
	72	! HERE STARTS RESIDUAL ADVECTION
	73	!
	74	DO 9000 JJ=N2STAR,N2END
	75	DO 50 J=-IOR,IOR
	76
	77	DO 51 I=-IOR,IOR
	78	DO 511 II=N1STAR,N1END
	79	IF ( icmask(II,JJ) ) Y(II,JJ,I)=XF(II+I,JJ+J,IIM)
	80	511 CONTINUE
	81	51 CONTINUE
	82
	83	DO 811 II=N1STAR,N1END
	84	IF ( icmask(II,JJ) ) THEN
	85	FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))
	86	FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))
	87	ENDIF
	88	811 CONTINUE
	89	DO 812 II=N1STAR,N1END
	90	IF ( icmask(II,JJ) ) W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
	91	812 CONTINUE
	92	DO 813 II=N1STAR,N1END
	93	IF ( icmask(II,JJ) ) THEN
	94	MXM(II,JJ)= &
	95	AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1), &
	96	W(II,JJ))
	97	MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
	98	ENDIF
	99	813 CONTINUE
	100	DO 312 II=N1STAR,N1END
	101	IF ( icmask(II,JJ) ) THEN
	102	F(II,JJ,0)= &
	103	TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0), &
	104	Y(II,JJ,1),XIG(IIM))
	105	F(II,JJ,1)= &
	106	TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
	107	XIG(IIM))
	108	ENDIF
	109	312 CONTINUE
	110	DO 822 II=N1STAR,N1END
	111	IF ( icmask(II,JJ) ) THEN
	112	F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
	113	F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
	114	ENDIF
	115	822 CONTINUE
	116	DO 823 II=N1STAR,N1END
	117	IF ( icmask(II,JJ) ) THEN
	118	OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ &
	119	PP(F(II,JJ,0))+EP)
	120	UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))- &
	121	PN(F(II,JJ,0))+EP)
	122	ENDIF
	123	823 CONTINUE
	124	DO 824 II=N1STAR,N1END
	125	IF ( icmask(II,JJ) ) THEN
	126	F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+ &
	127	PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))
	128	F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+ &
	129	PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))
	130	ENDIF
	131	824 CONTINUE
	132	DO 825 II=N1STAR,N1END
	133	IF ( icmask(II,JJ) ) THEN
	134	Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
	135	ENDIF
	136	825 CONTINUE
	137	DO 361 II=N1STAR,N1END
	138	IF ( icmask(II,JJ) ) Z(II,JJ,J)=Y(II,JJ,0)
	139	361 CONTINUE
	140	!
	141	! END IF FIRST J LOOP
	142	!
	143	8000 CONTINUE
	144	50 CONTINUE
	145
	146	DO 911 II=N1STAR,N1END
	147	IF ( icmask(II,JJ) ) THEN
	148	FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))
	149	FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))
	150	ENDIF
	151	911 CONTINUE
	152	DO 912 II=N1STAR,N1END
	153	IF ( icmask(II,JJ) ) W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
	154	912 CONTINUE
	155	DO 913 II=N1STAR,N1END
	156	IF ( icmask(II,JJ) ) THEN
	157	MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
	158	MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
	159	ENDIF
	160	913 CONTINUE
	161	DO 412 II=N1STAR,N1END
	162	IF ( icmask(II,JJ) ) THEN
	163	F(II,JJ,0)= &
	164	TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
	165	,XJG(IIM))
	166	F(II,JJ,1)= &
	167	TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2), &
	168	XJG(IIM))
	169	ENDIF
	170	412 CONTINUE
	171	DO 922 II=N1STAR,N1END
	172	IF ( icmask(II,JJ) ) THEN
	173	F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
	174	F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
	175	ENDIF
	176	922 CONTINUE
	177	DO 923 II=N1STAR,N1END
	178	IF ( icmask(II,JJ) ) THEN
	179	OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ &
	180	PP(F(II,JJ,0))+EP)
	181	UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
	182	EP)
	183	ENDIF
	184	923 CONTINUE
	185	DO 924 II=N1STAR,N1END
	186	IF ( icmask(II,JJ) ) THEN
	187	F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0)) &
	188	*AMIN1(1.,UN(II,JJ))
	189	F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1)) &
	190	*AMIN1(1.,OV(II,JJ))
	191	ENDIF
	192	924 CONTINUE
	193	9000 CONTINUE
	194	DO 925 JJ=N2STAR,N2END
	195	DO 925 II=N1STAR,N1END
	196	IF ( icmask(II,JJ) ) XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
	197	925 CONTINUE
	198
	199	!
	200	2000 CONTINUE
	201	RETURN
	202	END
	203
	204	! Version of sint that replaces mask with detailed ranges for avoiding boundaries
	205	! may help performance by getting the conditionals out of innner loops
	206
	207	SUBROUTINE SINTB(XF1, XF , &
	208	ims, ime, jms, jme, icmask , &
	209	its, ite, jts, jte, nf, xstag, ystag )
	210	IMPLICIT NONE
	211	INTEGER ims, ime, jms, jme, &
	212	its, ite, jts, jte
	213
	214	LOGICAL icmask( ims:ime, jms:jme )
	215	LOGICAL xstag, ystag
	216
	217	INTEGER nf, ior
	218	REAL one12, one24, ep
	219	PARAMETER(one12=1./12.,one24=1./24.)
	220	PARAMETER(ior=2)
	221	!
	222	REAL XF(ims:ime,jms:jme,NF)
	223	REAL XF1(ims:ime,jms:jme,NF)
	224	!
	225	REAL Y(ims:ime,jms:jme,-IOR:IOR), &
	226	Z(ims:ime,jms:jme,-IOR:IOR), &
	227	F(ims:ime,jms:jme,0:1)
	228	!
	229	INTEGER I,J,II,JJ,IIM
	230	INTEGER N2STAR, N2END, N1STAR, N1END
	231	!
	232	DATA EP/ 1.E-10/
	233	!
	234	! PARAMETER(NONOS=1)
	235	! PARAMETER(N1OS=N1NONOS+1-NONOS,N2OS=N2NONOS+1-NONOS)
	236	!
	237	REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme)
	238	REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme)
	239	REAL FL(ims:ime,jms:jme,0:1)
	240	REAL XIG(NFNF), XJG(NFNF) ! NF is the parent to child grid refinement ratio
	241	INTEGER IFRST
	242	integer rr
	243	COMMON /DEPAR2B/ IFRST
	244	DATA IFRST /1/
	245
	246	REAL rioff, rjoff
	247	!
	248	REAL donor, y1, y2, a
	249	DONOR(Y1,Y2,A)=(Y1AMAX1(0.,SIGN(1.,A))-Y2AMIN1(0.,SIGN(1.,A)))*A
	250	REAL tr4, ym1, y0, yp1, yp2
	251	TR4(YM1,Y0,YP1,YP2,A)=AONE12(7.*(YP1+Y0)-(YP2+YM1)) &
	252	-AAONE24(15.(YP1-Y0)-(YP2-YM1))-AAAONE12((YP1+Y0) &
	253	-(YP2+YM1))+AAAAONE24(3.(YP1-Y0)-(YP2-YM1))
	254	REAL pp, pn, x
	255	PP(X)=AMAX1(0.,X)
	256	PN(X)=AMIN1(0.,X)
	257
	258	rr = nint(sqrt(float(nf)))
	259
	260	rioff = 0
	261	rjoff = 0
	262	if(xstag .and. (mod(rr,2) .eq. 0)) rioff = 1.
	263	if(ystag .and. (mod(rr,2) .eq. 0)) rjoff = 1.
	264
	265	DO I=1,rr
	266	DO J=1,rr
	267	XIG(J+(I-1)rr)=(float(rr)-1.-rioff)/float(2rr)-FLOAT(J-1)*1./float(rr)
	268	XJG(J+(I-1)rr)=(float(rr)-1.-rjoff)/float(2rr)-FLOAT(I-1)*1./float(rr)
	269	ENDDO
	270	ENDDO
	271	IFRST = 0
	272
	273	N2STAR = jts
	274	N2END = jte
	275	N1STAR = its
	276	N1END = ite
	277
	278	DO 2000 IIM=1,NF
	279	!
	280	! HERE STARTS RESIDUAL ADVECTION
	281	!
	282	DO 9000 JJ=N2STAR,N2END
	283	!cdir unroll=5
	284	DO 50 J=-IOR,IOR
	285
	286	!cdir unroll=5
	287	DO 51 I=-IOR,IOR
	288	DO 511 II=N1STAR,N1END
	289	Y(II,JJ,I)=XF1(II+I,JJ+J,IIM)
	290	511 CONTINUE
	291	51 CONTINUE
	292
	293	DO 811 II=N1STAR,N1END
	294	FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM))
	295	FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM))
	296	811 CONTINUE
	297	DO 812 II=N1STAR,N1END
	298	W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
	299	812 CONTINUE
	300	DO 813 II=N1STAR,N1END
	301	MXM(II,JJ)= &
	302	AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1), &
	303	W(II,JJ))
	304	MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ))
	305	813 CONTINUE
	306	DO 312 II=N1STAR,N1END
	307	F(II,JJ,0)= &
	308	TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0), &
	309	Y(II,JJ,1),XIG(IIM))
	310	F(II,JJ,1)= &
	311	TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),&
	312	XIG(IIM))
	313	312 CONTINUE
	314	DO 822 II=N1STAR,N1END
	315	F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
	316	F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
	317	822 CONTINUE
	318	DO 823 II=N1STAR,N1END
	319	OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ &
	320	PP(F(II,JJ,0))+EP)
	321	UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))- &
	322	PN(F(II,JJ,0))+EP)
	323	823 CONTINUE
	324	DO 824 II=N1STAR,N1END
	325	F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+ &
	326	PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ))
	327	F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+ &
	328	PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ))
	329	824 CONTINUE
	330	DO 825 II=N1STAR,N1END
	331	Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
	332	825 CONTINUE
	333	DO 361 II=N1STAR,N1END
	334	Z(II,JJ,J)=Y(II,JJ,0)
	335	361 CONTINUE
	336	!
	337	! END IF FIRST J LOOP
	338	!
	339	8000 CONTINUE
	340	50 CONTINUE
	341
	342	DO 911 II=N1STAR,N1END
	343	FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM))
	344	FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM))
	345	911 CONTINUE
	346	DO 912 II=N1STAR,N1END
	347	W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0))
	348	912 CONTINUE
	349	DO 913 II=N1STAR,N1END
	350	MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
	351	MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ))
	352	913 CONTINUE
	353	DO 412 II=N1STAR,N1END
	354	F(II,JJ,0)= &
	355	TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)&
	356	,XJG(IIM))
	357	F(II,JJ,1)= &
	358	TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2), &
	359	XJG(IIM))
	360	412 CONTINUE
	361	DO 922 II=N1STAR,N1END
	362	F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0)
	363	F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1)
	364	922 CONTINUE
	365	DO 923 II=N1STAR,N1END
	366	OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ &
	367	PP(F(II,JJ,0))+EP)
	368	UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ &
	369	EP)
	370	923 CONTINUE
	371	DO 924 II=N1STAR,N1END
	372	F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0)) &
	373	*AMIN1(1.,UN(II,JJ))
	374	F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1)) &
	375	*AMIN1(1.,OV(II,JJ))
	376	924 CONTINUE
	377	9000 CONTINUE
	378	DO 925 JJ=N2STAR,N2END
	379	DO 925 II=N1STAR,N1END
	380	XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0))
	381	925 CONTINUE
	382
	383	!
	384	2000 CONTINUE
	385	RETURN
	386	END
	387
	388

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format