source: LMDZ6/branches/DYNAMICO-conv/libf/dyn3d/iniinterp_horiz.F @ 4976

Last change on this file since 4976 was 1907, checked in by lguez, 11 years ago

Added a copyright property to every file of the distribution, except
for the fcm files (which have their own copyright). Use svn propget on
a file to see the copyright. For instance:

$ svn propget copyright libf/phylmd/physiq.F90
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory

Also added the files defining the CeCILL version 2 license, in French
and English, at the top of the LMDZ tree.

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