source: CPL/oasis3-mct_5.0/lib/mct/mpeu/m_Permuter.F90 @ 6328

Last change on this file since 6328 was 6328, checked in by aclsce, 17 months ago

First import of oasis3-mct_5.0 (from oasis git server, branch OASIS3-MCT_5.0)
File size: 34.8 KB
Line 
1!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
3!-----------------------------------------------------------------------
4! CVS $Id$
5! CVS $Name$
6!BOP -------------------------------------------------------------------
7!
8! !MODULE: m_Permuter - permute/unpermute
9!
10! !DESCRIPTION:
11!
12! !INTERFACE:
13
14    module m_Permuter
15      implicit none
16      private   ! except
17
18      public :: permute
19      public :: unpermute
20
21    interface permute; module procedure &
22        permutei_,      &       ! integer in place
23        permuteio_,     &       ! integer with an output
24        permutei1_,     &       ! integer in place
25        permuteio1_,    &       ! integer with an output
26        permuter_,      &       ! real in place
27        permutero_,     &       ! real with an output
28        permuter1_,     &       ! real in place
29        permutero1_,    &       ! real with an output
30        permuted_,      &       ! dble in place
31        permutedo_,     &       ! dble with an output
32        permuted1_,     &       ! dble in place
33        permutedo1_,    &       ! dble with an output
34        permutel_,      &       ! logical in place
35        permutelo_,     &       ! logical with an output
36        permutel1_,     &       ! logical in place
37        permutelo1_             ! logical with an output
38    end interface
39
40    interface unpermute; module procedure       &
41        unpermutei_,    &       ! integer in place
42        unpermuteio_,   &       ! integer with an output
43        unpermutei1_,   &       ! integer in place
44        unpermuteio1_,  &       ! integer with an output
45        unpermuter_,    &       ! real in place
46        unpermutero_,   &       ! real with an output
47        unpermuter1_,   &       ! real in place
48        unpermutero1_,  &       ! real with an output
49        unpermuted_,    &       ! dble in place
50        unpermutedo_,   &       ! dble with an output
51        unpermuted1_,   &       ! dble in place
52        unpermutedo1_,  &       ! dble with an output
53        unpermutel_,    &       ! logical in place
54        unpermutelo_,   &       ! logical with an output
55        unpermutel1_,   &       ! logical in place
56        unpermutelo1_           ! logical with an output
57    end interface
58
59! !REVISION HISTORY:
60!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
61!               - initial prototype/prolog/code
62!EOP ___________________________________________________________________
63
64  character(len=*),parameter :: myname='MCT(MPEU)::m_Permuter'
65
66contains
67
68!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
69!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
70!BOP -------------------------------------------------------------------
71!
72! !IROUTINE: permutei_ - permute an integer array according to indx[]
73!
74! !DESCRIPTION:
75!
76! !INTERFACE:
77
78    subroutine permutei_(ary,indx,n)
79      use m_die
80      implicit none
81      integer,dimension(:),intent(inout) :: ary
82      integer,dimension(:),intent(in)    :: indx
83      integer,             intent(in)    :: n
84
85! !REVISION HISTORY:
86!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
87!               - initial prototype/prolog/code
88!EOP ___________________________________________________________________
89
90  character(len=*),parameter :: myname_=myname//'::permutei_'
91
92  integer,allocatable,dimension(:) :: wk
93  integer :: i,ier
94
95  allocate(wk(n),stat=ier)
96        if(ier/=0) call perr_die(myname_,'allocate()',ier)
97
98  call permuteio_(wk,ary,indx,n)
99
100  do i=1,n
101    ary(i)=wk(i)
102  end do
103
104  deallocate(wk,stat=ier)
105        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
106
107end subroutine permutei_
108
109!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
110!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
111!BOP -------------------------------------------------------------------
112!
113! !IROUTINE: permuteio_ - permute an integer array according to indx[]
114!
115! !DESCRIPTION:
116!
117! !INTERFACE:
118
119    subroutine permuteio_(aout,ary,indx,n)
120      implicit none
121      integer,dimension(:),intent(inout) :: aout
122      integer,dimension(:),intent(in ) :: ary
123      integer,dimension(:),intent(in)  :: indx
124      integer,             intent(in)  :: n
125
126! !REVISION HISTORY:
127!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
128!               - initial prototype/prolog/code
129!EOP ___________________________________________________________________
130
131  character(len=*),parameter :: myname_=myname//'::permuteio_'
132
133  integer :: i,l
134
135  do i=1,n
136    l=indx(i)
137    aout(i)=ary(l)
138  end do
139
140end subroutine permuteio_
141
142!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
143!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
144!BOP -------------------------------------------------------------------
145!
146! !IROUTINE: unpermutei_ - unpermute a _permuted_ integer array
147!
148! !DESCRIPTION:
149!
150! !INTERFACE:
151
152    subroutine unpermutei_(ary,indx,n)
153      use m_die
154      implicit none
155      integer,dimension(:),intent(inout) :: ary
156      integer,dimension(:),intent(in)    :: indx
157      integer,             intent(in)    :: n
158
159! !REVISION HISTORY:
160!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
161!               - initial prototype/prolog/code
162!EOP ___________________________________________________________________
163
164  character(len=*),parameter :: myname_=myname//'::unpermutei_'
165
166  integer,allocatable,dimension(:) :: wk
167  integer :: i,ier
168
169  allocate(wk(n),stat=ier)
170        if(ier/=0) call perr_die(myname_,'allocate()',ier)
171
172  call unpermuteio_(wk,ary,indx,n)
173
174  do i=1,n
175    ary(i)=wk(i)
176  end do
177
178  deallocate(wk,stat=ier)
179        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
180
181end subroutine unpermutei_
182
183!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
185!BOP -------------------------------------------------------------------
186!
187! !IROUTINE: unpermuteio_ - unpermute a _permuted_ integer array
188!
189! !DESCRIPTION:
190!
191! !INTERFACE:
192
193    subroutine unpermuteio_(aout,ary,indx,n)
194      implicit none
195      integer,dimension(:),intent(inout) :: aout
196      integer,dimension(:),intent(in)  :: ary
197      integer,dimension(:),intent(in)  :: indx
198      integer,             intent(in)  :: n
199
200! !REVISION HISTORY:
201!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
202!               - initial prototype/prolog/code
203!EOP ___________________________________________________________________
204
205  character(len=*),parameter :: myname_=myname//'::unpermuteio_'
206
207  integer :: i,l
208
209  do i=1,n
210    l=indx(i)
211    aout(l)=ary(i)
212  end do
213
214end subroutine unpermuteio_
215
216!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
217!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
218!BOP -------------------------------------------------------------------
219!
220! !IROUTINE: permuter_ - permute a real array according to indx[]
221!
222! !DESCRIPTION:
223!
224! !INTERFACE:
225
226    subroutine permuter_(ary,indx,n)
227      use m_die
228      use m_realkinds,only : SP
229      implicit none
230      real(SP),dimension(:),intent(inout) :: ary
231      integer ,dimension(:),intent(in)    :: indx
232      integer ,             intent(in)    :: n
233
234! !REVISION HISTORY:
235!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
236!               - initial prototype/prolog/code
237!EOP ___________________________________________________________________
238
239  character(len=*),parameter :: myname_=myname//'::permuter_'
240
241  real(kind(ary)),allocatable,dimension(:) :: wk
242  integer :: i,ier
243
244  allocate(wk(n),stat=ier)
245        if(ier/=0) call perr_die(myname_,'allocate()',ier)
246
247  call permutero_(wk,ary,indx,n)
248
249  do i=1,n
250    ary(i)=wk(i)
251  end do
252
253  deallocate(wk,stat=ier)
254        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
255
256end subroutine permuter_
257
258!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
259!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
260!BOP -------------------------------------------------------------------
261!
262! !IROUTINE: permutero_ - permute a real array according to indx[]
263!
264! !DESCRIPTION:
265!
266! !INTERFACE:
267
268    subroutine permutero_(aout,ary,indx,n)
269      use m_realkinds,only : SP
270      implicit none
271      real(SP),dimension(:),intent(inout) :: aout
272      real(SP),dimension(:),intent(in)  :: ary
273      integer ,dimension(:),intent(in)  :: indx
274      integer ,             intent(in)  :: n
275
276! !REVISION HISTORY:
277!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
278!               - initial prototype/prolog/code
279!EOP ___________________________________________________________________
280
281  character(len=*),parameter :: myname_=myname//'::permutero_'
282
283  integer :: i,l
284
285  do i=1,n
286    l=indx(i)
287    aout(i)=ary(l)
288  end do
289
290end subroutine permutero_
291
292!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
293!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
294!BOP -------------------------------------------------------------------
295!
296! !IROUTINE: unpermuter_ - unpermute a _permuted_ real array
297!
298! !DESCRIPTION:
299!
300! !INTERFACE:
301
302    subroutine unpermuter_(ary,indx,n)
303      use m_die
304      use m_realkinds,only : SP
305      implicit none
306      real(SP),dimension(:),intent(inout) :: ary
307      integer ,dimension(:),intent(in)    :: indx
308      integer ,             intent(in)    :: n
309
310! !REVISION HISTORY:
311!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
312!               - initial prototype/prolog/code
313!EOP ___________________________________________________________________
314
315  character(len=*),parameter :: myname_=myname//'::unpermuter_'
316
317  real(kind(ary)),allocatable,dimension(:) :: wk
318  integer :: i,ier
319
320  allocate(wk(n),stat=ier)
321        if(ier/=0) call perr_die(myname_,'allocate()',ier)
322
323  call unpermutero_(wk,ary,indx,n)
324
325  do i=1,n
326    ary(i)=wk(i)
327  end do
328
329  deallocate(wk,stat=ier)
330        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
331
332end subroutine unpermuter_
333
334!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
335!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
336!BOP -------------------------------------------------------------------
337!
338! !IROUTINE: unpermutero_ - unpermute a _permuted_ real array
339!
340! !DESCRIPTION:
341!
342! !INTERFACE:
343
344    subroutine unpermutero_(aout,ary,indx,n)
345      use m_realkinds,only : SP
346      implicit none
347      real(SP),dimension(:),intent(inout) :: aout
348      real(SP),dimension(:),intent(in)  :: ary
349      integer ,dimension(:),intent(in)  :: indx
350      integer ,             intent(in)  :: n
351
352! !REVISION HISTORY:
353!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
354!               - initial prototype/prolog/code
355!EOP ___________________________________________________________________
356
357  character(len=*),parameter :: myname_=myname//'::unpermutero_'
358
359  integer :: i,l
360
361  do i=1,n
362    l=indx(i)
363    aout(l)=ary(i)
364  end do
365
366end subroutine unpermutero_
367
368!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
369!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
370!BOP -------------------------------------------------------------------
371!
372! !IROUTINE: permuted_ - permute a double precision array
373!
374! !DESCRIPTION:
375!
376! !INTERFACE:
377
378    subroutine permuted_(ary,indx,n)
379      use m_die
380      use m_realkinds,only : DP
381      implicit none
382      real(DP),dimension(:),intent(inout) :: ary
383      integer ,dimension(:),intent(in)    :: indx
384      integer ,             intent(in)    :: n
385
386! !REVISION HISTORY:
387!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
388!               - initial prototype/prolog/code
389!EOP ___________________________________________________________________
390
391  character(len=*),parameter :: myname_=myname//'::permuted_'
392
393  real(kind(ary)),allocatable,dimension(:) :: wk
394  integer :: i,ier
395
396  allocate(wk(n),stat=ier)
397        if(ier/=0) call perr_die(myname_,'allocate()',ier)
398
399  call permutedo_(wk,ary,indx,n)
400
401  do i=1,n
402    ary(i)=wk(i)
403  end do
404
405  deallocate(wk,stat=ier)
406        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
407
408end subroutine permuted_
409
410!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
411!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
412!BOP -------------------------------------------------------------------
413!
414! !IROUTINE: permutedo_ - permute a double precision array
415!
416! !DESCRIPTION:
417!
418! !INTERFACE:
419
420    subroutine permutedo_(aout,ary,indx,n)
421      use m_realkinds,only : DP
422      implicit none
423      real(DP),dimension(:),intent(inout) :: aout
424      real(DP),dimension(:),intent(in)  :: ary
425      integer ,dimension(:),intent(in)  :: indx
426      integer ,             intent(in)  :: n
427
428! !REVISION HISTORY:
429!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
430!               - initial prototype/prolog/code
431!EOP ___________________________________________________________________
432
433  character(len=*),parameter :: myname_=myname//'::permutedo_'
434
435  integer :: i,l
436
437  do i=1,n
438    l=indx(i)
439    aout(i)=ary(l)
440  end do
441
442end subroutine permutedo_
443
444!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
445!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
446!BOP -------------------------------------------------------------------
447!
448! !IROUTINE: unpermuted_ - unpermute a double precision array
449!
450! !DESCRIPTION:
451!
452! !INTERFACE:
453
454    subroutine unpermuted_(ary,indx,n)
455      use m_die
456      use m_realkinds,only : DP
457      implicit none
458      real(DP),dimension(:),intent(inout) :: ary
459      integer ,dimension(:),intent(in)    :: indx
460      integer ,             intent(in)    :: n
461
462! !REVISION HISTORY:
463!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
464!               - initial prototype/prolog/code
465!EOP ___________________________________________________________________
466
467  character(len=*),parameter :: myname_=myname//'::unpermuted_'
468
469  real(kind(ary)),allocatable,dimension(:) :: wk
470  integer :: i,ier
471
472  allocate(wk(n),stat=ier)
473        if(ier/=0) call perr_die(myname_,'allocate()',ier)
474
475  call unpermutedo_(wk,ary,indx,n)
476
477  do i=1,n
478    ary(i)=wk(i)
479  end do
480
481  deallocate(wk,stat=ier)
482        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
483
484end subroutine unpermuted_
485
486!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
487!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
488!BOP -------------------------------------------------------------------
489!
490! !IROUTINE: unpermutedo_ - unpermute a double precision array
491!
492! !DESCRIPTION:
493!
494! !INTERFACE:
495
496    subroutine unpermutedo_(aout,ary,indx,n)
497      use m_realkinds,only : DP
498      implicit none
499      real(DP),dimension(:),intent(inout) :: aout
500      real(DP),dimension(:),intent(in)  :: ary
501      integer ,dimension(:),intent(in)  :: indx
502      integer ,             intent(in)  :: n
503
504! !REVISION HISTORY:
505!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
506!               - initial prototype/prolog/code
507!EOP ___________________________________________________________________
508
509  character(len=*),parameter :: myname_=myname//'::unpermutedo_'
510
511  integer :: i,l
512
513  do i=1,n
514    l=indx(i)
515    aout(l)=ary(i)
516  end do
517
518end subroutine unpermutedo_
519
520!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
521!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
522!BOP -------------------------------------------------------------------
523!
524! !IROUTINE: permutel_ - permute a real array according to indx[]
525!
526! !DESCRIPTION:
527!
528! !INTERFACE:
529
530    subroutine permutel_(ary,indx,n)
531      use m_die
532      implicit none
533      logical,dimension(:),intent(inout) :: ary
534      integer,dimension(:),intent(in)    :: indx
535      integer,             intent(in)    :: n
536
537! !REVISION HISTORY:
538!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
539!               - initial prototype/prolog/code
540!EOP ___________________________________________________________________
541
542  character(len=*),parameter :: myname_=myname//'::permutel_'
543
544  logical,allocatable,dimension(:) :: wk
545  integer :: i,ier
546
547  allocate(wk(n),stat=ier)
548        if(ier/=0) call perr_die(myname_,'allocate()',ier)
549
550  call permutelo_(wk,ary,indx,n)
551
552  do i=1,n
553    ary(i)=wk(i)
554  end do
555
556  deallocate(wk,stat=ier)
557        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
558
559end subroutine permutel_
560
561!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
562!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
563!BOP -------------------------------------------------------------------
564!
565! !IROUTINE: permutelo_ - permute a real array according to indx[]
566!
567! !DESCRIPTION:
568!
569! !INTERFACE:
570
571    subroutine permutelo_(aout,ary,indx,n)
572      implicit none
573      logical,dimension(:),intent(inout) :: aout
574      logical,dimension(:),intent(in)  :: ary
575      integer,dimension(:),intent(in)  :: indx
576      integer,             intent(in)  :: n
577
578! !REVISION HISTORY:
579!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
580!               - initial prototype/prolog/code
581!EOP ___________________________________________________________________
582
583  character(len=*),parameter :: myname_=myname//'::permutelo_'
584
585  integer :: i,l
586
587  do i=1,n
588    l=indx(i)
589    aout(i)=ary(l)
590  end do
591
592end subroutine permutelo_
593
594!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
595!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
596!BOP -------------------------------------------------------------------
597!
598! !IROUTINE: unpermutel_ - unpermute a _permuted_ logical array
599!
600! !DESCRIPTION:
601!
602! !INTERFACE:
603
604    subroutine unpermutel_(ary,indx,n)
605      use m_die
606      implicit none
607      logical,dimension(:),intent(inout) :: ary
608      integer,dimension(:),intent(in)    :: indx
609      integer,             intent(in)    :: n
610
611! !REVISION HISTORY:
612!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
613!               - initial prototype/prolog/code
614!EOP ___________________________________________________________________
615
616  character(len=*),parameter :: myname_=myname//'::unpermutel_'
617
618  logical,allocatable,dimension(:) :: wk
619  integer :: i,ier
620
621  allocate(wk(n),stat=ier)
622        if(ier/=0) call perr_die(myname_,'allocate()',ier)
623
624  call unpermutelo_(wk,ary,indx,n)
625
626  do i=1,n
627    ary(i)=wk(i)
628  end do
629
630  deallocate(wk,stat=ier)
631        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
632
633end subroutine unpermutel_
634
635!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
636!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
637!BOP -------------------------------------------------------------------
638!
639! !IROUTINE: unpermutelo_ - unpermute a _permuted_ logical array
640!
641! !DESCRIPTION:
642!
643! !INTERFACE:
644
645    subroutine unpermutelo_(aout,ary,indx,n)
646      implicit none
647      logical,dimension(:),intent(inout) :: aout
648      logical,dimension(:),intent(in)  :: ary
649      integer,dimension(:),intent(in)  :: indx
650      integer,             intent(in)  :: n
651
652! !REVISION HISTORY:
653!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
654!               - initial prototype/prolog/code
655!EOP ___________________________________________________________________
656
657  character(len=*),parameter :: myname_=myname//'::unpermutelo_'
658
659  integer :: i,l
660
661  do i=1,n
662    l=indx(i)
663    aout(l)=ary(i)
664  end do
665
666end subroutine unpermutelo_
667
668!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
669!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
670!BOP -------------------------------------------------------------------
671!
672! !IROUTINE: permutei1_ - permute an integer array according to indx[]
673!
674! !DESCRIPTION:
675!
676! !INTERFACE:
677
678    subroutine permutei1_(ary,indx,n)
679      use m_die
680      implicit none
681      integer,dimension(:,:),intent(inout) :: ary
682      integer,dimension(:),intent(in)    :: indx
683      integer,             intent(in)    :: n
684
685! !REVISION HISTORY:
686!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
687!               - initial prototype/prolog/code
688!EOP ___________________________________________________________________
689
690  character(len=*),parameter :: myname_=myname//'::permutei1_'
691
692  integer,allocatable,dimension(:,:) :: wk
693  integer :: i,l,ier
694
695  l=size(ary,1)
696  allocate(wk(l,n),stat=ier)
697        if(ier/=0) call perr_die(myname_,'allocate()',ier)
698
699  call permuteio1_(wk,ary,indx,n)
700
701  do i=1,n
702    ary(:,i)=wk(:,i)
703  end do
704
705  deallocate(wk,stat=ier)
706        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
707
708end subroutine permutei1_
709
710!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
711!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
712!BOP -------------------------------------------------------------------
713!
714! !IROUTINE: permuteio1_ - permute an integer array according to indx[]
715!
716! !DESCRIPTION:
717!
718! !INTERFACE:
719
720    subroutine permuteio1_(aout,ary,indx,n)
721      implicit none
722      integer,dimension(:,:),intent(inout) :: aout
723      integer,dimension(:,:),intent(in ) :: ary
724      integer,dimension(:),intent(in)  :: indx
725      integer,             intent(in)  :: n
726
727! !REVISION HISTORY:
728!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
729!               - initial prototype/prolog/code
730!EOP ___________________________________________________________________
731
732  character(len=*),parameter :: myname_=myname//'::permuteio1_'
733
734  integer :: i,l,m
735
736  m=min(size(aout,1),size(ary,1))
737  do i=1,n
738    l=indx(i)
739    aout(1:m,i)=ary(1:m,l)
740  end do
741
742end subroutine permuteio1_
743
744!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
745!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
746!BOP -------------------------------------------------------------------
747!
748! !IROUTINE: unpermutei1_ - unpermute a _permuted_ integer array
749!
750! !DESCRIPTION:
751!
752! !INTERFACE:
753
754    subroutine unpermutei1_(ary,indx,n)
755      use m_die
756      implicit none
757      integer,dimension(:,:),intent(inout) :: ary
758      integer,dimension(:),intent(in)    :: indx
759      integer,             intent(in)    :: n
760
761! !REVISION HISTORY:
762!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
763!               - initial prototype/prolog/code
764!EOP ___________________________________________________________________
765
766  character(len=*),parameter :: myname_=myname//'::unpermutei1_'
767
768  integer,allocatable,dimension(:,:) :: wk
769  integer :: i,l,ier
770
771  l=size(ary,1)
772  allocate(wk(l,n),stat=ier)
773        if(ier/=0) call perr_die(myname_,'allocate()',ier)
774
775  call unpermuteio1_(wk,ary,indx,n)
776
777  do i=1,n
778    ary(:,i)=wk(:,i)
779  end do
780
781  deallocate(wk,stat=ier)
782        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
783
784end subroutine unpermutei1_
785
786!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
787!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
788!BOP -------------------------------------------------------------------
789!
790! !IROUTINE: unpermuteio1_ - unpermute a _permuted_ integer array
791!
792! !DESCRIPTION:
793!
794! !INTERFACE:
795
796    subroutine unpermuteio1_(aout,ary,indx,n)
797      implicit none
798      integer,dimension(:,:),intent(inout) :: aout
799      integer,dimension(:,:),intent(in)  :: ary
800      integer,dimension(:),intent(in)  :: indx
801      integer,             intent(in)  :: n
802
803! !REVISION HISTORY:
804!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
805!               - initial prototype/prolog/code
806!EOP ___________________________________________________________________
807
808  character(len=*),parameter :: myname_=myname//'::unpermuteio1_'
809
810  integer :: i,l,m
811
812  m=min(size(aout,1),size(ary,1))
813  do i=1,n
814    l=indx(i)
815    aout(1:m,l)=ary(1:m,i)
816  end do
817
818end subroutine unpermuteio1_
819
820!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
821!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
822!BOP -------------------------------------------------------------------
823!
824! !IROUTINE: permuter1_ - permute a real array according to indx[]
825!
826! !DESCRIPTION:
827!
828! !INTERFACE:
829
830    subroutine permuter1_(ary,indx,n)
831      use m_die
832      use m_realkinds,only : SP
833      implicit none
834      real(SP),dimension(:,:),intent(inout) :: ary
835      integer ,dimension(:),intent(in)    :: indx
836      integer ,             intent(in)    :: n
837
838! !REVISION HISTORY:
839!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
840!               - initial prototype/prolog/code
841!EOP ___________________________________________________________________
842
843  character(len=*),parameter :: myname_=myname//'::permuter1_'
844
845  real(kind(ary)),allocatable,dimension(:,:) :: wk
846  integer :: i,l,ier
847
848  l=size(ary,1)
849  allocate(wk(l,n),stat=ier)
850        if(ier/=0) call perr_die(myname_,'allocate()',ier)
851
852  call permutero1_(wk,ary,indx,n)
853
854  do i=1,n
855    ary(:,i)=wk(:,i)
856  end do
857
858  deallocate(wk,stat=ier)
859        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
860
861end subroutine permuter1_
862
863!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
864!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
865!BOP -------------------------------------------------------------------
866!
867! !IROUTINE: permutero1_ - permute a real array according to indx[]
868!
869! !DESCRIPTION:
870!
871! !INTERFACE:
872
873    subroutine permutero1_(aout,ary,indx,n)
874      use m_realkinds,only : SP
875      implicit none
876      real(SP),dimension(:,:),intent(inout) :: aout
877      real(SP),dimension(:,:),intent(in)  :: ary
878      integer ,dimension(:),intent(in)  :: indx
879      integer ,             intent(in)  :: n
880
881! !REVISION HISTORY:
882!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
883!               - initial prototype/prolog/code
884!EOP ___________________________________________________________________
885
886  character(len=*),parameter :: myname_=myname//'::permutero1_'
887
888  integer :: i,l,m
889
890  m=min(size(aout,1),size(ary,1))
891  do i=1,n
892    l=indx(i)
893    aout(1:m,i)=ary(1:m,l)
894  end do
895
896end subroutine permutero1_
897
898!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
899!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
900!BOP -------------------------------------------------------------------
901!
902! !IROUTINE: unpermuter1_ - unpermute a _permuted_ real array
903!
904! !DESCRIPTION:
905!
906! !INTERFACE:
907
908    subroutine unpermuter1_(ary,indx,n)
909      use m_die
910      use m_realkinds,only : SP
911      implicit none
912      real(SP),dimension(:,:),intent(inout) :: ary
913      integer ,dimension(:),intent(in)    :: indx
914      integer ,             intent(in)    :: n
915
916! !REVISION HISTORY:
917!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
918!               - initial prototype/prolog/code
919!EOP ___________________________________________________________________
920
921  character(len=*),parameter :: myname_=myname//'::unpermuter1_'
922
923  real(kind(ary)),allocatable,dimension(:,:) :: wk
924  integer :: i,l,ier
925
926  l=size(ary,1)
927  allocate(wk(l,n),stat=ier)
928        if(ier/=0) call perr_die(myname_,'allocate()',ier)
929
930  call unpermutero1_(wk,ary,indx,n)
931
932  do i=1,n
933    ary(:,i)=wk(:,i)
934  end do
935
936  deallocate(wk,stat=ier)
937        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
938
939end subroutine unpermuter1_
940
941!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
942!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
943!BOP -------------------------------------------------------------------
944!
945! !IROUTINE: unpermutero1_ - unpermute a _permuted_ real array
946!
947! !DESCRIPTION:
948!
949! !INTERFACE:
950
951    subroutine unpermutero1_(aout,ary,indx,n)
952      use m_realkinds,only : SP
953      implicit none
954      real(SP),dimension(:,:),intent(inout) :: aout
955      real(SP),dimension(:,:),intent(in)  :: ary
956      integer ,dimension(:),intent(in)  :: indx
957      integer ,             intent(in)  :: n
958
959! !REVISION HISTORY:
960!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
961!               - initial prototype/prolog/code
962!EOP ___________________________________________________________________
963
964  character(len=*),parameter :: myname_=myname//'::unpermutero1_'
965
966  integer :: i,l,m
967
968  m=min(size(aout,1),size(ary,1))
969  do i=1,n
970    l=indx(i)
971    aout(1:m,l)=ary(1:m,i)
972  end do
973
974end subroutine unpermutero1_
975
976!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
977!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
978!BOP -------------------------------------------------------------------
979!
980! !IROUTINE: permuted1_ - permute a double precision array
981!
982! !DESCRIPTION:
983!
984! !INTERFACE:
985
986    subroutine permuted1_(ary,indx,n)
987      use m_die
988      use m_realkinds,only : DP
989      implicit none
990      real(DP),dimension(:,:),intent(inout) :: ary
991      integer ,dimension(:),intent(in)    :: indx
992      integer ,             intent(in)    :: n
993
994! !REVISION HISTORY:
995!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
996!               - initial prototype/prolog/code
997!EOP ___________________________________________________________________
998
999  character(len=*),parameter :: myname_=myname//'::permuted1_'
1000
1001  real(kind(ary)),allocatable,dimension(:,:) :: wk
1002  integer :: i,l,ier
1003
1004  l=size(ary,1)
1005  allocate(wk(l,n),stat=ier)
1006        if(ier/=0) call perr_die(myname_,'allocate()',ier)
1007
1008  call permutedo1_(wk,ary,indx,n)
1009
1010  do i=1,n
1011    ary(:,i)=wk(:,i)
1012  end do
1013
1014  deallocate(wk,stat=ier)
1015        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
1016
1017end subroutine permuted1_
1018
1019!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1020!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1021!BOP -------------------------------------------------------------------
1022!
1023! !IROUTINE: permutedo1_ - permute a double precision array
1024!
1025! !DESCRIPTION:
1026!
1027! !INTERFACE:
1028
1029    subroutine permutedo1_(aout,ary,indx,n)
1030      use m_realkinds,only : DP
1031      implicit none
1032      real(DP),dimension(:,:),intent(inout) :: aout
1033      real(DP),dimension(:,:),intent(in)  :: ary
1034      integer ,dimension(:),intent(in)  :: indx
1035      integer ,             intent(in)  :: n
1036
1037! !REVISION HISTORY:
1038!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1039!               - initial prototype/prolog/code
1040!EOP ___________________________________________________________________
1041
1042  character(len=*),parameter :: myname_=myname//'::permutedo1_'
1043
1044  integer :: i,l,m
1045
1046  m=min(size(aout,1),size(ary,1))
1047  do i=1,n
1048    l=indx(i)
1049    aout(1:m,i)=ary(1:m,l)
1050  end do
1051
1052end subroutine permutedo1_
1053
1054!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1055!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1056!BOP -------------------------------------------------------------------
1057!
1058! !IROUTINE: unpermuted1_ - unpermute a double precision array
1059!
1060! !DESCRIPTION:
1061!
1062! !INTERFACE:
1063
1064    subroutine unpermuted1_(ary,indx,n)
1065      use m_die
1066      use m_realkinds,only : DP
1067      implicit none
1068      real(DP),dimension(:,:),intent(inout) :: ary
1069      integer ,dimension(:),intent(in)    :: indx
1070      integer ,             intent(in)    :: n
1071
1072! !REVISION HISTORY:
1073!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1074!               - initial prototype/prolog/code
1075!EOP ___________________________________________________________________
1076
1077  character(len=*),parameter :: myname_=myname//'::unpermuted1_'
1078
1079  real(kind(ary)),allocatable,dimension(:,:) :: wk
1080  integer :: i,l,ier
1081
1082  l=size(ary,1)
1083  allocate(wk(l,n),stat=ier)
1084        if(ier/=0) call perr_die(myname_,'allocate()',ier)
1085
1086  call unpermutedo1_(wk,ary,indx,n)
1087
1088  do i=1,n
1089    ary(:,i)=wk(:,i)
1090  end do
1091
1092  deallocate(wk,stat=ier)
1093        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
1094
1095end subroutine unpermuted1_
1096
1097!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1098!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1099!BOP -------------------------------------------------------------------
1100!
1101! !IROUTINE: unpermutedo1_ - unpermute a double precision array
1102!
1103! !DESCRIPTION:
1104!
1105! !INTERFACE:
1106
1107    subroutine unpermutedo1_(aout,ary,indx,n)
1108      use m_realkinds,only : DP
1109      implicit none
1110      real(DP),dimension(:,:),intent(inout) :: aout
1111      real(DP),dimension(:,:),intent(in)  :: ary
1112      integer ,dimension(:),intent(in)  :: indx
1113      integer ,             intent(in)  :: n
1114
1115! !REVISION HISTORY:
1116!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1117!               - initial prototype/prolog/code
1118!EOP ___________________________________________________________________
1119
1120  character(len=*),parameter :: myname_=myname//'::unpermutedo1_'
1121
1122  integer :: i,l,m
1123
1124  m=min(size(aout,1),size(ary,1))
1125  do i=1,n
1126    l=indx(i)
1127    aout(1:m,l)=ary(1:m,i)
1128  end do
1129
1130end subroutine unpermutedo1_
1131
1132!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1133!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1134!BOP -------------------------------------------------------------------
1135!
1136! !IROUTINE: permutel1_ - permute a real array according to indx[]
1137!
1138! !DESCRIPTION:
1139!
1140! !INTERFACE:
1141
1142    subroutine permutel1_(ary,indx,n)
1143      use m_die
1144      implicit none
1145      logical,dimension(:,:),intent(inout) :: ary
1146      integer,dimension(:),intent(in)    :: indx
1147      integer,             intent(in)    :: n
1148
1149! !REVISION HISTORY:
1150!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1151!               - initial prototype/prolog/code
1152!EOP ___________________________________________________________________
1153
1154  character(len=*),parameter :: myname_=myname//'::permutel1_'
1155
1156  logical,allocatable,dimension(:,:) :: wk
1157  integer :: i,l,ier
1158
1159  l=size(ary,1)
1160  allocate(wk(l,n),stat=ier)
1161        if(ier/=0) call perr_die(myname_,'allocate()',ier)
1162
1163  call permutelo1_(wk,ary,indx,n)
1164
1165  do i=1,n
1166    ary(:,i)=wk(:,i)
1167  end do
1168
1169  deallocate(wk,stat=ier)
1170        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
1171
1172end subroutine permutel1_
1173
1174!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1175!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1176!BOP -------------------------------------------------------------------
1177!
1178! !IROUTINE: permutelo1_ - permute a real array according to indx[]
1179!
1180! !DESCRIPTION:
1181!
1182! !INTERFACE:
1183
1184    subroutine permutelo1_(aout,ary,indx,n)
1185      implicit none
1186      logical,dimension(:,:),intent(inout) :: aout
1187      logical,dimension(:,:),intent(in)  :: ary
1188      integer,dimension(:),intent(in)  :: indx
1189      integer,             intent(in)  :: n
1190
1191! !REVISION HISTORY:
1192!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1193!               - initial prototype/prolog/code
1194!EOP ___________________________________________________________________
1195
1196  character(len=*),parameter :: myname_=myname//'::permutelo1_'
1197
1198  integer :: i,l,m
1199
1200  m=min(size(aout,1),size(ary,1))
1201  do i=1,n
1202    l=indx(i)
1203    aout(1:m,i)=ary(1:m,l)
1204  end do
1205
1206end subroutine permutelo1_
1207
1208!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1209!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1210!BOP -------------------------------------------------------------------
1211!
1212! !IROUTINE: unpermutel1_ - unpermute a _permuted_ logical array
1213!
1214! !DESCRIPTION:
1215!
1216! !INTERFACE:
1217
1218    subroutine unpermutel1_(ary,indx,n)
1219      use m_die
1220      implicit none
1221      logical,dimension(:,:),intent(inout) :: ary
1222      integer,dimension(:),intent(in)    :: indx
1223      integer,             intent(in)    :: n
1224
1225! !REVISION HISTORY:
1226!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1227!               - initial prototype/prolog/code
1228!EOP ___________________________________________________________________
1229
1230  character(len=*),parameter :: myname_=myname//'::unpermutel1_'
1231
1232  logical,allocatable,dimension(:,:) :: wk
1233  integer :: i,l,ier
1234
1235  l=size(ary,1)
1236  allocate(wk(l,n),stat=ier)
1237        if(ier/=0) call perr_die(myname_,'allocate()',ier)
1238
1239  call unpermutelo1_(wk,ary,indx,n)
1240
1241  do i=1,n
1242    ary(:,i)=wk(:,i)
1243  end do
1244
1245  deallocate(wk,stat=ier)
1246        if(ier/=0) call perr_die(myname_,'deallocate()',ier)
1247
1248end subroutine unpermutel1_
1249
1250!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1251!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
1252!BOP -------------------------------------------------------------------
1253!
1254! !IROUTINE: unpermutelo1_ - unpermute a _permuted_ logical array
1255!
1256! !DESCRIPTION:
1257!
1258! !INTERFACE:
1259
1260    subroutine unpermutelo1_(aout,ary,indx,n)
1261      implicit none
1262      logical,dimension(:,:),intent(inout) :: aout
1263      logical,dimension(:,:),intent(in)  :: ary
1264      integer,dimension(:),intent(in)  :: indx
1265      integer,             intent(in)  :: n
1266
1267! !REVISION HISTORY:
1268!       25Aug99 - Jing Guo <guo@dao.gsfc.nasa.gov>
1269!               - initial prototype/prolog/code
1270!EOP ___________________________________________________________________
1271
1272  character(len=*),parameter :: myname_=myname//'::unpermutelo1_'
1273
1274  integer :: i,l,m
1275
1276  m=min(size(aout,1),size(ary,1))
1277  do i=1,n
1278    l=indx(i)
1279    aout(1:m,l)=ary(1:m,i)
1280  end do
1281
1282end subroutine unpermutelo1_
1283
1284end module m_Permuter
Note: See TracBrowser for help on using the repository browser.