source: LMDZ.3.3/trunk/libf/dyn3d/iniinterp_horizFF @ 507

Last change on this file since 507 was 2, checked in by lmdz, 25 years ago

Initial revision

  • Property svn:eol-style set to native
  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 5.1 KB
Line 
1      subroutine iniinterp_horiz (imo,jmo,imn,jmn ,kllm,
2     &       rlonuo,rlatvo,rlonun,rlatvn,
3     &       ktotal,iik,jjk,jk,ik,intersec,airen)
4   
5      implicit none
6
7
8
9c ---------------------------------------------------------
10c Prepare l' interpolation des variables d'une grille LMDZ
11c  dans une autre grille LMDZ en conservant la quantite
12c  totale pour les variables intensives (/m2) : ex : Pression au sol
13c
14c   (Pour chaque case autour d'un point scalaire de la nouvelle
15c    grille, on calcule la surface (en m2)en intersection avec chaque
16c    case de l'ancienne grille , pour la future interpolation)
17c
18c on calcule aussi l' aire dans la nouvelle grille
19c
20c
21c   Auteur:  F.Forget 01/1995
22c   -------
23c
24c ---------------------------------------------------------
25c   Declarations:
26c ==============
27c
28c  ARGUMENTS
29c  """""""""
30c INPUT
31       integer imo, jmo ! dimensions ancienne grille
32       integer imn,jmn  ! dimensions nouvelle grille
33       integer kllm ! taille du tableau des intersections
34       real rlonuo(imo+1)     !  Latitude et
35       real rlatvo(jmo)       !  longitude des
36       real rlonun(imn+1)     !  bord des
37       real rlatvn(jmn)     !  cases "scalaires" (input)
38
39c OUTPUT
40       integer ktotal ! nombre totale d'intersections reperees
41       integer iik(kllm), jjk(kllm),jk(kllm),ik(kllm)
42       real intersec(kllm)  ! surface des intersections (m2)
43       real airen (imn+1,jmn+1) ! aire dans la nouvelle grille
44
45
46       
47 
48c Autres variables
49c """"""""""""""""
50       integer i,j,ii,jj,k
51       real a(imo+1),b(imo+1),c(jmo+1),d(jmo+1)
52       real an(imn+1),bn(imn+1),cn(jmn+1),dn(jmn+1)
53       real aa, bb,cc,dd
54       real pi
55
56       pi      = 2.*ASIN( 1. )
57
58
59
60c On repere les frontieres des cases :
61c ===================================
62c
63c Attention, on ruse avec des latitudes = 90 deg au pole.
64
65
66c  ANcienne grile
67c  """"""""""""""
68      a(1) =   - rlonuo(imo+1)
69      b(1) = rlonuo(1)
70      do i=2,imo+1
71         a(i) = rlonuo(i-1)
72         b(i) =  rlonuo(i)
73      end do
74
75      d(1) = pi/2
76      do j=1,jmo
77         c(j) = rlatvo(j)
78         d(j+1) = rlatvo(j)
79      end do
80      c(jmo+1) = -pi/2
81     
82
83c  Nouvelle grille
84c  """""""""""""""
85      an(1) =  - rlonun(imn+1)
86      bn(1) = rlonun(1)
87      do i=2,imn+1
88         an(i) = rlonun(i-1)
89         bn(i) =  rlonun(i)
90      end do
91
92      dn(1) = pi/2
93      do j=1,jmn
94         cn(j) = rlatvn(j)
95         dn(j+1) = rlatvn(j)
96      end do
97      cn(jmn+1) = -pi/2
98
99c Calcul de la surface des cases scalaires de la nouvelle grille
100c ==============================================================
101      do ii=1,imn + 1
102        do jj = 1,jmn+1
103               airen(ii,jj) = (bn(ii)-an(ii))*(sin(dn(jj))-sin(cn(jj)))
104        end do
105      end do
106
107c Calcul de la surface des intersections
108c ======================================
109
110c     boucle sur la nouvelle grille
111c     """"""""""""""""""""""""""""
112      ktotal = 0
113      do jj = 1,jmn+1
114       do j=1, jmo+1
115          if((cn(jj).lt.d(j)).and.(dn(jj).gt.c(j)))then
116              do ii=1,imn + 1
117                do i=1, imo +1
118                    if (  ((an(ii).lt.b(i)).and.(bn(ii).gt.a(i)))
119     &        .or. ((an(ii).lt.b(i)-2*pi).and.(bn(ii).gt.a(i)-2*pi)
120     &             .and.(b(i)-2*pi.lt.-pi) )
121     &        .or. ((an(ii).lt.b(i)+2*pi).and.(bn(ii).gt.a(i)+2*pi)
122     &             .and.(a(i)+2*pi.gt.pi) )
123     &                     )then
124                      ktotal = ktotal +1
125                      iik(ktotal) =ii
126                      jjk(ktotal) =jj
127                      ik(ktotal) =i
128                      jk(ktotal) =j
129
130                      dd = min(d(j), dn(jj))
131                      cc = cn(jj)
132                      if (cc.lt. c(j))cc=c(j)
133                      if((an(ii).lt.b(i)-2*pi).and.
134     &                  (bn(ii).gt.a(i)-2*pi)) then
135                          bb = min(b(i)-2*pi,bn(ii))
136                          aa = an(ii)
137                          if (aa.lt.a(i)-2*pi) aa=a(i)-2*pi
138                      else if((an(ii).lt.b(i)+2*pi).and.
139     &                       (bn(ii).gt.a(i)+2*pi)) then
140                          bb = min(b(i)+2*pi,bn(ii))
141                          aa = an(ii)
142                          if (aa.lt.a(i)+2*pi) aa=a(i)+2*pi
143                      else
144                          bb = min(b(i),bn(ii))
145                          aa = an(ii)
146                          if (aa.lt.a(i)) aa=a(i)
147                      end if
148                      intersec(ktotal)=(bb-aa)*(sin(dd)-sin(cc))
149                     end if
150                end do
151               end do
152             end if
153         end do
154       end do       
155
156
157
158c     TEST  INFO
159c     DO k=1,ktotal
160c      ii = iik(k)
161c      jj = jjk(k)
162c      i = ik(k)
163c      j = jk(k)
164c      if ((ii.eq.10).and.(jj.eq.10).and.(i.eq.10).and.(j.eq.10))then
165c      if (jj.eq.2.and.(ii.eq.1))then
166c          write(*,*) '**************** jj=',jj,'ii=',ii
167c          write(*,*) 'i,j =',i,j
168c          write(*,*) 'an,bn,cn,dn', an(ii), bn(ii), cn(jj),dn(jj)
169c          write(*,*) 'a,b,c,d', a(i), b(i), c(j),d(j)
170c          write(*,*) 'intersec(k)',intersec(k)
171c          write(*,*) 'airen(ii,jj)=',airen(ii,jj)
172c      end if
173c     END DO
174
175      return
176      end
Note: See TracBrowser for help on using the repository browser.