source: codes/icosagcm/devel/src/vertical/vertical_remap.f90 @ 947

Last change on this file since 947 was 947, checked in by jisesh, 5 years ago

devel: Nudging external data and vertical interpolatiion
File size: 5.0 KB
Line 
1MODULE vertical_remap_mod
2  USE icosa
3  USE omp_para
4  IMPLICIT NONE
5  PRIVATE
6PUBLIC vertical_remap_extdata,compute_vertical_remap_extdata
7
8  PUBLIC :: vertical_remap
9
10CONTAINS
11
12   
13  SUBROUTINE vertical_remap(pressure_level,field_in,f_ps,field_out)
14    USE compute_pression_mod, ONLY : pression
15    REAL(rstd), INTENT(IN) :: pressure_level(:)
16    TYPE(t_field),POINTER :: field_in(:)
17    TYPE(t_field),POINTER :: f_ps(:)
18    TYPE(t_field),POINTER :: field_out(:)
19
20    TYPE(t_field),POINTER,SAVE :: f_p(:)
21    REAL(rstd),POINTER :: in(:,:)
22    REAL(rstd),POINTER :: out(:,:)
23    REAL(rstd),POINTER :: p(:,:)
24   
25    INTEGER :: ind
26
27    CALL allocate_field(f_p,field_t,type_real,llm+1)
28    CALL pression(f_ps,f_p)
29 
30    DO ind=1,ndomain
31      IF (.NOT. assigned_domain(ind)) CYCLE
32      CALL swap_dimensions(ind)
33      CALL swap_geometry(ind)
34      p=f_p(ind)
35      in=field_in(ind)
36      out=field_out(ind)
37      CALL compute_vertical_remap(pressure_level,in,p,out)
38    ENDDO
39   
40  END SUBROUTINE  vertical_remap
41
42  SUBROUTINE compute_vertical_remap(pressure_level,in,p,out)
43    REAL(rstd),INTENT(IN)  :: pressure_level(:)
44    REAL(rstd),INTENT(IN)  :: in(:,:)
45    REAL(rstd),INTENT(IN)  :: p(iim*jjm,llm+1)
46    REAL(rstd),INTENT(OUT) :: out(iim*jjm,llm)
47    REAL(rstd) :: coeff, pmid
48    INTEGER :: i,j,ij,l,n,nb_level
49    INTEGER :: a
50    INTEGER :: b
51    LOGICAL :: positive
52   
53    nb_level=size(pressure_level)
54    IF (pressure_level(1)>=pressure_level(nb_level)) THEN
55      positive=.FALSE.
56    ELSE
57      positive=.TRUE.
58    ENDIF
59     
60 !$OMP BARRIER   
61    IF (is_omp_level_master) THEN
62   
63    DO l=1,llm
64      DO j=jj_begin,jj_end
65        DO i=ii_begin,ii_end
66          ij=(j-1)*iim+i
67          pmid=0.5*(p(ij,l)+p(ij,l+1))
68          IF (positive) THEN
69            a=0
70            DO n=1,nb_level-1
71              IF ( (pmid>=pressure_level(n) .AND. pmid<pressure_level(n+1))) THEN
72               a=n ; b=n+1 ; EXIT
73              ENDIF
74            ENDDO
75            IF (a==0) THEN
76              IF (pmid<=pressure_level(1)) THEN
77                a=1 ; b=2
78              ELSE
79                a=nb_level-1 ; b=nb_level
80              ENDIF
81            ENDIF
82          ELSE
83            a=0
84            DO n=1,nb_level-1
85              IF ( (pmid<=pressure_level(n) .AND. pmid>pressure_level(n+1))) THEN
86               a=n ; b=n+1 ; EXIT
87              ENDIF
88            ENDDO
89           
90            IF (a==0) THEN
91              IF (pmid >= pressure_level(1)) THEN
92                a=1 ; b=2
93              ELSE
94                a=nb_level-1 ; b=nb_level
95              ENDIF
96            ENDIF
97          ENDIF
98                 
99          coeff=(pmid-pressure_level(a))/(pressure_level(a)-pressure_level(b))
100          out(ij,l)=in(ij,a)+coeff*(in(ij,a)-in(ij,b))
101        ENDDO
102      ENDDO
103    ENDDO
104 
105    ENDIF
106 !$OMP BARRIER   
107       
108  END SUBROUTINE compute_vertical_remap
109
110  SUBROUTINE vertical_remap_extdata(field_in,f_target_pressure,field_out)
111  USE icosa
112  USE pression_mod
113  USE omp_para
114  USE disvert_mod, ONLY : presnivs
115
116  IMPLICIT NONE
117    TYPE(t_field),POINTER :: field_in(:) 
118    TYPE(t_field),POINTER :: field_out(:)
119    TYPE(t_field),POINTER :: f_target_pressure(:)
120
121    REAL(rstd),POINTER :: target_pressure(:,:)
122    REAL(rstd),POINTER :: in(:,:)
123    REAL(rstd),POINTER :: out(:,:)
124    INTEGER :: ind
125
126    DO ind=1,ndomain
127      IF (.NOT. assigned_domain(ind)) CYCLE
128      CALL swap_dimensions(ind)
129      CALL swap_geometry(ind)
130      in=field_in(ind)
131      out=field_out(ind)
132      target_pressure=f_target_pressure(ind)
133      CALL compute_vertical_remap_extdata(in,target_pressure,out)
134    ENDDO
135
136  END SUBROUTINE vertical_remap_extdata
137
138  SUBROUTINE compute_vertical_remap_extdata(in,target_pressure,out2d_press)
139  USE omp_para
140  USE disvert_mod, ONLY : presnivs 
141  IMPLICIT NONE
142    REAL(rstd),INTENT(IN)  :: in(:,:)
143    REAL(rstd),INTENT(IN)  :: target_pressure(iim*jjm,llm+1) 
144    REAL(rstd),INTENT(OUT) :: out2d_press(iim*jjm,llm+1)
145    REAL(rstd) :: coeff, target_pval,testp1,testp2
146    INTEGER :: i,j,ij,l,n,nb_level
147    INTEGER :: a
148    INTEGER :: b
149    LOGICAL :: positive
150   
151    nb_level=size(presnivs)
152 !$OMP BARRIER   
153    IF (is_omp_level_master) THEN
154    DO l=1,llm
155      DO j=jj_begin,jj_end
156        DO i=ii_begin,ii_end
157          ij=(j-1)*iim+i
158          target_pval=target_pressure(ij,l)
159            a=0
160            DO n=1,nb_level-1
161              IF ( (target_pval<=presnivs(n) .AND. target_pval>=presnivs(n+1))) THEN
162               testp1=presnivs(n); testp2=presnivs(n+1)
163               a=n ; b=n+1 ; EXIT
164              ENDIF
165            ENDDO
166            IF (a==0) THEN
167              IF (target_pval>=presnivs(1)) THEN
168                a=1 ; b=2
169              ELSE
170                a=nb_level-1 ; b=nb_level
171              ENDIF
172            ENDIF
173
174          coeff=(target_pval-presnivs(a))/(presnivs(a)-presnivs(b))
175          out2d_press(ij,l)=in(ij,a)+coeff*(in(ij,a)-in(ij,b))
176        ENDDO
177      ENDDO
178    ENDDO
179
180    ENDIF
181 !$OMP BARRIER   
182
183  END SUBROUTINE compute_vertical_remap_extdata
184
185
186
187END MODULE vertical_remap_mod
Note: See TracBrowser for help on using the repository browser.