1 #if( BUILD_RRTMG_FAST != 1)
2 MODULE module_ra_rrtmg_lwf
4 SUBROUTINE RRTMG_LWRAD_FAST
7 END SUBROUTINE RRTMG_LWRAD_FAST
8 END MODULE module_ra_rrtmg_lwf
10 !MODULE module_ra_rrtmg_lwf
15 ! --------------------------------------------------------------------------
17 ! | Copyright 2002-2013, Atmospheric & Environmental Research, Inc. (AER). |
18 ! | This software may be used, copied, or redistributed as long as it is |
19 ! | not sold and this copyright notice is reproduced on each copy made. |
20 ! | This model is provided as is without any express or implied warranties. |
21 ! | (http://www.rtweb.aer.com/) |
23 ! --------------------------------------------------------------------------
25 ! Uncomment to use GPU, or comment to use CPU
29 #define _gpudev ,device
30 #define _gpudeva ,device,allocatable
31 #define _gpudevanp ,device,allocatable
32 #define _gpucon ,constant
33 #define _gpuker attributes(global)
34 #define _gpuked attributes(device)
35 #define _gpuchv <<<dimGrid,dimBlock>>>
40 #define _gpudeva ,pointer
41 #define _gpudevanp ,allocatable
51 #define dbreg(x) call dbal(x)
52 #define dbcop(x,y) call dbcp(x, cpointer);call c_f_pointer( cpointer, y, shape(x))
53 #define dbcopnp(x,y,t,u) call dbcp(x, cpointer);call c_f_pointer( cpointer, y, shape(x))
54 #define dreg(x,y,z) call ddbxeg(x,y,z,cpointer);call c_f_pointer( cpointer, x, [y,z] )
55 #define sreg(x,y,z) call ddbxeg(x,y,z,cpointer)
56 #define dbflushreg() call dbflushrg()
57 #define dbflushcop() call dbflushcp()
60 #define dbcop(x,y) y=>x
61 #define dbcopnp(x,y,u,v) if (allocated(y).eqv..true.) deallocate(y) ;allocate( y( u, v)); y=x
64 #define dreg(x,y,z) if (allocated(x).eqv..true.) deallocate(x) ;allocate( x( y , z))
90 real, device, allocatable :: ar(:)
94 type(adr) :: plist(500)
95 type(adr) :: clist(100)
96 type(adrd) :: dlist(100)
100 type(c_devptr) :: cpointer
103 real, device, allocatable :: ddar(:)
104 real, device :: ddtemp(1)
105 integer :: ddsizec = 0
106 integer :: ddindex = 0
107 integer :: ddflush = 0
112 module procedure dbalr, dbalr2, dbalr3, dbali, dbali2, dbali3
116 module procedure dbcpi1, dbcpi2, dbcpi3, dbcpr1, dbcpr2, dbcpr3
120 module procedure ddbxegi, ddbxegr
125 subroutine ddbxegi( a, x, y , pt)
126 integer, allocatable, device :: a(:,:)
128 type(c_devptr), intent(out) :: pt
131 if (ddflush == 0) then
133 ddsizec = ddsizec + (x*y)
134 !pt = c_devloc( ddtemp(1) )
138 pt = c_devloc( ddar( ddindex ) )
139 ddindex = ddindex + (x*y)
146 subroutine ddbxegr( a, x, y , pt)
147 real, allocatable, device :: a(:,:)
149 type(c_devptr), intent(out) :: pt
152 if (ddflush == 0) then
154 ddsizec = ddsizec + (x*y)
155 pt = c_devloc( ddtemp(1) )
159 pt = c_devloc( ddar( ddindex ) )
160 ddindex = ddindex + (x*y)
167 allocate( ddar( ddsizec + 1 ) )
184 subroutine dbgenr( p, s )
185 real, intent(in) :: p(*)
186 integer, intent(in) :: s
188 plist(np)%loc = loc(p(1))
189 plist(np)%locp = c_loc(p(1))
192 plist(np)%oindex = np
194 print *, "index ", np
195 print *, "real allocation ", np, " loc: ", plist(np)%loc, " size: ", plist(np)%size
199 subroutine dbgeni( p, s )
200 integer, intent(in) :: p(*)
201 integer, intent(in) :: s
203 plist(np)%loc = loc(p(1))
204 plist(np)%locp = c_loc(p(1))
207 plist(np)%oindex = np
209 print *, "index ", np
210 print *, "integer allocation ", np, " loc: ", plist(np)%loc, " size: ", plist(np)%size
214 subroutine dbalr( p )
215 real, intent(in) :: p(:)
216 call dbgenr( p, size(p) * 4)
219 subroutine dbalr2( p)
220 real, intent(in) :: p(:,:)
221 call dbgenr( p, size(p) * 4)
224 subroutine dbalr3( p)
225 real, intent(in) :: p(:,:,:)
226 call dbgenr( p, size(p) * 4)
229 subroutine dbali( p )
230 integer, intent(in) :: p(:)
231 call dbgeni( p, size(p) * 4)
234 subroutine dbali2( p )
235 integer, intent(in) :: p(:,:)
236 call dbgeni( p, size(p) * 4)
239 subroutine dbali3( p )
240 integer, intent(in) :: p(:,:,:)
241 call dbgeni( p, size(p) * 4)
245 subroutine dbflushrg()
247 integer*8 :: loc, size, oin
248 type(c_ptr) :: locp, cpt
251 print *, "analyzing memory"
252 print *, "sorting entries"
257 if (plist(i)%loc > plist(i+1)%loc) then
261 oin = plist(i)%oindex
263 plist(i)%loc = plist(i+1)%loc
264 plist(i)%locp = plist(i+1)%locp
265 plist(i)%size = plist(i+1)%size
266 plist(i)%oindex = plist(i+1)%oindex
268 plist(i+1)%locp = locp
269 plist(i+1)%size = size
270 plist(i+1)%oindex = oin
277 plist(i)%gap = plist(i+1)%loc - (plist(i)%loc + plist(i)%size)
279 plist(np)%gap = 9999999
281 print *, "sorted elements"
285 print *, plist(i)%loc, plist(i)%size, plist(i)%gap
287 if (plist(i)%gap < 0) then
288 print *, "ERROR! Memory overlap found at index ", plist(i)%oindex
293 print *, "analyzing contiguous regions"
296 clist(1)%loc = plist(1)%loc
300 plist(i)%cindex = clist(nc)%size/4
302 if (plist(i)%gap > acgap) then
303 clist(nc)%size = clist(nc)%size + plist(i)%size
305 clist(nc+1)%loc = plist(i+1)%loc
306 clist(nc+1)%cindex = i+1
310 clist(nc)%size = clist(nc)%size + plist(i)%size + plist(i)%gap
317 print *, "contiguous regions", nc
318 print *, "number alloc/copy reduced to ", 100.0 * real(nc)/real(np), "%"
321 print *, clist(i)%loc, clist(i)%size
324 print *, "allocating device memory"
328 dlist(i)%size = clist(i)%size
330 print *, dlist(i)%size
333 allocate( dlist(i)%ar( dlist(i)%size + 2 ))
335 dlist(i)%loc = c_devloc( dlist(i)%ar(1) )
342 subroutine dbcpr( p, pt )
344 real, intent(in) :: p(*)
346 type(c_devptr), intent(out) :: pt
351 subroutine dbcpi1( p, pt )
352 integer, intent(in) :: p(:)
354 type(c_devptr), intent(out) :: pt
359 subroutine dbcpi2( p, pt )
360 integer, intent(in) :: p(:,:)
362 type(c_devptr), intent(out) :: pt
367 subroutine dbcpi3( p, pt )
368 integer, intent(in) :: p(:,:,:)
370 type(c_devptr), intent(out) :: pt
375 subroutine dbcpr1( p, pt )
376 real, intent(in) :: p(:)
378 type(c_devptr), intent(out) :: pt
383 subroutine dbcpr2( p, pt )
384 real, intent(in) :: p(:,:)
386 type(c_devptr), intent(out) :: pt
391 subroutine dbcpr3( p, pt )
392 real, intent(in) :: p(:,:,:)
394 type(c_devptr), intent(out) :: pt
401 subroutine dbcpg( lc, pt )
402 integer*8, intent(in) :: lc
403 type(c_devptr), intent(out) :: pt
408 if (plist(i)%loc .eq. lc) then
410 print *, "pointer found at index ", i
412 pt = c_devloc( dlist( plist(i)%cnum )%ar( plist(i)%cindex+1 ))
419 print *, "ERROR! pointer not found!"
430 print *, "checking that all pointers are assigned"
433 if (plist(i)%agn == 0) then
434 print *, "ERROR! pointer not assigned at index ", plist(i)%oindex
439 print *, "pointers are OK"
442 err = cudaMemCpyAsync( dlist(i)%loc, plist(clist(i)%cindex)%locp , clist(i)%size+1)
444 print *, "ERROR! there was an error with a memory copy"
449 print *, "memory copied successfully"
461 deallocate( dlist(i)%ar )
475 ! use parkind ,only : im => kind
480 !------------------------------------------------------------------
481 ! rrtmg_lw main parameters
483 ! Initial version: JJMorcrette, ECMWF, Jul 1998
484 ! Revised: MJIacono, AER, Jun 2006
485 ! Revised: MJIacono, AER, Aug 2007
486 ! Revised: MJIacono, AER, Aug 2008
487 !------------------------------------------------------------------
490 ! ----- : ---- : ----------------------------------------------
491 ! mxlay : integer: maximum number of layers
492 ! mg : integer: number of original g-intervals per spectral band
493 ! nbndlw : integer: number of spectral bands
494 ! maxxsec: integer: maximum number of cross-section molecules
497 ! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw
498 ! ngNN : integer: number of reduced g-intervals per spectral band
499 ! ngsNN : integer: cumulative number of g-intervals per band
500 !------------------------------------------------------------------
502 integer , parameter :: mxlay = 100
503 integer , parameter :: mg = 16
504 integer , parameter :: nbndlw = 16
505 integer , parameter :: maxxsec= 4
506 integer , parameter :: mxmol = 38
507 integer , parameter :: maxinpx= 38
508 integer , parameter :: nmol = 7
509 ! Use for 140 g-point model
510 integer , parameter :: ngptlw = 140
511 ! Use for 256 g-point model
512 ! integer , parameter :: ngptlw = 256
514 ! Use for 140 g-point model
515 integer , parameter :: ng1 = 10
516 integer , parameter :: ng2 = 12
517 integer , parameter :: ng3 = 16
518 integer , parameter :: ng4 = 14
519 integer , parameter :: ng5 = 16
520 integer , parameter :: ng6 = 8
521 integer , parameter :: ng7 = 12
522 integer , parameter :: ng8 = 8
523 integer , parameter :: ng9 = 12
524 integer , parameter :: ng10 = 6
525 integer , parameter :: ng11 = 8
526 integer , parameter :: ng12 = 8
527 integer , parameter :: ng13 = 4
528 integer , parameter :: ng14 = 2
529 integer , parameter :: ng15 = 2
530 integer , parameter :: ng16 = 2
532 integer , parameter :: ngs1 = 10
533 integer , parameter :: ngs2 = 22
534 integer , parameter :: ngs3 = 38
535 integer , parameter :: ngs4 = 52
536 integer , parameter :: ngs5 = 68
537 integer , parameter :: ngs6 = 76
538 integer , parameter :: ngs7 = 88
539 integer , parameter :: ngs8 = 96
540 integer , parameter :: ngs9 = 108
541 integer , parameter :: ngs10 = 114
542 integer , parameter :: ngs11 = 122
543 integer , parameter :: ngs12 = 130
544 integer , parameter :: ngs13 = 134
545 integer , parameter :: ngs14 = 136
546 integer , parameter :: ngs15 = 138
548 ! Use for 256 g-point model
549 ! integer , parameter :: ng1 = 16
550 ! integer , parameter :: ng2 = 16
551 ! integer , parameter :: ng3 = 16
552 ! integer , parameter :: ng4 = 16
553 ! integer , parameter :: ng5 = 16
554 ! integer , parameter :: ng6 = 16
555 ! integer , parameter :: ng7 = 16
556 ! integer , parameter :: ng8 = 16
557 ! integer , parameter :: ng9 = 16
558 ! integer , parameter :: ng10 = 16
559 ! integer , parameter :: ng11 = 16
560 ! integer , parameter :: ng12 = 16
561 ! integer , parameter :: ng13 = 16
562 ! integer , parameter :: ng14 = 16
563 ! integer , parameter :: ng15 = 16
564 ! integer , parameter :: ng16 = 16
566 ! integer , parameter :: ngs1 = 16
567 ! integer , parameter :: ngs2 = 32
568 ! integer , parameter :: ngs3 = 48
569 ! integer , parameter :: ngs4 = 64
570 ! integer , parameter :: ngs5 = 80
571 ! integer , parameter :: ngs6 = 96
572 ! integer , parameter :: ngs7 = 112
573 ! integer , parameter :: ngs8 = 128
574 ! integer , parameter :: ngs9 = 144
575 ! integer , parameter :: ngs10 = 160
576 ! integer , parameter :: ngs11 = 176
577 ! integer , parameter :: ngs12 = 192
578 ! integer , parameter :: ngs13 = 208
579 ! integer , parameter :: ngs14 = 224
580 ! integer , parameter :: ngs15 = 240
581 ! integer , parameter :: ngs16 = 256
587 ! use parkind, only : rb => kind
592 !------------------------------------------------------------------
593 ! rrtmg_lw cloud property coefficients
595 ! Revised: MJIacono, AER, jun2006
596 ! Revised: MJIacono, AER, aug2008
597 !------------------------------------------------------------------
600 ! ----- : ---- : ----------------------------------------------
608 !------------------------------------------------------------------
611 real , dimension(2) :: absice0
612 real , dimension(2,5) :: absice1
613 real , dimension(43,16) :: absice2
614 real , dimension(46,16) :: absice3
616 real , dimension(58,16) :: absliq1
618 end module rrlw_cld_f
622 ! use parkind, only : rb => kind
627 !------------------------------------------------------------------
630 ! Initial version: MJIacono, AER, jun2006
631 ! Revised: MJIacono, AER, aug2008
632 !------------------------------------------------------------------
635 ! ----- : ---- : ----------------------------------------------
636 ! fluxfac: real : radiance to flux conversion factor
637 ! heatfac: real : flux to heating rate conversion factor
638 !oneminus: real : 1.-1.e-6
640 ! grav : real : acceleration of gravity
641 ! planck : real : planck constant
642 ! boltz : real : boltzmann constant
643 ! clight : real : speed of light
644 ! avogad : real : avogadro constant
645 ! alosmt : real : loschmidt constant
646 ! gascon : real : molar gas constant
647 ! radcn1 : real : first radiation constant
648 ! radcn2 : real : second radiation constant
649 ! sbcnst : real : stefan-boltzmann constant
650 ! secdy : real : seconds per day
651 !------------------------------------------------------------------
653 real :: fluxfac, heatfac
654 real :: oneminus, pi, grav
655 real :: planck, boltz, clight
656 real :: avogad, alosmt, gascon
657 real :: radcn1, radcn2
658 real :: sbcnst, secdy
660 end module rrlw_con_f
664 ! use parkind ,only : im => kind , rb => kind
670 !-----------------------------------------------------------------
671 ! rrtmg_lw ORIGINAL abs. coefficients for interval 1
672 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
674 ! Initial version: JJMorcrette, ECMWF, jul1998
675 ! Revised: MJIacono, AER, jun2006
676 ! Revised: MJIacono, AER, aug2008
677 !-----------------------------------------------------------------
680 ! ---- : ---- : ---------------------------------------------
689 !-----------------------------------------------------------------
691 integer , parameter :: no1 = 16
693 real :: fracrefao(no1) , fracrefbo(no1)
694 real :: kao(5,13,no1)
695 real :: kbo(5,13:59,no1)
696 real :: kao_mn2(19,no1) , kbo_mn2(19,no1)
697 real :: selfrefo(10,no1), forrefo(4,no1)
699 !-----------------------------------------------------------------
700 ! rrtmg_lw COMBINED abs. coefficients for interval 1
701 ! band 1: 10-250 cm-1 (low - h2o; high - h2o)
703 ! Initial version: JJMorcrette, ECMWF, jul1998
704 ! Revised: MJIacono, AER, jun2006
705 ! Revised: MJIacono, AER, aug2008
706 !-----------------------------------------------------------------
709 ! ---- : ---- : ---------------------------------------------
720 !-----------------------------------------------------------------
722 integer , parameter :: ng1 = 10
725 real _cpusnp :: ka(5,13,ng1) , absa(65,ng1)
726 real _cpusnp :: kb(5,13:59,ng1), absb(235,ng1)
727 real _cpus :: fracrefa(ng1) , fracrefb(ng1)
728 real _cpus :: ka_mn2(19,ng1) , kb_mn2(19,ng1)
729 real _cpus :: selfref(10,ng1), forref(4,ng1)
732 real _gpudevanp :: kad(:,:,:), absad(:,:), absbd(:,:)
733 real _gpudevanp :: kbd(:,:,:)
735 real _gpudeva :: fracrefad(:) , fracrefbd(:)
736 real _gpudeva :: ka_mn2d(:,:) , kb_mn2d(:,:)
737 real _gpudeva :: selfrefd(:,:), forrefd(:,:)
739 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
743 subroutine copyToGPU1
745 dbcop(fracrefa,fracrefad)
746 dbcop(fracrefb,fracrefbd)
747 dbcop(ka_mn2,ka_mn2d)
748 dbcop(kb_mn2,kb_mn2d)
749 dbcop(selfref,selfrefd)
750 dbcop(forref,forrefd)
752 dbcopnp(absa , absad , 65 , ng1)
753 dbcopnp(absb , absbd , 235 , ng1)
770 end module rrlw_kg01_f
774 ! use parkind ,only : im => kind , rb => kind
780 !-----------------------------------------------------------------
781 ! rrtmg_lw ORIGINAL abs. coefficients for interval 2
782 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
784 ! Initial version: JJMorcrette, ECMWF, jul1998
785 ! Revised: MJIacono, AER, jun2006
786 ! Revised: MJIacono, AER, aug2008
787 !-----------------------------------------------------------------
790 ! ---- : ---- : ---------------------------------------------
797 !-----------------------------------------------------------------
799 integer , parameter :: no2 = 16
800 real _cpus :: kao(5,13,no2)
801 real _cpus :: kbo(5,13:59,no2)
802 real _cpus :: fracrefao(no2) , fracrefbo(no2)
803 real _cpus :: selfrefo(10,no2) , forrefo(4,no2)
805 real _gpudeva :: fracrefaod(:) , fracrefbod(:)
806 real _gpudeva :: selfrefod(:,:) , forrefod(:,:)
808 !-----------------------------------------------------------------
809 ! rrtmg_lw COMBINED abs. coefficients for interval 2
810 ! band 2: 250-500 cm-1 (low - h2o; high - h2o)
812 ! Initial version: JJMorcrette, ECMWF, jul1998
813 ! Revised: MJIacono, AER, jun2006
814 ! Revised: MJIacono, AER, aug2008
815 !-----------------------------------------------------------------
818 ! ---- : ---- : ---------------------------------------------
829 !-----------------------------------------------------------------
831 integer , parameter :: ng2 = 12
833 real _cpus :: fracrefa(ng2) , fracrefb(ng2)
834 real _cpusnp :: ka(5,13,ng2) , absa(65,ng2)
835 real _cpusnp :: kb(5,13:59,ng2), absb(235,ng2)
836 real _cpus :: selfref(10,ng2), forref(4,ng2)
838 real _gpudeva :: fracrefad(:) , fracrefbd(:)
839 real _gpudevanp :: absad(:,:)
840 real _gpudevanp :: absbd(:,:)
841 real _gpudeva :: selfrefd(:,:), forrefd(:,:)
845 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
849 subroutine copyToGPU2
851 dbcop(fracrefao,fracrefaod)
852 dbcop(fracrefbo,fracrefbod)
853 dbcop(selfrefo, selfrefod)
854 dbcop(forrefo, forrefod)
856 dbcop(fracrefa,fracrefad)
857 dbcop(fracrefb,fracrefbd)
859 dbcopnp(absa , absad , 65 , ng2)
860 dbcopnp(absb , absbd , 235 , ng2)
862 dbcop(selfref, selfrefd)
863 dbcop(forref, forrefd)
883 end module rrlw_kg02_f
887 ! use parkind ,only : im => kind , rb => kind
893 !-----------------------------------------------------------------
894 ! rrtmg_lw ORIGINAL abs. coefficients for interval 3
895 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
897 ! Initial version: JJMorcrette, ECMWF, jul1998
898 ! Revised: MJIacono, AER, jun2006
899 ! Revised: MJIacono, AER, aug2008
900 !-----------------------------------------------------------------
903 ! ---- : ---- : ---------------------------------------------
912 !-----------------------------------------------------------------
914 integer , parameter :: no3 = 16
916 real _cpus :: fracrefao(no3,9) ,fracrefbo(no3,5)
917 real _cpus :: kao(9,5,13,no3)
918 real _cpus :: kbo(5,5,13:59,no3)
919 real _cpus :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3)
920 real _cpus :: selfrefo(10,no3)
921 real _cpus :: forrefo(4,no3)
923 real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:)
924 !real _gpudeva :: kaod(9,5,13,no3)
925 !real _gpudeva :: kbod(5,5,13:59,no3)
926 real _gpudeva :: kao_mn2od(:,:,:), kbo_mn2od(:,:,:)
927 real _gpudeva :: selfrefod(:,:)
928 real _gpudeva :: forrefod(:,:)
930 !-----------------------------------------------------------------
931 ! rrtmg_lw COMBINED abs. coefficients for interval 3
932 ! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
934 ! Initial version: JJMorcrette, ECMWF, jul1998
935 ! Revised: MJIacono, AER, jun2006
936 ! Revised: MJIacono, AER, aug2008
937 !-----------------------------------------------------------------
940 ! ---- : ---- : ---------------------------------------------
952 !-----------------------------------------------------------------
954 integer , parameter :: ng3 = 16
956 real _cpus :: fracrefa(ng3,9) ,fracrefb(ng3,5)
957 real _cpusnp :: ka(9,5,13,ng3) ,absa(585,ng3)
958 real _cpusnp :: kb(5,5,13:59,ng3),absb(1175,ng3)
959 real _cpus :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3)
960 real _cpus :: selfref(10,ng3)
961 real _cpus :: forref(4,ng3)
963 real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:)
964 real _gpudevanp :: absad(:,:)
965 real _gpudevanp :: absbd(:,:)
966 real _gpudeva :: ka_mn2od(:,:,:), kb_mn2od(:,:,:)
967 real _gpudeva :: selfrefd(:,:)
968 real _gpudeva :: forrefd(:,:)
970 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
974 subroutine copyToGPU3
976 dbcop( fracrefao , fracrefaod )
977 dbcop( fracrefbo , fracrefbod )
978 dbcop( kao_mn2o , kao_mn2od )
979 dbcop( kbo_mn2o , kbo_mn2od )
980 dbcop( selfrefo , selfrefod )
981 dbcop( forrefo , forrefod )
983 dbcop( fracrefa , fracrefad )
984 dbcop( fracrefb , fracrefbd )
986 dbcopnp( absa , absad , 585 , ng3 )
987 dbcopnp( absb , absbd , 1175 , ng3 )
989 dbcop( ka_mn2o , ka_mn2od )
990 dbcop( kb_mn2o , kb_mn2od )
991 dbcop( selfref , selfrefd )
992 dbcop( forref , forrefd )
1019 end module rrlw_kg03_f
1023 ! use parkind ,only : im => kind , rb => kind
1029 !-----------------------------------------------------------------
1030 ! rrtmg_lw ORIGINAL abs. coefficients for interval 4
1031 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
1033 ! Initial version: JJMorcrette, ECMWF, jul1998
1034 ! Revised: MJIacono, AER, jun2006
1035 ! Revised: MJIacono, AER, aug2008
1036 !-----------------------------------------------------------------
1039 ! ---- : ---- : ---------------------------------------------
1046 !-----------------------------------------------------------------
1047 integer , parameter :: ng4 = 14
1048 integer , parameter :: no4 = 16
1050 real _cpus :: kao(9,5,13,no4)
1051 real _cpus :: kbo(5,5,13:59,no4)
1052 real _cpusnp :: ka(9,5,13,ng4) ,absa(585,ng4)
1053 real _cpusnp :: kb(5,5,13:59,ng4),absb(1175,ng4)
1055 real _cpus :: fracrefao(no4,9) ,fracrefbo(no4,5)
1057 real _cpus :: selfrefo(10,no4) ,forrefo(4,no4)
1059 real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:)
1060 !real _gpudev :: kaod(9,5,13,no4)
1061 !real _gpudev :: kbod(5,5,13:59,no4)
1062 real _gpudeva :: selfrefod(:,:) ,forrefod(:,:)
1064 !-----------------------------------------------------------------
1065 ! rrtmg_lw COMBINED abs. coefficients for interval 4
1066 ! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
1068 ! Initial version: JJMorcrette, ECMWF, jul1998
1069 ! Revised: MJIacono, AER, jun2006
1070 ! Revised: MJIacono, AER, aug2008
1071 !-----------------------------------------------------------------
1074 ! ---- : ---- : ---------------------------------------------
1083 !-----------------------------------------------------------------
1085 real _cpus :: fracrefa(ng4,9) ,fracrefb(ng4,5)
1087 real _cpus :: selfref(10,ng4) ,forref(4,ng4)
1089 real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:)
1090 real _gpudevanp :: absad(:,:)
1091 real _gpudevanp :: absbd(:,:)
1092 real _gpudeva :: selfrefd(:,:) ,forrefd(:,:)
1094 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
1098 subroutine copyToGPU4
1100 dbcop( fracrefa , fracrefad )
1101 dbcop( fracrefb , fracrefbd )
1103 dbcopnp( absa , absad , 585 , ng4 )
1104 dbcopnp( absb , absbd , 1175 , ng4)
1106 dbcop( selfref , selfrefd )
1107 dbcop( forref , forrefd )
1124 end module rrlw_kg04_f
1128 ! use parkind ,only : im => kind , rb => kind
1134 !-----------------------------------------------------------------
1135 ! rrtmg_lw ORIGINAL abs. coefficients for interval 5
1136 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
1138 ! Initial version: JJMorcrette, ECMWF, jul1998
1139 ! Revised: MJIacono, AER, jun2006
1140 ! Revised: MJIacono, AER, aug2008
1141 !-----------------------------------------------------------------
1144 ! ---- : ---- : ---------------------------------------------
1153 !-----------------------------------------------------------------
1155 integer , parameter :: no5 = 16
1156 integer , parameter :: ng5 = 16
1157 real _cpusnp :: ka(9,5,13,ng5),kb(5,5,13:59,ng5)
1158 real _cpus :: kao(9,5,13,no5)
1159 real _cpus :: kbo(5,5,13:59,no5)
1161 real _cpus :: fracrefao(no5,9) ,fracrefbo(no5,5)
1162 real _cpusnp :: absa(585,ng5)
1164 real _cpus :: kao_mo3(9,19,no5)
1165 real _cpus :: selfrefo(10,no5)
1166 real _cpus :: forrefo(4,no5)
1167 real _cpus :: ccl4o(no5)
1170 real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:)
1171 real _gpudev :: kaod(9,5,13,no5)
1172 real _gpudev :: kbod(5,5,13:59,no5)
1173 real _gpudeva :: kao_mo3d(:,:,:)
1174 real _gpudeva :: selfrefod(:,:)
1175 real _gpudeva :: forrefod(:,:)
1176 real _gpudeva :: ccl4od(:)
1177 !-----------------------------------------------------------------
1178 ! rrtmg_lw COMBINED abs. coefficients for interval 5
1179 ! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
1181 ! Initial version: JJMorcrette, ECMWF, jul1998
1182 ! Revised: MJIacono, AER, jun2006
1183 ! Revised: MJIacono, AER, aug2008
1184 !-----------------------------------------------------------------
1187 ! ---- : ---- : ---------------------------------------------
1199 !-----------------------------------------------------------------
1201 real _cpusnp :: absb(1175,ng5)
1203 real _cpus :: fracrefa(ng5,9) ,fracrefb(ng5,5)
1205 real _cpus :: ka_mo3(9,19,ng5)
1206 real _cpus :: selfref(10,ng5)
1207 real _cpus :: forref(4,ng5)
1208 real _cpus :: ccl4(ng5)
1210 real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:)
1211 real _gpudevanp :: absad(:,:)
1212 real _gpudevanp :: absbd(:,:)
1213 real _gpudeva :: ka_mo3d(:,:,:)
1214 real _gpudeva :: selfrefd(:,:)
1215 real _gpudeva :: forrefd(:,:)
1216 real _gpudeva :: ccl4d(:)
1218 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1))
1222 subroutine copyToGPU5
1224 dbcop( fracrefao , fracrefaod )
1225 dbcop( fracrefbo , fracrefbod )
1227 dbcop( kao_mo3 , kao_mo3d )
1228 dbcop( selfrefo , selfrefod )
1229 dbcop( forrefo , forrefod )
1230 dbcop( ccl4o , ccl4od )
1232 dbcop( fracrefa , fracrefad )
1233 dbcop( fracrefb , fracrefbd )
1235 dbcopnp( absa , absad, 585 , ng5 )
1236 dbcopnp( absb , absbd, 1175 , ng5 )
1238 dbcop( ka_mo3 , ka_mo3d )
1239 dbcop( selfref , selfrefd )
1240 dbcop( forref , forrefd )
1241 dbcop( ccl4 , ccl4d )
1268 end module rrlw_kg05_f
1272 ! use parkind ,only : im => kind , rb => kind
1279 !-----------------------------------------------------------------
1280 ! rrtmg_lw ORIGINAL abs. coefficients for interval 6
1281 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
1283 ! Initial version: JJMorcrette, ECMWF, jul1998
1284 ! Revised: MJIacono, AER, jun2006
1285 ! Revised: MJIacono, AER, aug2008
1286 !-----------------------------------------------------------------
1289 ! ---- : ---- : ---------------------------------------------
1297 !-----------------------------------------------------------------
1299 integer , parameter :: no6 = 16
1300 integer , parameter :: ng6 = 8
1302 real _cpusnp :: ka(5,13,ng6),absa(65,ng6)
1303 real _cpus, dimension(no6) :: fracrefao
1304 real _cpus :: kao(5,13,no6)
1305 real _cpus :: kao_mco2(19,no6)
1306 real _cpus :: selfrefo(10,no6)
1307 real _cpus :: forrefo(4,no6)
1309 real _cpus, dimension(no6) :: cfc11adjo
1310 real _cpus, dimension(no6) :: cfc12o
1312 real _gpudeva , dimension(:) :: fracrefaod
1313 real _gpudeva :: kaod(:,:,:)
1314 real _gpudeva :: kao_mco2d(:,:)
1315 real _gpudeva :: selfrefod(:,:)
1316 real _gpudeva :: forrefod(:,:)
1318 real _gpudeva , dimension(:) :: cfc11adjod
1319 real _gpudeva , dimension(:) :: cfc12od
1321 !-----------------------------------------------------------------
1322 ! rrtmg_lw COMBINED abs. coefficients for interval 6
1323 ! band 6: 820-980 cm-1 (low - h2o; high - nothing)
1325 ! Initial version: JJMorcrette, ECMWF, jul1998
1326 ! Revised: MJIacono, AER, jun2006
1327 ! Revised: MJIacono, AER, aug2008
1328 !-----------------------------------------------------------------
1331 ! ---- : ---- : ---------------------------------------------
1341 !-----------------------------------------------------------------
1343 real _cpus, dimension(ng6) :: fracrefa
1345 real _cpus :: ka_mco2(19,ng6)
1346 real _cpus :: selfref(10,ng6)
1347 real _cpus :: forref(4,ng6)
1349 real _cpus, dimension(ng6) :: cfc11adj
1350 real _cpus, dimension(ng6) :: cfc12
1352 real _gpudeva , dimension(:) :: fracrefad
1353 real _gpudevanp :: absad(:,:)
1354 real _gpudeva :: ka_mco2d(:,:)
1355 real _gpudeva :: selfrefd(:,:)
1356 real _gpudeva :: forrefd(:,:)
1358 real _gpudeva , dimension(:) :: cfc11adjd
1359 real _gpudeva , dimension(:) :: cfc12d
1361 equivalence (ka(1,1,1),absa(1,1))
1365 subroutine copyToGPU6
1367 dbcop( fracrefao , fracrefaod )
1369 dbcop( kao_mco2 , kao_mco2d )
1370 dbcop( selfrefo , selfrefod )
1371 dbcop( forrefo , forrefod )
1372 dbcop( cfc11adjo , cfc11adjod )
1373 dbcop( cfc12o , cfc12od )
1375 dbcop( fracrefa , fracrefad )
1377 dbcopnp( absa , absad, 65, ng6 )
1378 dbcop( ka_mco2 , ka_mco2d )
1379 dbcop( selfref , selfrefd )
1380 dbcop( forref , forrefd )
1381 dbcop( cfc11adj , cfc11adjd )
1382 dbcop( cfc12 , cfc12d )
1407 end module rrlw_kg06_f
1411 ! use parkind ,only : im => kind , rb => kind
1417 !-----------------------------------------------------------------
1418 ! rrtmg_lw ORIGINAL abs. coefficients for interval 7
1419 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
1421 ! Initial version: JJMorcrette, ECMWF, jul1998
1422 ! Revised: MJIacono, AER, jun2006
1423 ! Revised: MJIacono, AER, aug2008
1424 !-----------------------------------------------------------------
1427 ! ---- : ---- : ---------------------------------------------
1436 !-----------------------------------------------------------------
1438 integer , parameter :: no7 = 16
1439 integer , parameter :: ng7 = 12
1440 real _gpudev :: kaod(9,5,13,no7)
1441 real _gpudev :: kbod(5,13:59,no7)
1442 real _cpusnp :: ka(9,5,13,ng7) ,kb(5,13:59,ng7),absa(585,ng7)
1443 real _cpusnp :: absb(235,ng7)
1445 real _cpus, dimension(no7) :: fracrefbo
1446 real _cpus :: fracrefao(no7,9)
1447 real _cpus :: kao(9,5,13,no7)
1448 real _cpus :: kbo(5,13:59,no7)
1449 real _cpus :: kao_mco2(9,19,no7)
1450 real _cpus :: kbo_mco2(19,no7)
1451 real _cpus :: selfrefo(10,no7)
1452 real _cpus :: forrefo(4,no7)
1454 real _gpudeva , dimension(:) :: fracrefbod
1455 real _gpudeva :: fracrefaod(:,:)
1457 real _gpudeva :: kao_mco2d(:,:,:)
1458 real _gpudeva :: kbo_mco2d(:,:)
1459 real _gpudeva :: selfrefod(:,:)
1460 real _gpudeva :: forrefod(:,:)
1462 !-----------------------------------------------------------------
1463 ! rrtmg_lw COMBINED abs. coefficients for interval 7
1464 ! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
1466 ! Initial version: JJMorcrette, ECMWF, jul1998
1467 ! Revised: MJIacono, AER, jun2006
1468 ! Revised: MJIacono, AER, aug2008
1469 !-----------------------------------------------------------------
1472 ! ---- : ---- : ---------------------------------------------
1483 !-----------------------------------------------------------------
1485 real _cpus, dimension(ng7) :: fracrefb
1486 real _cpus :: fracrefa(ng7,9)
1488 real _cpus :: ka_mco2(9,19,ng7)
1489 real _cpus :: kb_mco2(19,ng7)
1490 real _cpus :: selfref(10,ng7)
1491 real _cpus :: forref(4,ng7)
1493 real _gpudeva , dimension(:) :: fracrefbd
1494 real _gpudeva :: fracrefad(:,:)
1495 real _gpudevanp :: absad(:,:)
1496 real _gpudevanp :: absbd(:,:)
1497 real _gpudeva :: ka_mco2d(:,:,:)
1498 real _gpudeva :: kb_mco2d(:,:)
1499 real _gpudeva :: selfrefd(:,:)
1500 real _gpudeva :: forrefd(:,:)
1501 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1505 subroutine copyToGPU7
1507 dbcop( fracrefb , fracrefbd )
1508 dbcop( fracrefa , fracrefad )
1510 dbcopnp( absa , absad, 585, ng7 )
1511 dbcopnp( absb , absbd, 235, ng7 )
1513 dbcop( ka_mco2 , ka_mco2d )
1514 dbcop( kb_mco2 , kb_mco2d )
1515 dbcop( selfref , selfrefd )
1516 dbcop( forref , forrefd )
1518 dbcop( fracrefbo , fracrefbod )
1519 dbcop( fracrefao , fracrefaod )
1521 dbcop( kao_mco2 , kao_mco2d )
1522 dbcop( kbo_mco2 , kbo_mco2d )
1523 dbcop( selfrefo , selfrefod )
1524 dbcop( forrefo , forrefod )
1554 end module rrlw_kg07_f
1558 ! use parkind ,only : im => kind , rb => kind
1564 !-----------------------------------------------------------------
1565 ! rrtmg_lw ORIGINAL abs. coefficients for interval 8
1566 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
1568 ! Initial version: JJMorcrette, ECMWF, jul1998
1569 ! Revised: MJIacono, AER, jun2006
1570 ! Revised: MJIacono, AER, aug2008
1571 !-----------------------------------------------------------------
1574 ! ---- : ---- : ---------------------------------------------
1588 !-----------------------------------------------------------------
1590 integer , parameter :: no8 = 16
1592 real _cpus, dimension(no8) :: fracrefao
1593 real _cpus, dimension(no8) :: fracrefbo
1594 real _cpus, dimension(no8) :: cfc12o
1595 real _cpus, dimension(no8) :: cfc22adjo
1597 real _cpus :: kao(5,13,no8)
1598 real _cpus :: kao_mco2(19,no8)
1599 real _cpus :: kao_mn2o(19,no8)
1600 real _cpus :: kao_mo3(19,no8)
1601 real _cpus :: kbo(5,13:59,no8)
1602 real _cpus :: kbo_mco2(19,no8)
1603 real _cpus :: kbo_mn2o(19,no8)
1604 real _cpus :: selfrefo(10,no8)
1605 real _cpus :: forrefo(4,no8)
1607 real _gpudeva , dimension(:) :: fracrefaod
1608 real _gpudeva , dimension(:) :: fracrefbod
1609 real _gpudeva , dimension(:) :: cfc12od
1610 real _gpudeva , dimension(:) :: cfc22adjod
1612 real _gpudev :: kaod(5,13,no8)
1613 real _gpudeva :: kao_mco2d(:,:)
1614 real _gpudeva :: kao_mn2od(:,:)
1615 real _gpudeva :: kao_mo3d(:,:)
1616 real _gpudev :: kbod(5,13:59,no8)
1617 real _gpudeva :: kbo_mco2d(:,:)
1618 real _gpudeva :: kbo_mn2od(:,:)
1619 real _gpudeva :: selfrefod(:,:)
1620 real _gpudeva :: forrefod(:,:)
1622 !-----------------------------------------------------------------
1623 ! rrtmg_lw COMBINED abs. coefficients for interval 8
1624 ! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
1626 ! Initial version: JJMorcrette, ECMWF, jul1998
1627 ! Revised: MJIacono, AER, jun2006
1628 ! Revised: MJIacono, AER, aug2008
1629 !-----------------------------------------------------------------
1632 ! ---- : ---- : ---------------------------------------------
1649 !-----------------------------------------------------------------
1651 integer , parameter :: ng8 = 8
1653 real _cpus, dimension(ng8) :: fracrefa
1654 real _cpus, dimension(ng8) :: fracrefb
1655 real _cpus, dimension(ng8) :: cfc12
1656 real _cpus, dimension(ng8) :: cfc22adj
1658 real _cpusnp :: ka(5,13,ng8) ,absa(65,ng8)
1659 real _cpusnp :: kb(5,13:59,ng8) ,absb(235,ng8)
1660 real _cpus :: ka_mco2(19,ng8)
1661 real _cpus :: ka_mn2o(19,ng8)
1662 real _cpus :: ka_mo3(19,ng8)
1663 real _cpus :: kb_mco2(19,ng8)
1664 real _cpus :: kb_mn2o(19,ng8)
1665 real _cpus :: selfref(10,ng8)
1666 real _cpus :: forref(4,ng8)
1668 real _gpudeva , dimension(:) :: fracrefad
1669 real _gpudeva , dimension(:) :: fracrefbd
1670 real _gpudeva , dimension(:) :: cfc12d
1671 real _gpudeva , dimension(:) :: cfc22adjd
1673 real _gpudevanp :: absad(:,:)
1674 real _gpudevanp :: absbd(:,:)
1675 real _gpudeva :: ka_mco2d(:,:)
1676 real _gpudeva :: ka_mn2od(:,:)
1677 real _gpudeva :: ka_mo3d(:,:)
1678 real _gpudeva :: kb_mco2d(:,:)
1679 real _gpudeva :: kb_mn2od(:,:)
1680 real _gpudeva :: selfrefd(:,:)
1681 real _gpudeva :: forrefd(:,:)
1683 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1687 subroutine copyToGPU8
1692 dbcop( fracrefao , fracrefaod )
1693 dbcop( fracrefbo , fracrefbod )
1694 dbcop( cfc12o , cfc12od )
1695 dbcop( cfc22adjo , cfc22adjod )
1697 dbcop( kao_mco2 , kao_mco2d )
1698 dbcop( kao_mn2o , kao_mn2od )
1699 dbcop( kao_mo3 , kao_mo3d )
1701 dbcop( kbo_mco2 , kbo_mco2d )
1702 dbcop( kbo_mn2o , kbo_mn2od )
1703 dbcop( selfrefo , selfrefod )
1704 dbcop( forrefo , forrefod )
1706 dbcop( fracrefa , fracrefad )
1707 dbcop( fracrefb , fracrefbd )
1708 dbcop( cfc12 , cfc12d )
1709 dbcop( cfc22adj , cfc22adjd )
1711 dbcopnp( absa , absad, 65 , ng8 )
1712 dbcopnp( absb , absbd, 235 , ng8 )
1714 dbcop( ka_mco2 , ka_mco2d )
1715 dbcop( ka_mn2o , ka_mn2od )
1716 dbcop( ka_mo3 , ka_mo3d )
1717 dbcop( kb_mco2 , kb_mco2d )
1718 dbcop( kb_mn2o , kb_mn2od )
1719 dbcop( selfref , selfrefd )
1720 dbcop( forref , forrefd )
1756 end module rrlw_kg08_f
1760 ! use parkind ,only : im => kind , rb => kind
1766 !-----------------------------------------------------------------
1767 ! rrtmg_lw ORIGINAL abs. coefficients for interval 9
1768 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
1770 ! Initial version: JJMorcrette, ECMWF, jul1998
1771 ! Revised: MJIacono, AER, jun2006
1772 ! Revised: MJIacono, AER, aug2008
1773 !-----------------------------------------------------------------
1776 ! ---- : ---- : ---------------------------------------------
1785 !-----------------------------------------------------------------
1787 integer , parameter :: no9 = 16
1789 real _cpus, dimension(no9) :: fracrefbo
1791 real _cpus :: fracrefao(no9,9)
1792 real _cpus :: kao(9,5,13,no9)
1793 real _cpus :: kbo(5,13:59,no9)
1794 real _cpus :: kao_mn2o(9,19,no9)
1795 real _cpus :: kbo_mn2o(19,no9)
1796 real _cpus :: selfrefo(10,no9)
1797 real _cpus :: forrefo(4,no9)
1799 real _gpudeva , dimension(:) :: fracrefbod
1801 real _gpudeva :: fracrefaod(:,:)
1802 real _gpudev :: kaod(9,5,13,no9)
1803 real _gpudev :: kbod(5,13:59,no9)
1804 real _gpudeva :: kao_mn2od(:,:,:)
1805 real _gpudeva :: kbo_mn2od(:,:)
1806 real _gpudeva :: selfrefod(:,:)
1807 real _gpudeva :: forrefod(:,:)
1809 !-----------------------------------------------------------------
1810 ! rrtmg_lw COMBINED abs. coefficients for interval 9
1811 ! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
1813 ! Initial version: JJMorcrette, ECMWF, jul1998
1814 ! Revised: MJIacono, AER, jun2006
1815 ! Revised: MJIacono, AER, aug2008
1816 !-----------------------------------------------------------------
1819 ! ---- : ---- : ---------------------------------------------
1831 !-----------------------------------------------------------------
1833 integer , parameter :: ng9 = 12
1835 real _cpus, dimension(ng9) :: fracrefb
1836 real _cpus :: fracrefa(ng9,9)
1837 real _cpusnp :: ka(9,5,13,ng9) ,absa(585,ng9)
1838 real _cpusnp :: kb(5,13:59,ng9) ,absb(235,ng9)
1839 real _cpus :: ka_mn2o(9,19,ng9)
1840 real _cpus :: kb_mn2o(19,ng9)
1841 real _cpus :: selfref(10,ng9)
1842 real _cpus :: forref(4,ng9)
1844 real _gpudeva , dimension(:) :: fracrefbd
1845 real _gpudeva :: fracrefad(:,:)
1846 real _gpudevanp :: absad(:,:)
1847 real _gpudevanp :: absbd(:,:)
1848 real _gpudeva :: ka_mn2od(:,:,:)
1849 real _gpudeva :: kb_mn2od(:,:)
1850 real _gpudeva :: selfrefd(:,:)
1851 real _gpudeva :: forrefd(:,:)
1853 equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1857 subroutine copyToGPU9
1862 dbcop( fracrefao , fracrefaod )
1863 dbcop( fracrefbo , fracrefbod )
1865 dbcopnp( absa , absad , 585 , ng9 )
1866 dbcopnp( absb , absbd, 235 , ng9 )
1868 dbcop( kao_mn2o , kao_mn2od )
1869 dbcop( kbo_mn2o , kbo_mn2od )
1870 dbcop( selfref , selfrefd )
1871 dbcop( forref , forrefd )
1873 dbcop( fracrefa , fracrefad )
1874 dbcop( fracrefb , fracrefbd )
1876 dbcop( ka_mn2o , ka_mn2od )
1877 dbcop( kb_mn2o , kb_mn2od )
1878 dbcop( selfrefo , selfrefod )
1879 dbcop( forrefo , forrefod )
1906 end module rrlw_kg09_f
1910 ! use parkind ,only : im => kind , rb => kind
1916 !-----------------------------------------------------------------
1917 ! rrtmg_lw ORIGINAL abs. coefficients for interval 10
1918 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
1920 ! Initial version: JJMorcrette, ECMWF, jul1998
1921 ! Revised: MJIacono, AER, jun2006
1922 ! Revised: MJIacono, AER, aug2008
1923 !-----------------------------------------------------------------
1926 ! ---- : ---- : ---------------------------------------------
1933 !-----------------------------------------------------------------
1935 integer , parameter :: no10 = 16
1937 real _cpus, dimension(no10) :: fracrefao
1938 real _cpus, dimension(no10) :: fracrefbo
1940 real _cpus :: kao(5,13,no10)
1941 real _cpus :: kbo(5,13:59,no10)
1942 real _cpus :: selfrefo(10,no10)
1943 real _cpus :: forrefo(4,no10)
1945 real _gpudeva , dimension(:) :: fracrefaod
1946 real _gpudeva , dimension(:) :: fracrefbod
1948 real _gpudev :: kaod(5,13,no10)
1949 real _gpudev :: kbod(5,13:59,no10)
1950 real _gpudeva :: selfrefod(:,:)
1951 real _gpudeva :: forrefod(:,:)
1953 !-----------------------------------------------------------------
1954 ! rrtmg_lw COMBINED abs. coefficients for interval 10
1955 ! band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
1957 ! Initial version: JJMorcrette, ECMWF, jul1998
1958 ! Revised: MJIacono, AER, jun2006
1959 ! Revised: MJIacono, AER, aug2008
1960 !-----------------------------------------------------------------
1963 ! ---- : ---- : ---------------------------------------------
1973 !-----------------------------------------------------------------
1975 integer , parameter :: ng10 = 6
1977 real _cpus , dimension(ng10) :: fracrefa
1978 real _cpus , dimension(ng10) :: fracrefb
1980 real _cpusnp :: ka(5,13,ng10) , absa(65,ng10)
1981 real _cpusnp :: kb(5,13:59,ng10), absb(235,ng10)
1982 real _cpus :: selfref(10,ng10)
1983 real _cpus :: forref(4,ng10)
1985 real _gpudeva , dimension(:) :: fracrefad
1986 real _gpudeva , dimension(:) :: fracrefbd
1988 real _gpudevanp :: absad(:,:)
1989 real _gpudevanp :: absbd(:,:)
1990 real _gpudeva :: selfrefd(:,:)
1991 real _gpudeva :: forrefd(:,:)
1993 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
1997 subroutine copyToGPU10
2002 dbcop( fracrefao , fracrefaod )
2003 dbcop( fracrefbo , fracrefbod )
2005 !dbcop( kao , kaod )
2006 !dbcop( kbo , kbod )
2007 dbcop( selfrefo , selfrefod )
2008 dbcop( forrefo , forrefod )
2010 dbcop( fracrefa , fracrefad )
2011 dbcop( fracrefb , fracrefbd )
2015 dbcopnp( absa , absad, 65 , ng10 )
2016 dbcopnp( absb , absbd, 235 , ng10 )
2018 dbcop( selfref , selfrefd )
2019 dbcop( forref , forrefd )
2045 end module rrlw_kg10_f
2049 ! use parkind ,only : im => kind , rb => kind
2055 !-----------------------------------------------------------------
2056 ! rrtmg_lw ORIGINAL abs. coefficients for interval 11
2057 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
2059 ! Initial version: JJMorcrette, ECMWF, jul1998
2060 ! Revised: MJIacono, AER, jun2006
2061 ! Revised: MJIacono, AER, aug2008
2062 !-----------------------------------------------------------------
2065 ! ---- : ---- : ---------------------------------------------
2074 !-----------------------------------------------------------------
2076 integer , parameter :: no11 = 16
2078 real _cpus, dimension(no11) :: fracrefao
2079 real _cpus, dimension(no11) :: fracrefbo
2081 real _cpus :: kao(5,13,no11)
2082 real _cpus :: kbo(5,13:59,no11)
2083 real _cpus :: kao_mo2(19,no11)
2084 real _cpus :: kbo_mo2(19,no11)
2085 real _cpus :: selfrefo(10,no11)
2086 real _cpus :: forrefo(4,no11)
2088 real _gpudeva , dimension(:) :: fracrefaod
2089 real _gpudeva , dimension(:) :: fracrefbod
2091 real _gpudev :: kaod(5,13,no11)
2092 real _gpudev :: kbod(5,13:59,no11)
2093 real _gpudeva :: kao_mo2d(:,:)
2094 real _gpudeva :: kbo_mo2d(:,:)
2095 real _gpudeva :: selfrefod(:,:)
2096 real _gpudeva :: forrefod(:,:)
2098 !-----------------------------------------------------------------
2099 ! rrtmg_lw COMBINED abs. coefficients for interval 11
2100 ! band 11: 1480-1800 cm-1 (low - h2o; high - h2o)
2102 ! Initial version: JJMorcrette, ECMWF, jul1998
2103 ! Revised: MJIacono, AER, jun2006
2104 ! Revised: MJIacono, AER, aug2008
2105 !-----------------------------------------------------------------
2108 ! ---- : ---- : ---------------------------------------------
2120 !-----------------------------------------------------------------
2122 integer , parameter :: ng11 = 8
2124 real _cpus, dimension(ng11) :: fracrefa
2125 real _cpus, dimension(ng11) :: fracrefb
2127 real _cpusnp :: ka(5,13,ng11) , absa(65,ng11)
2128 real _cpusnp :: kb(5,13:59,ng11), absb(235,ng11)
2129 real _cpus :: ka_mo2(19,ng11)
2130 real _cpus :: kb_mo2(19,ng11)
2131 real _cpus :: selfref(10,ng11)
2132 real _cpus :: forref(4,ng11)
2134 real _gpudeva , dimension(:) :: fracrefad
2135 real _gpudeva , dimension(:) :: fracrefbd
2137 real _gpudevanp :: absad(:,:)
2138 real _gpudevanp :: absbd(:,:)
2139 real _gpudeva :: ka_mo2d(:,:)
2140 real _gpudeva :: kb_mo2d(:,:)
2141 real _gpudeva :: selfrefd(:,:)
2142 real _gpudeva :: forrefd(:,:)
2144 equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1))
2148 subroutine copyToGPU11
2150 dbcop( fracrefa , fracrefad )
2151 dbcop( fracrefb , fracrefbd )
2153 dbcopnp( absa , absad , 65 , ng11 )
2154 dbcopnp( absb , absbd , 235 , ng11 )
2156 dbcop( ka_mo2 , ka_mo2d )
2157 dbcop( kb_mo2 , kb_mo2d )
2158 dbcop( selfref , selfrefd )
2159 dbcop( forref , forrefd )
2179 end module rrlw_kg11_f
2183 ! use parkind ,only : im => kind , rb => kind
2189 !-----------------------------------------------------------------
2190 ! rrtmg_lw ORIGINAL abs. coefficients for interval 12
2191 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
2193 ! Initial version: JJMorcrette, ECMWF, jul1998
2194 ! Revised: MJIacono, AER, jun2006
2195 ! Revised: MJIacono, AER, aug2008
2196 !-----------------------------------------------------------------
2199 ! ---- : ---- : ---------------------------------------------
2204 !-----------------------------------------------------------------
2206 integer , parameter :: no12 = 16
2208 real _cpus :: fracrefao(no12,9)
2209 real _cpus :: kao(9,5,13,no12)
2210 real _cpus :: selfrefo(10,no12)
2211 real _cpus :: forrefo(4,no12)
2213 real _gpudeva :: fracrefaod(:,:)
2214 real _gpudev :: kaod(9,5,13,no12)
2215 real _gpudeva :: selfrefod(:,:)
2216 real _gpudeva :: forrefod(:,:)
2218 !-----------------------------------------------------------------
2219 ! rrtmg_lw COMBINED abs. coefficients for interval 12
2220 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
2222 ! Initial version: JJMorcrette, ECMWF, jul1998
2223 ! Revised: MJIacono, AER, jun2006
2224 ! Revised: MJIacono, AER, aug2008
2225 !-----------------------------------------------------------------
2228 ! ---- : ---- : ---------------------------------------------
2235 !-----------------------------------------------------------------
2237 integer , parameter :: ng12 = 8
2239 real _cpus :: fracrefa(ng12,9)
2240 real _cpusnp :: ka(9,5,13,ng12) ,absa(585,ng12)
2241 real _cpus :: selfref(10,ng12)
2242 real _cpus :: forref(4,ng12)
2244 real _gpudeva :: fracrefad(:,:)
2245 real _gpudevanp :: absad(:,:)
2246 real _gpudeva :: selfrefd(:,:)
2247 real _gpudeva :: forrefd(:,:)
2249 equivalence (ka(1,1,1,1),absa(1,1))
2253 subroutine copyToGPU12
2257 dbcop( fracrefao , fracrefaod )
2258 !dbcop( kao , kaod )
2259 dbcop( selfrefo , selfrefod )
2260 dbcop( forrefo , forrefod )
2262 dbcop( fracrefa , fracrefad )
2264 dbcopnp( absa , absad , 585 , ng12 )
2266 dbcop( selfref , selfrefd )
2267 dbcop( forref , forrefd )
2287 end module rrlw_kg12_f
2291 ! use parkind ,only : im => kind , rb => kind
2297 !-----------------------------------------------------------------
2298 ! rrtmg_lw ORIGINAL abs. coefficients for interval 13
2299 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
2301 ! Initial version: JJMorcrette, ECMWF, jul1998
2302 ! Revised: MJIacono, AER, jun2006
2303 ! Revised: MJIacono, AER, aug2008
2304 !-----------------------------------------------------------------
2307 ! ---- : ---- : ---------------------------------------------
2315 !-----------------------------------------------------------------
2317 integer , parameter :: no13 = 16
2319 real _cpus, dimension(no13) :: fracrefbo
2321 real _cpus :: fracrefao(no13,9)
2322 real _cpus :: kao(9,5,13,no13)
2323 real _cpus :: kao_mco2(9,19,no13)
2324 real _cpus :: kao_mco(9,19,no13)
2325 real _cpus :: kbo_mo3(19,no13)
2326 real _cpus :: selfrefo(10,no13)
2327 real _cpus :: forrefo(4,no13)
2329 real _gpudeva , dimension(:) :: fracrefbod
2331 real _gpudeva :: fracrefaod(:,:)
2332 real _gpudev :: kaod(9,5,13,no13)
2333 real _gpudeva :: kao_mco2d(:,:,:)
2334 real _gpudeva :: kao_mcod(:,:,:)
2335 real _gpudeva :: kbo_mo3d(:,:)
2336 real _gpudeva :: selfrefod(:,:)
2337 real _gpudeva :: forrefod(:,:)
2339 !-----------------------------------------------------------------
2340 ! rrtmg_lw COMBINED abs. coefficients for interval 13
2341 ! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
2343 ! Initial version: JJMorcrette, ECMWF, jul1998
2344 ! Revised: MJIacono, AER, jun2006
2345 ! Revised: MJIacono, AER, aug2008
2346 !-----------------------------------------------------------------
2349 ! ---- : ---- : ---------------------------------------------
2359 !-----------------------------------------------------------------
2361 integer , parameter :: ng13 = 4
2363 real _cpus, dimension(ng13) :: fracrefb
2365 real _cpus :: fracrefa(ng13,9)
2366 real _cpusnp :: ka(9,5,13,ng13) ,absa(585,ng13)
2367 real _cpus :: ka_mco2(9,19,ng13)
2368 real _cpus :: ka_mco(9,19,ng13)
2369 real _cpus :: kb_mo3(19,ng13)
2370 real _cpus :: selfref(10,ng13)
2371 real _cpus :: forref(4,ng13)
2373 real _gpudeva , dimension(:) :: fracrefbd
2375 real _gpudeva :: fracrefad(:,:)
2376 real _gpudevanp :: absad(:,:)
2377 real _gpudeva :: ka_mco2d(:,:,:)
2378 real _gpudeva :: ka_mcod(:,:,:)
2379 real _gpudeva :: kb_mo3d(:,:)
2380 real _gpudeva :: selfrefd(:,:)
2381 real _gpudeva :: forrefd(:,:)
2383 equivalence (ka(1,1,1,1),absa(1,1))
2387 subroutine copyToGPU13
2391 dbcop( fracrefbo , fracrefbod )
2392 dbcop( fracrefao , fracrefaod )
2394 dbcop( kao_mco2 , kao_mco2d )
2395 dbcop( kao_mco , kao_mcod )
2396 dbcop( kbo_mo3 , kbo_mo3d )
2397 dbcop( selfrefo , selfrefod )
2398 dbcop( forrefo , forrefod )
2400 dbcop( fracrefb , fracrefbd )
2401 dbcop( fracrefa , fracrefad )
2403 dbcopnp( absa , absad , 585 , ng13)
2405 dbcop( ka_mco2 , ka_mco2d )
2406 dbcop( ka_mco , ka_mcod )
2407 dbcop( kb_mo3 , kb_mo3d )
2408 dbcop( selfref , selfrefd )
2409 dbcop( forref , forrefd )
2436 end module rrlw_kg13_f
2440 ! use parkind ,only : im => kind , rb => kind
2446 !-----------------------------------------------------------------
2447 ! rrtmg_lw ORIGINAL abs. coefficients for interval 14
2448 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
2450 ! Initial version: JJMorcrette, ECMWF, jul1998
2451 ! Revised: MJIacono, AER, jun2006
2452 ! Revised: MJIacono, AER, aug2008
2453 !-----------------------------------------------------------------
2456 ! ---- : ---- : ---------------------------------------------
2463 !-----------------------------------------------------------------
2465 integer , parameter :: no14 = 16
2467 real _cpus, dimension(no14) :: fracrefao
2468 real _cpus, dimension(no14) :: fracrefbo
2470 real _cpus :: kao(5,13,no14)
2471 real _cpus :: kbo(5,13:59,no14)
2472 real _cpus :: selfrefo(10,no14)
2473 real _cpus :: forrefo(4,no14)
2475 real _gpudeva , dimension(:) :: fracrefaod
2476 real _gpudeva , dimension(:) :: fracrefbod
2478 real _gpudev :: kaod(5,13,no14)
2479 real _gpudev :: kbod(5,13:59,no14)
2480 real _gpudeva :: selfrefod(:,:)
2481 real _gpudeva :: forrefod(:,:)
2483 !-----------------------------------------------------------------
2484 ! rrtmg_lw COMBINED abs. coefficients for interval 14
2485 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
2487 ! Initial version: JJMorcrette, ECMWF, jul1998
2488 ! Revised: MJIacono, AER, jun2006
2489 ! Revised: MJIacono, AER, aug2008
2490 !-----------------------------------------------------------------
2493 ! ---- : ---- : ---------------------------------------------
2503 !-----------------------------------------------------------------
2505 integer , parameter :: ng14 = 2
2507 real _cpus, dimension(ng14) :: fracrefa
2508 real _cpus, dimension(ng14) :: fracrefb
2510 real _cpusnp :: ka(5,13,ng14) ,absa(65,ng14)
2511 real _cpusnp :: kb(5,13:59,ng14),absb(235,ng14)
2512 real _cpus :: selfref(10,ng14)
2513 real _cpus :: forref(4,ng14)
2515 real _gpudeva , dimension(:) :: fracrefad
2516 real _gpudeva , dimension(:) :: fracrefbd
2518 real _gpudevanp :: absad(:,:)
2519 real _gpudevanp :: absbd(:,:)
2520 real _gpudeva :: selfrefd(:,:)
2521 real _gpudeva :: forrefd(:,:)
2523 equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
2527 subroutine copyToGPU14
2532 dbcop( fracrefao , fracrefaod )
2533 dbcop( fracrefbo , fracrefbod )
2535 !dbcop( kao , kaod )
2536 !dbcop( kbo , kbod )
2537 dbcop( selfrefo , selfrefod )
2538 dbcop( forrefo , forrefod )
2540 dbcop( fracrefa , fracrefad )
2541 dbcop( fracrefb , fracrefbd )
2545 dbcopnp( absa , absad , 65 , ng14 )
2546 dbcopnp( absb , absbd , 235 , ng14 )
2548 dbcop( selfref , selfrefd )
2549 dbcop( forref , forrefd )
2575 end module rrlw_kg14_f
2579 ! use parkind ,only : im => kind , rb => kind
2585 !-----------------------------------------------------------------
2586 ! rrtmg_lw ORIGINAL abs. coefficients for interval 15
2587 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
2589 ! Initial version: JJMorcrette, ECMWF, jul1998
2590 ! Revised: MJIacono, AER, jun2006
2591 ! Revised: MJIacono, AER, aug2008
2592 !-----------------------------------------------------------------
2595 ! ---- : ---- : ---------------------------------------------
2601 !-----------------------------------------------------------------
2603 integer , parameter :: no15 = 16
2605 real _cpus :: fracrefao(no15,9)
2606 real _cpus :: kao(9,5,13,no15)
2607 real _cpus :: kao_mn2(9,19,no15)
2608 real _cpus :: selfrefo(10,no15)
2609 real _cpus :: forrefo(4,no15)
2611 real _gpudeva :: fracrefaod(:,:)
2612 real _gpudev :: kaod(9,5,13,no15)
2613 real _gpudeva :: kao_mn2d(:,:,:)
2614 real _gpudeva :: selfrefod(:,:)
2615 real _gpudeva :: forrefod(:,:)
2617 !-----------------------------------------------------------------
2618 ! rrtmg_lw COMBINED abs. coefficients for interval 15
2619 ! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
2621 ! Initial version: JJMorcrette, ECMWF, jul1998
2622 ! Revised: MJIacono, AER, jun2006
2623 ! Revised: MJIacono, AER, aug2008
2624 !-----------------------------------------------------------------
2627 ! ---- : ---- : ---------------------------------------------
2635 !-----------------------------------------------------------------
2637 integer , parameter :: ng15 = 2
2639 real _cpus :: fracrefa(ng15,9)
2640 real _cpusnp :: ka(9,5,13,ng15) ,absa(585,ng15)
2641 real _cpus :: ka_mn2(9,19,ng15)
2642 real _cpus :: selfref(10,ng15)
2643 real _cpus :: forref(4,ng15)
2645 real _gpudeva :: fracrefad(:,:)
2646 real _gpudevanp :: absad(:,:)
2647 real _gpudeva :: ka_mn2d(:,:,:)
2648 real _gpudeva :: selfrefd(:,:)
2649 real _gpudeva :: forrefd(:,:)
2651 equivalence (ka(1,1,1,1),absa(1,1))
2655 subroutine copyToGPU15
2659 dbcop( fracrefao , fracrefaod )
2660 !dbcop( kao , kaod )
2661 dbcop( kao_mn2 , kao_mn2d )
2662 dbcop( selfrefo , selfrefod )
2663 dbcop( forrefo , forrefod )
2665 dbcop( fracrefa , fracrefad )
2668 dbcopnp( absa , absad , 585 , ng15 )
2670 dbcop( ka_mn2 , ka_mn2d )
2671 dbcop( selfref , selfrefd )
2672 dbcop( forref , forrefd )
2693 end module rrlw_kg15_f
2697 ! use parkind ,only : im => kind , rb => kind
2703 !-----------------------------------------------------------------
2704 ! rrtmg_lw ORIGINAL abs. coefficients for interval 16
2705 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
2707 ! Initial version: JJMorcrette, ECMWF, jul1998
2708 ! Revised: MJIacono, AER, jun2006
2709 ! Revised: MJIacono, AER, aug2008
2710 !-----------------------------------------------------------------
2713 ! ---- : ---- : ---------------------------------------------
2719 !-----------------------------------------------------------------
2721 integer , parameter :: no16 = 16
2723 real _cpus, dimension(no16) :: fracrefbo
2725 real _cpus :: fracrefao(no16,9)
2726 real _cpus :: kao(9,5,13,no16)
2727 real _cpus :: kbo(5,13:59,no16)
2728 real _cpus :: selfrefo(10,no16)
2729 real _cpus :: forrefo(4,no16)
2731 real _gpudeva , dimension(:) :: fracrefbod
2732 real _gpudeva :: fracrefaod(:,:)
2733 real _gpudev :: kaod(9,5,13,no16)
2734 real _gpudev :: kbod(5,13:59,no16)
2735 real _gpudeva :: selfrefod(:,:)
2736 real _gpudeva :: forrefod(:,:)
2738 !-----------------------------------------------------------------
2739 ! rrtmg_lw COMBINED abs. coefficients for interval 16
2740 ! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
2742 ! Initial version: JJMorcrette, ECMWF, jul1998
2743 ! Revised: MJIacono, AER, jun2006
2744 ! Revised: MJIacono, AER, aug2008
2745 !-----------------------------------------------------------------
2748 ! ---- : ---- : ---------------------------------------------
2757 !-----------------------------------------------------------------
2759 integer , parameter :: ng16 = 2
2761 real _cpus, dimension(ng16) :: fracrefb
2763 real _cpus :: fracrefa(ng16,9)
2764 real _cpusnp :: ka(9,5,13,ng16) ,absa(585,ng16)
2765 real _cpusnp :: kb(5,13:59,ng16), absb(235,ng16)
2766 real _cpus :: selfref(10,ng16)
2767 real _cpus :: forref(4,ng16)
2769 real _gpudeva , dimension(:) :: fracrefbd
2771 real _gpudeva :: fracrefad(:,:)
2772 real _gpudevanp :: absad(:,:)
2773 real _gpudevanp :: absbd(:,:)
2774 real _gpudeva :: selfrefd(:,:)
2775 real _gpudeva :: forrefd(:,:)
2777 equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1))
2781 subroutine copyToGPU16
2786 dbcop( fracrefao , fracrefaod )
2788 !dbcop( kao , kaod )
2789 !dbcop( kbo , kbod )
2790 dbcop( selfrefo , selfrefod )
2791 dbcop( forrefo , forrefod )
2793 dbcop( fracrefa , fracrefad )
2794 dbcop( fracrefb , fracrefbd )
2798 dbcopnp( absa , absad , 585 , ng16)
2799 dbcopnp( absb , absbd , 235 , ng16)
2801 dbcop( selfref , selfrefd )
2802 dbcop( forref , forrefd )
2827 end module rrlw_kg16_f
2831 ! use parkind ,only : im => kind , rb => kind
2836 real , parameter :: cpdair = 1003.5 ! Specific heat capacity of dry air
2837 ! at constant pressure at 273 K
2841 integer , parameter :: maxAbsorberNameLength = 5, &
2843 character(len = maxAbsorberNameLength), dimension(Absorber), parameter :: &
2844 AbsorberNames = (/ &
2858 integer , dimension(40) :: status
2860 integer , parameter :: keylower = 9, &
2877 subroutine getAbsorberIndex(AbsorberName,AbsorberIndex)
2878 character(len = *), intent(in) :: AbsorberName
2879 integer , intent(out) :: AbsorberIndex
2885 if (trim(AbsorberNames(m)) == trim(AbsorberName)) then
2890 if (AbsorberIndex == -1) then
2891 print*, "Absorber name index lookup failed."
2893 end subroutine getAbsorberIndex
2895 end module rrlw_ncpar
2899 ! use parkind, only : im => kind , rb => kind
2903 !------------------------------------------------------------------
2904 ! rrtmg_lw reference atmosphere
2905 ! Based on standard mid-latitude summer profile
2907 ! Initial version: JJMorcrette, ECMWF, jul1998
2908 ! Revised: MJIacono, AER, jun2006
2909 ! Revised: MJIacono, AER, aug2008
2910 !------------------------------------------------------------------
2913 ! ----- : ---- : ----------------------------------------------
2914 ! pref : real : Reference pressure levels
2915 ! preflog: real : Reference pressure levels, ln(pref)
2916 ! tref : real : Reference temperature levels for MLS profile
2918 !------------------------------------------------------------------
2920 real , dimension(59) :: pref
2921 real , dimension(59) :: preflog
2922 real , dimension(59) :: tref
2923 real :: chi_mls(7,59)
2925 ! (dmb 2012) These GPU arrays are defined as constant so that they are cached.
2926 ! This is really needed because they accessed in quite a scattered pattern.
2927 real _gpucon :: chi_mlsd(7,59)
2928 real _gpucon :: preflogd(59)
2929 real _gpucon :: trefd(59)
2932 # define chi_mlsd chi_mls
2933 # define preflogd preflog
2939 ! (dmb 2012) Copy the reference arrays over to the GPU
2940 subroutine copyToGPUref()
2948 end module rrlw_ref_f
2952 ! use parkind, only : im => kind , rb => kind
2957 !------------------------------------------------------------------
2958 ! rrtmg_lw exponential lookup table arrays
2960 ! Initial version: JJMorcrette, ECMWF, jul1998
2961 ! Revised: MJIacono, AER, Jun 2006
2962 ! Revised: MJIacono, AER, Aug 2007
2963 ! Revised: MJIacono, AER, Aug 2008
2964 !------------------------------------------------------------------
2967 ! ----- : ---- : ----------------------------------------------
2968 ! ntbl : integer: Lookup table dimension
2969 ! tblint : real : Lookup table conversion factor
2970 ! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative
2972 ! exp_tbl: real : Transmittance lookup table
2973 ! tfn_tbl: real : Tau transition function; i.e. the transition of
2974 ! the Planck function from that for the mean layer
2975 ! temperature to that for the layer boundary
2976 ! temperature as a function of optical depth.
2977 ! The "linear in tau" method is used to make
2979 ! pade : real : Pade constant
2980 ! bpade : real : Inverse of Pade constant
2981 !------------------------------------------------------------------
2983 integer , parameter :: ntbl = 10000
2985 real , parameter :: tblint = 10000.0
2987 real , dimension(0:ntbl) :: tau_tbl
2988 real , dimension(0:ntbl) :: exp_tbl
2989 real , dimension(0:ntbl) :: tfn_tbl
2991 real , parameter :: pade = 0.278
2994 end module rrlw_tbl_f
3001 !------------------------------------------------------------------
3002 ! rrtmg_lw version information
3004 ! Initial version: JJMorcrette, ECMWF, jul1998
3005 ! Revised: MJIacono, AER, jun2006
3006 ! Revised: MJIacono, AER, aug2008
3007 !------------------------------------------------------------------
3010 ! ----- : ---- : ----------------------------------------------
3011 !hnamrtm :character:
3012 !hnamini :character:
3013 !hnamcld :character:
3014 !hnamclc :character:
3015 !hnamrtr :character:
3016 !hnamrtx :character:
3017 !hnamrtc :character:
3018 !hnamset :character:
3019 !hnamtau :character:
3020 !hnamatm :character:
3021 !hnamutl :character:
3022 !hnamext :character:
3025 ! hvrrtm :character:
3026 ! hvrini :character:
3027 ! hvrcld :character:
3028 ! hvrclc :character:
3029 ! hvrrtr :character:
3030 ! hvrrtx :character:
3031 ! hvrrtc :character:
3032 ! hvrset :character:
3033 ! hvrtau :character:
3034 ! hvratm :character:
3035 ! hvrutl :character:
3036 ! hvrext :character:
3038 !------------------------------------------------------------------
3040 character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, &
3041 hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext
3042 character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, &
3043 hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext
3048 end module rrlw_vsn_f
3052 ! use parkind, only : im => kind , rb => kind
3053 use parrrtm_f, only : nbndlw, mg, ngptlw, maxinpx
3058 !------------------------------------------------------------------
3059 ! rrtmg_lw spectral information
3061 ! Initial version: JJMorcrette, ECMWF, jul1998
3062 ! Revised: MJIacono, AER, jun2006
3063 ! Revised: MJIacono, AER, aug2008
3064 !------------------------------------------------------------------
3067 ! ----- : ---- : ----------------------------------------------
3068 ! ng : integer: Number of original g-intervals in each spectral band
3069 ! nspa : integer: For the lower atmosphere, the number of reference
3070 ! atmospheres that are stored for each spectral band
3071 ! per pressure level and temperature. Each of these
3072 ! atmospheres has different relative amounts of the
3073 ! key species for the band (i.e. different binary
3074 ! species parameters).
3075 ! nspb : integer: Same as nspa for the upper atmosphere
3076 !wavenum1: real : Spectral band lower boundary in wavenumbers
3077 !wavenum2: real : Spectral band upper boundary in wavenumbers
3078 ! delwave: real : Spectral band width in wavenumbers
3079 ! totplnk: real : Integrated Planck value for each band; (band 16
3080 ! includes total from 2600 cm-1 to infinity)
3081 ! Used for calculation across total spectrum
3082 !totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1)
3083 ! Used for calculation in band 16 only if
3084 ! individual band output requested
3085 !totplnkderiv: real: Integrated Planck function derivative with respect
3086 ! to temperature for each band; (band 16
3087 ! includes total from 2600 cm-1 to infinity)
3088 ! Used for calculation across total spectrum
3089 !totplk16deriv:real: Integrated Planck function derivative with respect
3090 ! to temperature for band 16 (2600-3250 cm-1)
3091 ! Used for calculation in band 16 only if
3092 ! individual band output requested
3094 ! ngc : integer: The number of new g-intervals in each band
3095 ! ngs : integer: The cumulative sum of new g-intervals for each band
3096 ! ngm : integer: The index of each new g-interval relative to the
3097 ! original 16 g-intervals in each band
3098 ! ngn : integer: The number of original g-intervals that are
3099 ! combined to make each new g-intervals in each band
3100 ! ngb : integer: The band index for each new g-interval
3101 ! wt : real : RRTM weights for the original 16 g-intervals
3102 ! rwgt : real : Weights for combining original 16 g-intervals
3103 ! (256 total) into reduced set of g-intervals
3105 ! nxmol : integer: Number of cross-section molecules
3106 ! ixindx : integer: Flag for active cross-sections in calculation
3107 !------------------------------------------------------------------
3109 integer :: ng(nbndlw)
3110 integer :: nspa(nbndlw)
3111 integer :: nspb(nbndlw)
3113 real :: wavenum1(nbndlw)
3114 real :: wavenum2(nbndlw)
3115 real :: delwave(nbndlw)
3117 real :: totplnk(181,nbndlw)
3118 real :: totplk16(181)
3120 real :: totplnkderiv(181,nbndlw)
3121 real :: totplk16deriv(181)
3123 integer :: ngc(nbndlw)
3124 integer :: ngs(nbndlw)
3125 integer :: ngn(ngptlw)
3126 integer :: ngb(ngptlw)
3127 integer :: ngm(nbndlw*mg)
3130 real :: rwgt(nbndlw*mg)
3133 integer :: ixindx(maxinpx)
3135 end module rrlw_wvn_f
3138 ! Fortran-95 implementation of the Mersenne Twister 19937, following
3139 ! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10),
3140 ! adapted cosmetically by making the names more general.
3141 ! Users must declare one or more variables of type randomNumberSequence in the calling
3142 ! procedure which are then initialized using a required seed. If the
3143 ! variable is not initialized the random numbers will all be 0.
3145 ! program testRandoms
3147 ! type(randomNumberSequence) :: randomNumbers
3150 ! randomNumbers = new_RandomNumberSequence(seed = 100)
3152 ! print ('(f12.10, 2x)'), getRandomReal(randomNumbers)
3154 ! end program testRandoms
3156 ! Fortran-95 implementation by
3158 ! NOAA-CIRES Climate Diagnostics Center
3160 ! email: Robert.Pincus@colorado.edu
3162 ! This documentation in the original C program reads:
3163 ! -------------------------------------------------------------
3164 ! A C-program for MT19937, with initialization improved 2002/2/10.
3165 ! Coded by Takuji Nishimura and Makoto Matsumoto.
3166 ! This is a faster version by taking Shawn Cokus's optimization,
3167 ! Matthe Bellew's simplification, Isaku Wada's real version.
3169 ! Before using, initialize the state by using init_genrand(seed)
3170 ! or init_by_array(init_key, key_length).
3172 ! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura,
3173 ! All rights reserved.
3175 ! Redistribution and use in source and binary forms, with or without
3176 ! modification, are permitted provided that the following conditions
3179 ! 1. Redistributions of source code must retain the above copyright
3180 ! notice, this list of conditions and the following disclaimer.
3182 ! 2. Redistributions in binary form must reproduce the above copyright
3183 ! notice, this list of conditions and the following disclaimer in the
3184 ! documentation and/or other materials provided with the distribution.
3186 ! 3. The names of its contributors may not be used to endorse or promote
3187 ! products derived from this software without specific prior written
3190 ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
3191 ! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
3192 ! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
3193 ! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
3194 ! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
3195 ! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
3196 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
3197 ! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
3198 ! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
3199 ! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
3200 ! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
3203 ! Any feedback is very welcome.
3204 ! http://www.math.keio.ac.jp/matumoto/emt.html
3205 ! email: matumoto@math.keio.ac.jp
3206 ! -------------------------------------------------------------
3208 module MersenneTwister_f
3209 ! -------------------------------------------------------------
3211 !use parkind, only : im => kind , rb => kind
3216 ! Algorithm parameters
3219 integer , parameter :: blockSize = 624, &
3221 MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL)
3222 ! UMASK = -2147483648, & ! most significant w-r bits (0x80000000UL)
3223 UMASK = -2147483647, & ! most significant w-r bits (0x80000000UL)
3224 LMASK = 2147483647 ! least significant r bits (0x7fffffffUL)
3225 ! Tempering parameters
3226 integer , parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL)
3227 TMASKC= -272236544 ! (0xefc60000UL)
3230 ! The type containing the state variable
3231 type randomNumberSequence
3232 integer :: currentElement ! = blockSize
3233 integer , dimension(0:blockSize -1) :: state ! = 0
3234 end type randomNumberSequence
3236 interface new_RandomNumberSequence
3237 module procedure initialize_scalar, initialize_vector
3238 end interface new_RandomNumberSequence
3240 public :: randomNumberSequence
3241 public :: new_RandomNumberSequence, finalize_RandomNumberSequence, &
3242 getRandomInt, getRandomPositiveInt, getRandomReal
3243 ! -------------------------------------------------------------
3245 ! -------------------------------------------------------------
3247 ! ---------------------------
3248 function mixbits(u, v)
3249 integer , intent( in) :: u, v
3252 mixbits = ior(iand(u, UMASK), iand(v, LMASK))
3253 end function mixbits
3254 ! ---------------------------
3255 function twist(u, v)
3256 integer , intent( in) :: u, v
3260 integer , parameter, dimension(0:1) :: t_matrix = (/ 0 , MATRIX_A /)
3262 twist = ieor(ishft(mixbits(u, v), -1 ), t_matrix(iand(v, 1 )))
3263 twist = ieor(ishft(mixbits(u, v), -1 ), t_matrix(iand(v, 1 )))
3265 ! ---------------------------
3266 subroutine nextState(twister)
3267 type(randomNumberSequence), intent(inout) :: twister
3272 do k = 0, blockSize - M - 1
3273 twister%state(k) = ieor(twister%state(k + M), &
3274 twist(twister%state(k), twister%state(k + 1 )))
3276 do k = blockSize - M, blockSize - 2
3277 twister%state(k) = ieor(twister%state(k + M - blockSize), &
3278 twist(twister%state(k), twister%state(k + 1 )))
3280 twister%state(blockSize - 1 ) = ieor(twister%state(M - 1 ), &
3281 twist(twister%state(blockSize - 1 ), twister%state(0 )))
3282 twister%currentElement = 0
3284 end subroutine nextState
3285 ! ---------------------------
3286 elemental function temper(y)
3287 integer , intent(in) :: y
3293 x = ieor(y, ishft(y, -11))
3294 x = ieor(x, iand(ishft(x, 7), TMASKB))
3295 x = ieor(x, iand(ishft(x, 15), TMASKC))
3296 temper = ieor(x, ishft(x, -18))
3298 ! -------------------------------------------------------------
3299 ! Public (but hidden) functions
3300 ! --------------------
3301 function initialize_scalar(seed) result(twister)
3302 integer , intent(in ) :: seed
3303 type(randomNumberSequence) :: twister
3306 ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions,
3307 ! MSBs of the seed affect only MSBs of the array state[].
3308 ! 2002/01/09 modified by Makoto Matsumoto
3310 twister%state(0) = iand(seed, -1 )
3311 do i = 1, blockSize - 1 ! ubound(twister%state)
3312 twister%state(i) = 1812433253 * ieor(twister%state(i-1), &
3313 ishft(twister%state(i-1), -30 )) + i
3314 twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines
3316 twister%currentElement = blockSize
3317 end function initialize_scalar
3318 ! -------------------------------------------------------------
3319 function initialize_vector(seed) result(twister)
3320 integer , dimension(0:), intent(in) :: seed
3321 type(randomNumberSequence) :: twister
3323 integer :: i, j, k, nFirstLoop, nWraps
3326 twister = initialize_scalar(19650218 )
3328 nFirstLoop = max(blockSize, size(seed))
3329 do k = 1, nFirstLoop
3330 i = mod(k + nWraps, blockSize)
3331 j = mod(k - 1, size(seed))
3333 twister%state(i) = twister%state(blockSize - 1)
3334 twister%state(1) = ieor(twister%state(1), &
3335 ieor(twister%state(1-1), &
3336 ishft(twister%state(1-1), -30 )) * 1664525 ) + &
3337 seed(j) + j ! Non-linear
3338 twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines
3341 twister%state(i) = ieor(twister%state(i), &
3342 ieor(twister%state(i-1), &
3343 ishft(twister%state(i-1), -30 )) * 1664525 ) + &
3344 seed(j) + j ! Non-linear
3345 twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines
3350 ! Walk through the state array, beginning where we left off in the block above
3352 do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1
3353 twister%state(i) = ieor(twister%state(i), &
3354 ieor(twister%state(i-1), &
3355 ishft(twister%state(i-1), -30 )) * 1566083941 ) - i ! Non-linear
3356 twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines
3359 twister%state(0) = twister%state(blockSize - 1)
3361 do i = 1, mod(nFirstLoop, blockSize) + nWraps
3362 twister%state(i) = ieor(twister%state(i), &
3363 ieor(twister%state(i-1), &
3364 ishft(twister%state(i-1), -30 )) * 1566083941 ) - i ! Non-linear
3365 twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines
3368 twister%state(0) = UMASK
3369 twister%currentElement = blockSize
3371 end function initialize_vector
3372 ! -------------------------------------------------------------
3374 ! --------------------
3375 function getRandomInt(twister)
3376 type(randomNumberSequence), intent(inout) :: twister
3377 integer :: getRandomInt
3378 ! Generate a random integer on the interval [0,0xffffffff]
3379 ! Equivalent to genrand_int32 in the C code.
3380 ! Fortran doesn't have a type that's unsigned like C does,
3381 ! so this is integers in the range -2**31 - 2**31
3382 ! All functions for getting random numbers call this one,
3383 ! then manipulate the result
3385 if(twister%currentElement >= blockSize) call nextState(twister)
3387 getRandomInt = temper(twister%state(twister%currentElement))
3388 twister%currentElement = twister%currentElement + 1
3390 end function getRandomInt
3391 ! --------------------
3392 function getRandomPositiveInt(twister)
3393 type(randomNumberSequence), intent(inout) :: twister
3394 integer :: getRandomPositiveInt
3395 ! Generate a random integer on the interval [0,0x7fffffff]
3397 ! Equivalent to genrand_int31 in the C code.
3402 localInt = getRandomInt(twister)
3403 getRandomPositiveInt = ishft(localInt, -1)
3405 end function getRandomPositiveInt
3406 ! --------------------
3407 !! mji - modified Jan 2007, double converted to rrtmg real kind type
3408 function getRandomReal(twister)
3409 type(randomNumberSequence), intent(inout) :: twister
3410 ! double precision :: getRandomReal
3411 real :: getRandomReal
3412 ! Generate a random number on [0,1]
3413 ! Equivalent to genrand_real1 in the C code
3414 ! The result is stored as double precision but has 32 bit resolution
3418 localInt = getRandomInt(twister)
3419 if(localInt < 0) then
3420 ! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0)
3421 getRandomReal = (localInt + 2.0**32 )/(2.0**32 - 1.0 )
3423 ! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0)
3424 getRandomReal = (localInt )/(2.0**32 - 1.0 )
3427 end function getRandomReal
3428 ! --------------------
3429 subroutine finalize_RandomNumberSequence(twister)
3430 type(randomNumberSequence), intent(inout) :: twister
3432 twister%currentElement = blockSize
3433 twister%state(:) = 0
3434 end subroutine finalize_RandomNumberSequence
3436 ! --------------------
3438 end module MersenneTwister_f
3441 module mcica_random_numbers_f
3443 ! Generic module to wrap random number generators.
3444 ! The module defines a type that identifies the particular stream of random
3445 ! numbers, and has procedures for initializing it and getting real numbers
3446 ! in the range 0 to 1.
3447 ! This version uses the Mersenne Twister to generate random numbers on [0, 1].
3449 use MersenneTwister_f, only: randomNumberSequence, & ! The random number engine.
3450 new_RandomNumberSequence, getRandomReal
3452 !! use time_manager_mod, only: time_type, get_date
3454 !use parkind, only : im => kind , rb => kind
3459 type randomNumberStream
3460 type(randomNumberSequence) :: theNumbers
3461 end type randomNumberStream
3463 interface getRandomNumbers
3464 module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D
3465 end interface getRandomNumbers
3467 interface initializeRandomNumberStream
3468 module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V
3469 end interface initializeRandomNumberStream
3471 public :: randomNumberStream, &
3472 initializeRandomNumberStream, getRandomNumbers
3474 !! initializeRandomNumberStream, getRandomNumbers, &
3477 ! ---------------------------------------------------------
3479 ! ---------------------------------------------------------
3480 function initializeRandomNumberStream_S(seed) result(new)
3481 integer , intent( in) :: seed
3482 type(randomNumberStream) :: new
3484 new%theNumbers = new_RandomNumberSequence(seed)
3486 end function initializeRandomNumberStream_S
3487 ! ---------------------------------------------------------
3488 function initializeRandomNumberStream_V(seed) result(new)
3489 integer , dimension(:), intent( in) :: seed
3490 type(randomNumberStream) :: new
3492 new%theNumbers = new_RandomNumberSequence(seed)
3494 end function initializeRandomNumberStream_V
3495 ! ---------------------------------------------------------
3496 ! Procedures for drawing random numbers
3497 ! ---------------------------------------------------------
3498 subroutine getRandomNumber_Scalar(stream, number)
3499 type(randomNumberStream), intent(inout) :: stream
3500 real , intent( out) :: number
3502 number = getRandomReal(stream%theNumbers)
3503 end subroutine getRandomNumber_Scalar
3504 ! ---------------------------------------------------------
3505 subroutine getRandomNumber_1D(stream, numbers)
3506 type(randomNumberStream), intent(inout) :: stream
3507 real , dimension(:), intent( out) :: numbers
3512 do i = 1, size(numbers)
3513 numbers(i) = getRandomReal(stream%theNumbers)
3515 end subroutine getRandomNumber_1D
3516 ! ---------------------------------------------------------
3517 subroutine getRandomNumber_2D(stream, numbers)
3518 type(randomNumberStream), intent(inout) :: stream
3519 real , dimension(:, :), intent( out) :: numbers
3524 do i = 1, size(numbers, 2)
3525 call getRandomNumber_1D(stream, numbers(:, i))
3527 end subroutine getRandomNumber_2D
3529 ! ! ---------------------------------------------------------
3530 ! ! Constructing a unique seed from grid cell index and model date/time
3531 ! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute
3532 ! ! ---------------------------------------------------------
3533 ! function constructSeed(i, j, time) result(seed)
3534 ! integer , intent( in) :: i, j
3535 ! type(time_type), intent( in) :: time
3536 ! integer , dimension(8) :: seed
3539 ! integer :: year, month, day, hour, minute, second
3542 ! call get_date(time, year, month, day, hour, minute, second)
3543 ! seed = (/ i, j, year, month, day, hour, minute, second /)
3544 ! end function constructSeed
3546 end module mcica_random_numbers_f
3548 module gpu_mcica_subcol_gen_lw
3550 ! --------------------------------------------------------------------------
3552 ! | Copyright 2006-2009, Atmospheric & Environmental Research, Inc. (AER). |
3553 ! | This software may be used, copied, or redistributed as long as it is |
3554 ! | not sold and this copyright notice is reproduced on each copy made. |
3555 ! | This model is provided as is without any express or implied warranties. |
3556 ! | (http://www.rtweb.aer.com/) |
3558 ! --------------------------------------------------------------------------
3560 ! Purpose: Create McICA stochastic arrays for cloud physical or optical properties.
3561 ! Two options are possible:
3562 ! 1) Input cloud physical properties: cloud fraction, ice and liquid water
3563 ! paths, ice fraction, and particle sizes. Output will be stochastic
3564 ! arrays of these variables. (inflag = 1)
3565 ! 2) Input cloud optical properties directly: cloud optical depth, single
3566 ! scattering albedo and asymmetry parameter. Output will be stochastic
3567 ! arrays of these variables. (inflag = 0; longwave scattering is not
3568 ! yet available, ssac and asmc are for future expansion)
3570 ! --------- Modules ----------
3572 !use parkind, only : im => kind , rb => kind
3573 use parrrtm_f, only : nbndlw, ngptlw, mxlay
3574 use rrlw_con_f, only: grav
3575 use rrlw_wvn_f, only: ngb
3586 real _gpudev, allocatable :: pmidd(:, :)
3587 real _gpudev, allocatable :: cldfracd(:,:), clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:)
3589 !$OMP THREADPRIVATE(pmidd,cldfracd,clwpd,ciwpd,cswpd,taucd)
3592 ! public interfaces/functions/subroutines
3593 !public :: mcica_subcol_lwg, generate_stochastic_cloudsg
3597 !------------------------------------------------------------------
3598 ! Public subroutines
3599 !------------------------------------------------------------------
3601 subroutine mcica_subcol_lwg(colstart, ncol, nlay, icld, permuteseed, irng, &
3603 pmidd,clwpd,ciwpd,cswpd,taucd, &
3605 play, cldfrac, ciwp, clwp, cswp, tauc, ngbd, cldfmcl, &
3606 ciwpmcl, clwpmcl, cswpmcl, taucmcl)
3610 integer , intent(in) :: colstart ! column/longitude index
3611 integer , intent(in) :: ncol ! number of columns
3612 integer , intent(in) :: nlay ! number of model layers
3613 integer , intent(in) :: icld ! clear/cloud, cloud overlap flag
3614 integer , intent(in) :: permuteseed ! if the cloud generator is called multiple times,
3615 ! permute the seed between each call.
3616 ! between calls for LW and SW, recommended
3617 ! permuteseed differes by 'ngpt'
3618 integer , intent(in) :: irng ! flag for random number generator
3620 ! 1 = Mersenne Twister
3621 ! integer , intent(in) :: cloudMH, cloudHH
3624 real , intent(in) :: play(:,:) ! layer pressures (mb)
3625 ! Dimensions: (ncol,nlay)
3627 ! Atmosphere/clouds - cldprop
3628 real , intent(in) :: cldfrac(:,:) ! layer cloud fraction
3629 ! Dimensions: (ncol,nlay)
3630 real , intent(in) :: tauc(:,:,:) ! in-cloud optical depth
3631 ! Dimensions: (ncol,nbndlw,nlay)
3632 real , intent(in) :: ciwp(:,:) ! in-cloud ice water path
3633 ! Dimensions: (ncol,nlay)
3634 real , intent(in) :: clwp(:,:) ! in-cloud liquid water path
3635 ! Dimensions: (ncol,nlay)
3636 real , intent(in) :: cswp(:,:) ! in-cloud snow path
3637 ! Dimensions: (ncol,nlay)
3638 integer _gpudev, intent(in) :: ngbd(:)
3640 ! ----- Output -----
3641 ! Atmosphere/clouds - cldprmc [mcica]
3642 real _gpudev, intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica]
3643 ! Dimensions: (ngptlw,ncol,nlay)
3644 real _gpudev, intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica]
3645 ! Dimensions: (ngptlw,ncol,nlay)
3646 real _gpudev, intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica]
3647 ! Dimensions: (ngptlw,ncol,nlay)
3648 real _gpudev, intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica]
3649 ! Dimensions: (ngptlw,ncol,nlay)
3650 real _gpudev, intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica]
3651 ! Dimensions: (ngptlw,ncol,nlay)
3654 ! were module data but changed to arguments because not thread-safe
3656 real :: clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:)
3661 ! Stochastic cloud generator variables [mcica]
3662 integer , parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals)
3663 integer :: ilev ! loop index
3665 real :: pmid(ncol, nlay) ! layer pressures (Pa)
3667 type(dim3) :: dimGrid, dimBlock
3669 integer, save :: counter = 0
3673 ! Return if clear sky; or stop if icld out of range
3684 if (icld.lt.0.or.icld.gt.4) then
3685 stop 'MCICA_SUBCOL: INVALID ICLD'
3688 ! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns
3691 ! Pass particle sizes to new arrays, no subcolumns for these properties yet
3692 ! Convert pressures from mb to Pa
3695 pmid(1:ncol,:nlay) = play(colstart:colstart+ncol-1,:nlay)*1.e2
3697 pmidd(1:ncol,:nlay) = play(colstart:colstart+ncol-1,:nlay)*1.e2
3701 allocate( pmidd(ncol, nlay), cldfracd(ncol, mxlay+1))
3702 allocate( clwpd(ncol, mxlay+1), ciwpd(ncol, mxlay+1), cswpd(ncol, mxlay+1))
3703 allocate( taucd(ncol, nbndlw, mxlay))
3716 end subroutine mcica_subcol_lwg
3718 !-------------------------------------------------------------------------------------------------
3719 _gpuker subroutine generate_stochastic_cloudsg(ncol, nlay, icld, ngbd, &
3721 pmidd,cldfracd,clwpd,ciwpd,cswpd,taucd,changeSeed, &
3723 cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, &
3725 !-------------------------------------------------------------------------------------------------
3727 !----------------------------------------------------------------------------------------------------------------
3728 ! ---------------------
3729 ! Contact: Cecile Hannay (hannay@ucar.edu)
3731 ! Original code: Based on Raisanen et al., QJRMS, 2004.
3733 ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default
3734 ! random number generator, which can be changed to the optional kissvec random number generator
3735 ! with flag 'irng'. Some extra functionality has been commented or removed.
3736 ! Michael J. Iacono, AER, Inc., February 2007
3738 ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns.
3739 ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one
3740 ! and uniform cloud liquid and cloud ice concentration.
3741 ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer
3742 ! and obeys an overlap assumption in the vertical.
3744 ! Overlap assumption:
3745 ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential.
3746 ! The default option is maximum-random (option 3)
3747 ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap
3748 ! This is set with the variable "overlap"
3749 !mji - Exponential overlap option (overlap=4) has been deactivated in this version
3750 ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. )
3753 ! If the stochastic cloud generator is called several times during the same timestep,
3754 ! one should change the seed between the call to insure that the subcolumns are different.
3755 ! This is done by changing the argument 'changeSeed'
3756 ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave ,
3757 ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call
3760 ! We can use arbitrary complicated PDFS.
3761 ! In the present version, we produce homogeneuous clouds (the simplest case).
3762 ! Future developments include using the PDF scheme of Ben Johnson.
3765 ! Option to add diagnostics variables in the history file. (using FINCL in the namelist)
3766 ! nsubcol = number of subcolumns
3767 ! overlap = overlap type (1-3)
3769 ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic)
3770 ! CLDLIQ_S = mean of the subcolumn cloud water
3771 ! CLDICE_S = mean of the subcolumn cloud ice
3774 ! Here: we force that the cloud condensate to be consistent with the cloud fraction
3775 ! i.e we only have cloud condensate when the cell is cloudy.
3776 ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations
3777 ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction
3778 ! without cloud condensate or the opposite).
3779 !---------------------------------------------------------------------------------------------------------------
3784 integer , intent(in) :: ncol ! number of columns
3785 integer , intent(in) :: nlay ! number of layers
3786 integer , intent(in) :: icld ! clear/cloud, cloud overlap flag
3788 integer _gpudev, intent(in) :: ngbd(:)
3791 ! were module data but changed to arguments because not thread-safe
3793 real :: cldfracd(:,:), clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:)
3794 integer, intent(in) :: changeSeed
3797 ! real , intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo
3798 ! Dimensions: (nbndlw,ncol,nlay)
3799 ! inactive - for future expansion
3800 ! real , intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter
3801 ! Dimensions: (nbndlw,ncol,nlay)
3802 ! inactive - for future expansion
3804 real _gpudev, intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction
3805 ! Dimensions: (ncol,ngptlw,nlay)
3806 real _gpudev, intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path
3807 ! Dimensions: (ncol,ngptlw,nlay)
3808 real _gpudev, intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
3809 ! Dimensions: (ncol,ngptlw,nlay)
3810 real _gpudev, intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
3811 ! Dimensions: (ncol,ngptlw,nlay)
3812 real _gpudev, intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
3813 ! Dimensions: (ncol,ngptlw,nlay)
3814 ! real , intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
3815 ! Dimensions: (ngptlw,ncol,nlay)
3816 ! inactive - for future expansion
3817 ! real , intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter
3818 ! Dimensions: (ngptlw,ncol,nlay)
3819 ! inactive - for future expansion
3821 !integer, value, intent(in) :: counter
3826 real :: RIND1, RIND2, ZCW, SIGMA_QCW
3827 integer :: IND1, IND2
3829 real :: CDF3(mxlay) ! random numbers
3832 integer, parameter :: nsubcol = 140
3834 ! Constants (min value for cloud fraction and cloud water and ice)
3835 ! real , parameter :: cldmin = 1.0e-20 ! min cloud fraction
3836 ! real , parameter :: qmin = 1.0e-10 ! min cloud water and cloud ice (not used)
3838 ! Variables related to random number and seed
3840 real :: CDF(mxlay), CDF2(mxlay) ! random numbers
3841 integer :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
3842 real :: rand_num ! random number (kissvec)
3844 real :: CDF(ncol,mxlay), CDF2(mxlay) ! random numbers
3845 integer,dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec)
3846 real ,dimension(ncol) :: rand_num ! random number (kissvec)
3848 integer :: iseed ! seed to create random number (Mersenne Teister)
3849 real :: rand_num_mt ! random number (Mersenne Twister)
3851 ! Flag to identify cloud fraction in subcolumns
3852 ! logical :: iscloudy(mxlay) ! flag that says whether a gridbox is cloudy
3855 integer :: ilev, isubcol, i, n ! indices
3857 integer :: iplon, gp
3858 integer :: m, k, n1, kiss
3860 m(k, n1) = ieor (k, ishft (k, n1) )
3862 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
3863 gp = (blockidx%y-1) * blockdim%y + threadidx%y
3865 !------------------------------------------------------------------------------------------
3866 ! print *, "ppp ", iplon, gp
3867 if (iplon <= ncol .and. gp <= nsubcol) then
3868 # define ILOOP_S_CPU
3869 # define ILOOP_E_CPU
3871 # define ILOOP_S_CPU do iplon = 1, ncol
3872 # define ILOOP_E_CPU enddo
3876 ! ----- Create seed --------
3878 ! Advance randum number generator by changeseed values
3880 ! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works.
3881 ! Must use pmid from bottom four layers.
3883 seed1 = (pmidd(iplon,1) - int(pmidd(iplon,1))) * 1000000000 + (gp) * 11
3884 seed3 = (pmidd(iplon,3) - int(pmidd(iplon,3))) * 1000000000 + (gp) * 13
3888 ! Have it agree with the original _lw.F version, jm 20141222
3890 seed1(iplon) = (pmidd(iplon,1) - int(pmidd(iplon,1))) * 1000000000
3891 seed2(iplon) = (pmidd(iplon,2) - int(pmidd(iplon,2))) * 1000000000
3892 seed3(iplon) = (pmidd(iplon,3) - int(pmidd(iplon,3))) * 1000000000
3893 seed4(iplon) = (pmidd(iplon,4) - int(pmidd(iplon,4))) * 1000000000
3895 ! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon))
3897 seed1(iplon) = 69069 * seed1(iplon) + 1327217885
3898 seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5)
3899 seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16)
3900 seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16)
3901 kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon)
3902 rand_num(iplon) = kiss*2.328306e-10 + 0.5
3912 ! ------ Apply overlap assumption --------
3914 ! generate the random numbers
3924 call kissvec(seed1, seed2, seed3, seed4, rand_num)
3925 CDF(iplon,ilev) = rand_num
3930 ! Maximum-Random overlap
3934 call kissvec(seed1, seed2, seed3, seed4, rand_num)
3935 CDF(ilev) = rand_num
3940 if (CDF(ilev-1) > 1. - cldfracd(iplon, ilev-1)) then
3941 CDF(ilev) = CDF(ilev-1)
3943 CDF(ilev) = CDF(ilev) * (1. - cldfracd(iplon, ilev-1))
3950 call kissvec(seed1, seed2, seed3, seed4, rand_num)
3952 CDF(ilev) = rand_num
3963 call kissvec(seed1, seed2, seed3, seed4, rand_num)
3964 CDF(iplon,ilev) = rand_num
3967 CALL wrf_error_fatal("icld == 1 not supported: module_ra_rrtmg_lwf.F")
3970 ! Maximum-Random overlap
3975 ! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon))
3976 seed1(iplon) = 69069 * seed1(iplon) + 1327217885
3977 seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5)
3978 seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16)
3979 seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16)
3980 kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon)
3981 CDF(iplon,ilev) = kiss*2.328306e-10 + 0.5
3988 if (CDF(iplon,ilev-1) > 1. - cldfracd(iplon, ilev-1)) then
3989 CDF(iplon,ilev) = CDF(iplon,ilev-1)
3991 CDF(iplon,ilev) = CDF(iplon,ilev) * (1. - cldfracd(iplon, ilev-1))
4000 ! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon))
4001 seed1(iplon) = 69069 * seed1(iplon) + 1327217885
4002 seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5)
4003 seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16)
4004 seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16)
4005 kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon)
4006 rand_num(iplon) = kiss*2.328306e-10 + 0.5
4010 CDF(iplon,ilev) = rand_num(iplon)
4021 cfs = cldfracd(iplon, ilev)
4022 ! do gp = 1, nsubcol
4024 if (CDF(ilev) >=1. - cfs) then
4026 if (CDF(iplon,ilev) >=1. - cfs) then
4029 cld_stoch(iplon,gp,ilev) = 1.
4030 clwp_stoch(iplon,gp,ilev) = clwpd(iplon,ilev)
4031 ciwp_stoch(iplon,gp,ilev) = ciwpd(iplon,ilev)
4032 cswp_stoch(iplon,gp,ilev) = cswpd(iplon,ilev)
4034 tauc_stoch(iplon,gp,ilev) = taucd(iplon,n,ilev)
4037 cld_stoch(iplon,gp,ilev) = 0.
4038 clwp_stoch(iplon,gp,ilev) = 0.
4039 ciwp_stoch(iplon,gp,ilev) = 0.
4040 cswp_stoch(iplon,gp,ilev) = 0.
4041 tauc_stoch(iplon,gp,ilev) = 0.
4042 ! ssac_stoch(isubcol,i,ilev) = 1.
4043 ! asmc_stoch(isubcol,i,ilev) = 1.
4055 end subroutine generate_stochastic_cloudsg
4057 _gpuked subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr)
4058 !--------------------------------------------------------------------------------------------------
4060 ! public domain code
4061 ! made available from http://www.fortran.com/
4062 ! downloaded by pjr on 03/16/04 for NCAR CAM
4063 ! converted to vector form, functions inlined by pjr,mvr on 05/10/2004
4065 ! The KISS (Keep It Simple Stupid) random number generator. Combines:
4066 ! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32.
4067 ! (2) A 3-shift shift-register generator, period 2^32-1,
4068 ! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59
4069 ! Overall period>2^123;
4071 real , intent(inout) :: ran_arr
4072 integer , intent(inout) :: seed1,seed2,seed3,seed4
4073 integer :: i,sz,kiss
4077 m(k, n) = ieor (k, ishft (k, n) )
4079 seed1 = 69069 * seed1 + 1327217885
4080 seed2 = m (m (m (seed2, 13), - 17), 5)
4081 seed3 = 18000 * iand (seed3, 65535) + ishft (seed3, - 16)
4082 seed4 = 30903 * iand (seed4, 65535) + ishft (seed4, - 16)
4083 kiss = seed1 + seed2 + ishft (seed3, 16) + seed4
4084 ran_arr = kiss*2.328306e-10 + 0.5
4086 end subroutine kissvec
4088 end module gpu_mcica_subcol_gen_lw
4090 ! (dmb 2012) This is the GPU version of the cldprmc routine. I have parallelized across
4091 ! all 3 dimensions (columns, g-points, and layers) to make this routine run very fast on the GPU.
4092 ! The greatest speedup was obtained by switching the indices for the cloud variables so that
4093 ! the columns were the least significant (leftmost) dimension
4095 module gpu_rrtmg_lw_cldprmc
4097 ! --------------------------------------------------------------------------
4099 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
4100 ! | This software may be used, copied, or redistributed as long as it is |
4101 ! | not sold and this copyright notice is reproduced on each copy made. |
4102 ! | This model is provided as is without any express or implied warranties. |
4103 ! | (http://www.rtweb.aer.com/) |
4105 ! --------------------------------------------------------------------------
4107 ! --------- Modules ----------
4109 ! use parkind, only : im => kind , rb => kind
4110 use parrrtm_f, only : ngptlw, nbndlw
4111 use rrlw_cld_f, only: abscld1, absliq0, absliq1, &
4112 absice0, absice1, absice2, absice3
4113 ! use rrlw_wvn_f, only: ngb
4114 use rrlw_vsn_f, only: hvrclc, hnamclc
4122 ! (dmb 2012) I moved most GPU variables so that they are module level variables.
4123 ! PGI Fortran seems to sometimes have trouble passing arrays into kernels correctly.
4124 ! Using module level variables bypasses this issue and allows for cleaner code.
4125 ! (jm 2014) but not thread safe.
4126 integer _gpudev, allocatable :: inflagd(:), iceflagd(:), liqflagd(:)
4128 real _gpudev, allocatable :: ciwpmcd(:,:,:) ! in-cloud ice water path [mcica]
4129 real _gpudev, allocatable :: clwpmcd(:,:,:) ! in-cloud liquid water path [mcica]
4130 real _gpudev, allocatable :: cswpmcd(:,:,:) ! in-cloud snow water path [mcica]
4131 ! Dimensions: (ncol,ngptlw,nlayers)
4132 real _gpudev, allocatable :: relqmcd(:,:) ! liquid particle effective radius (microns)
4133 real _gpudev, allocatable :: reicmcd(:,:) ! ice particle effective size (microns)
4134 real _gpudev, allocatable :: resnmcd(:,:) ! snow particle effective size (microns)
4135 ! Dimensions: (ncol,nlayers)
4136 ! specific definition of reicmc depends on setting of iceflag:
4137 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
4138 ! r_ec must be >= 10.0 microns
4139 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
4140 ! r_ec range is limited to 13.0 to 130.0 microns
4141 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
4142 ! r_k range is limited to 5.0 to 131.0 microns
4143 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
4144 ! dge range is limited to 5.0 to 140.0 microns
4145 ! [dge = 1.0315 * r_ec]
4147 real _gpucon, dimension(2) :: absice0d
4148 real _gpucon, dimension(2,5) :: absice1d
4149 real _gpucon, dimension(43,16) :: absice2d
4150 real _gpucon, dimension(46,16) :: absice3d
4151 real _gpucon, dimension(58,16) :: absliq1d
4154 ! (jm 2014) My reading of threadprivate documentation says this should work,
4155 ! see http://publib.boulder.ibm.com/infocenter/comphelp/v101v121
4156 ! but keep an eye on it. Different vendors have extended this in different ways.
4157 ! See also the intel -openmp-threadprivate=legacy/compat documentation.
4158 !$OMP THREADPRIVATE(inflagd,iceflagd,liqflagd,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, &
4159 !$OMP absice0d,absice1d,absice2d,absice3d,absliq1d)
4164 ! ------------------------------------------------------------------------------
4165 _gpuker subroutine cldprmcg(ncol, nlayers, &
4167 inflagd,iceflagd,liqflagd,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, &
4168 absice0d,absice1d,absice2d,absice3d,absliq1d, &
4170 cldfmc, taucmc, ngb, icb, ncbands, icldlyr)
4171 ! ------------------------------------------------------------------------------
4173 ! Purpose: Compute the cloud optical depth(s) for each cloudy layer.
4175 ! ------- Input -------
4177 integer, value, intent(in) :: ncol ! total number of columns
4178 integer, value, intent(in) :: nlayers ! total number of layers
4184 real , intent(in) :: cldfmc(ncol, ngptlw, nlayers+1) ! cloud fraction [mcica]
4186 integer , intent(out) :: icldlyr( ncol, nlayers+1)
4187 integer , dimension(140), intent(in) :: ngb
4188 integer , intent(in) :: icb(16)
4189 real , intent(inout) :: taucmc(:,:,:) ! cloud optical depth [mcica]
4191 real , parameter :: absliq0 = 0.0903614
4193 ! ------- Output -------
4195 integer , intent(out) :: ncbands(:) ! number of cloud spectral bands
4198 !changed to arguments for thread safety on CPU
4199 integer :: inflagd(:), iceflagd(:), liqflagd(:)
4201 real :: ciwpmcd(:,:,:) ! in-cloud ice water path [mcica]
4202 real :: clwpmcd(:,:,:) ! in-cloud liquid water path [mcica]
4203 real :: cswpmcd(:,:,:) ! in-cloud snow water path [mcica]
4204 ! Dimensions: (ncol,ngptlw,nlayers)
4205 real :: relqmcd(:,:) ! liquid particle effective radius (microns)
4206 real :: reicmcd(:,:) ! ice particle effective size (microns)
4207 real :: resnmcd(:,:) ! snow particle effective size (microns)
4208 ! Dimensions: (ncol,nlayers)
4209 ! specific definition of reicmc depends on setting of iceflag:
4210 ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
4211 ! r_ec must be >= 10.0 microns
4212 ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
4213 ! r_ec range is limited to 13.0 to 130.0 microns
4214 ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
4215 ! r_k range is limited to 5.0 to 131.0 microns
4216 ! iceflag = 3: generalized effective size, dge, (Fu, 1996),
4217 ! dge range is limited to 5.0 to 140.0 microns
4218 ! [dge = 1.0315 * r_ec]
4220 real, dimension(2) :: absice0d
4221 real, dimension(2,5) :: absice1d
4222 real, dimension(43,16) :: absice2d
4223 real, dimension(46,16) :: absice3d
4224 real, dimension(58,16) :: absliq1d
4227 ! ------- Local -------
4230 integer :: lay ! Layer index
4231 integer :: ib ! spectral band index
4232 integer :: ig ! g-point interval index
4236 real :: abscoice ! ice absorption coefficients
4237 real :: abscoliq ! liquid absorption coefficients
4238 real :: abscosno ! snow absorption coefficients
4239 real :: cwp ! cloud water path
4240 real :: radice ! cloud ice effective size (microns)
4241 real :: radliq ! cloud liquid droplet radius (microns)
4242 real :: radsno ! cloud snow effective radius (microns)
4245 real , parameter :: eps = 1.e-6 ! epsilon
4246 real , parameter :: cldmin = 1.e-20 ! minimum value for cloud quantities
4248 character*256 errmess
4249 ! ------- Definitions -------
4251 ! Explanation of the method for each value of INFLAG. Values of
4252 ! 0 or 1 for INFLAG do not distingish being liquid and ice clouds.
4253 ! INFLAG = 2 does distinguish between liquid and ice clouds, and
4254 ! requires further user input to specify the method to be used to
4255 ! compute the aborption due to each.
4256 ! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray)
4257 ! optical depth are input.
4258 ! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud
4259 ! water path (g/m2) are input. The (gray) cloud optical
4260 ! depth is computed as in CCM2.
4261 ! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud
4262 ! water path (g/m2), and cloud ice fraction are input.
4263 ! ICEFLAG = 0: The ice effective radius (microns) is input and the
4264 ! optical depths due to ice clouds are computed as in CCM3.
4265 ! ICEFLAG = 1: The ice effective radius (microns) is input and the
4266 ! optical depths due to ice clouds are computed as in
4267 ! Ebert and Curry, JGR, 97, 3831-3836 (1992). The
4268 ! spectral regions in this work have been matched with
4269 ! the spectral bands in RRTM to as great an extent
4271 ! E&C 1 IB = 5 RRTM bands 9-16
4272 ! E&C 2 IB = 4 RRTM bands 6-8
4273 ! E&C 3 IB = 3 RRTM bands 3-5
4274 ! E&C 4 IB = 2 RRTM band 2
4275 ! E&C 5 IB = 1 RRTM band 1
4276 ! ICEFLAG = 2: The ice effective radius (microns) is input and the
4277 ! optical properties due to ice clouds are computed from
4278 ! the optical properties stored in the RT code,
4279 ! STREAMER v3.0 (Reference: Key. J., Streamer
4280 ! User's Guide, Cooperative Institute for
4281 ! Meteorological Satellite Studies, 2001, 96 pp.).
4282 ! Valid range of values for re are between 5.0 and
4284 ! ICEFLAG = 3: The ice generalized effective size (dge) is input
4285 ! and the optical properties, are calculated as in
4286 ! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution
4287 ! tables which were appropriately averaged for the
4288 ! bands in RRTM_LW. Linear interpolation is used to
4289 ! get the coefficients from the stored tables.
4290 ! Valid range of values for dge are between 5.0 and
4292 ! LIQFLAG = 0: The optical depths due to water clouds are computed as
4294 ! LIQFLAG = 1: The water droplet effective radius (microns) is input
4295 ! and the optical depths due to water clouds are computed
4296 ! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993).
4297 ! The values for absorption coefficients appropriate for
4298 ! the spectral bands in RRTM have been obtained for a
4299 ! range of effective radii by an averaging procedure
4300 ! based on the work of J. Pinto (private communication).
4301 ! Linear interpolation is used to get the absorption
4302 ! coefficients for the input effective radius.
4304 ! (dmb 2012) Here insead of looping over the column, layer, and band dimensions,
4305 ! I compute the index for each dimension from the grid and block layout. This
4306 ! function is called once per each thread, and each thread has a unique combination of
4307 ! column, layer, and g-point.
4310 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
4311 lay = (blockidx%y-1) * blockdim%y + threadidx%y
4312 ig = (blockidx%z-1) * blockdim%z + threadidx%z
4313 ! (dmb 2012) Make sure that the column, layer, and g-points are all within the proper
4314 ! range. They can be out of range if we select certain block configurations due to
4316 if (iplon<=ncol .and. lay<=nlayers .and. ig<=ngptlw) then
4324 ! (dmb 2012) all of the cloud variables have been modified so that the column dimensions
4325 ! is least significant.
4326 if (cldfmc(iplon,ig,lay) .eq. 1. ) then
4327 icldlyr(iplon, lay)=1
4329 cwp = ciwpmcd(iplon,ig,lay) + clwpmcd(iplon,ig,lay) + cswpmcd(iplon,ig,lay)
4330 ! (dmb 2012) the stop commands were removed because they aren't supported on the GPU
4331 if (cldfmc(iplon,ig,lay) .ge. cldmin .and. &
4332 (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then
4335 !jm top cldprmc inflagd 5
4336 !jm top cldprmc iceflagd 5
4337 !jm top cldprmc liqflagd 1
4340 !jm zap if(inflagd(iplon) .eq. 2) then
4341 if(inflagd(iplon) .ge. 2) then
4342 radice = reicmcd(iplon, lay)
4344 ! Calculation of absorption coefficients due to ice clouds.
4345 if (ciwpmcd(iplon,ig,lay)+cswpmcd(iplon,ig,lay) .eq. 0.0) then
4349 elseif (iceflagd(iplon) .eq. 0) then
4350 abscoice= absice0d(1) + absice0d(2)/radice
4353 elseif (iceflagd(iplon) .eq. 1) then
4356 abscoice = absice1d(1,ib) + absice1d(2,ib)/radice
4359 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
4361 elseif (iceflagd(iplon) .eq. 2) then
4363 factor = (radice - 2.)/3.
4365 ! mji - temporary fix to prevent out of range subscripts
4366 if (index .le. 0) index = 1
4367 if (index .ge. 43) index = 42
4368 ! if (index .eq. 43) index = 42
4369 fint = factor - float(index)
4372 absice2d(index,ib) + fint * &
4373 (absice2d(index+1,ib) - (absice2d(index,ib)))
4376 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
4378 !jm elseif (iceflagd(iplon) .eq. 3) then
4379 elseif (iceflagd(iplon) .ge. 3) then
4381 factor = (radice - 2.)/3.
4383 ! mji - temporary fix to prevent out of range subscripts
4384 if (index .le. 0) index = 1
4385 if (index .ge. 46) index = 45
4386 ! if (index .eq. 46) index = 45
4387 fint = factor - float(index)
4390 absice3d(index,ib) + fint * &
4391 (absice3d(index+1,ib) - (absice3d(index,ib)))
4395 !..Incorporate additional effects due to snow.
4396 if (cswpmcd(iplon,ig,lay).gt.0.0 .and. iceflagd(iplon) .eq. 5) then
4397 radsno = resnmcd(iplon,lay)
4400 if (radsno .lt. 5.0 .or. radsno .gt. 140.0) then
4401 write(errmess,'(A,i5,i5,i5,f8.2,f8.2)' ) &
4402 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' &
4403 ,iplon,ig, lay, cswpmcd(iplon,ig,lay), radsno
4404 call wrf_error_fatal(errmess)
4409 factor = (radsno - 2.)/3.
4411 ! mji - temporary fix to prevent out of range subscripts
4412 if (index .le. 0) index = 1
4413 if (index .ge. 46) index = 45
4414 ! if (index .eq. 46) index = 45
4415 fint = factor - float(index)
4418 absice3d(index,ib) + fint * &
4419 (absice3d(index+1,ib) - (absice3d(index,ib)))
4422 ! Calculation of absorption coefficients due to water clouds.
4423 !jm if (liqflagd(iplon) .eq. 1) then
4424 if (clwpmcd(iplon,ig,lay) .eq. 0.0) then
4426 else if (liqflagd(iplon) .eq. 0) then
4428 else if (liqflagd(iplon) .eq. 1) then
4429 radliq = relqmcd(iplon, lay)
4430 index = int(radliq - 1.5 )
4431 ! mji - temporary fix to prevent out of range subscripts
4432 if (index .le. 0) index = 1
4433 if (index .ge. 58) index = 57
4434 ! if (index .eq. 0) index = 1
4435 ! if (index .eq. 58) index = 57
4436 fint = radliq - 1.5 - float(index)
4439 absliq1d(index,ib) + fint * &
4440 (absliq1d(index+1,ib) - (absliq1d(index,ib)))
4443 taucmc(iplon,ig,lay) = ciwpmcd(iplon,ig,lay) * abscoice + &
4444 clwpmcd(iplon,ig,lay) * abscoliq + &
4445 cswpmcd(iplon,ig,lay) * abscosno
4459 end subroutine cldprmcg
4466 ! (dmb 2012) This subroutine allocates the module level arrays on the GPU
4467 subroutine allocateGPUcldprmcg(ncol, nlay, ngptlw)
4469 integer , intent(in) :: nlay, ngptlw, ncol
4471 allocate( inflagd(ncol), iceflagd(ncol), liqflagd(ncol))
4472 allocate( relqmcd(ncol, nlay+1), reicmcd(ncol, nlay+1))
4473 allocate( resnmcd(ncol, nlay+1))
4475 allocate( ciwpmcd(ncol, ngptlw, nlay+1))
4476 allocate( clwpmcd(ncol, ngptlw, nlay+1))
4477 allocate( cswpmcd(ncol, ngptlw, nlay+1))
4482 ! (dmb 2012) This subroutine deallocates any GPU arrays.
4483 subroutine deallocateGPUcldprmcg()
4486 deallocate( inflagd, iceflagd, liqflagd)
4487 deallocate( relqmcd, reicmcd, resnmcd)
4489 deallocate( ciwpmcd)
4490 deallocate( clwpmcd)
4491 deallocate( cswpmcd)
4496 ! (dmb 2012) This subroutine copies input data from the CPU over to the GPU
4497 ! for use in the cldprmcg subroutine.
4498 subroutine copyGPUcldprmcg(inflag, iceflag, liqflag,&
4499 absice0, absice1, absice2, absice3, absliq1)
4501 integer :: inflag(:), iceflag(:), liqflag(:)
4503 real , dimension(:) :: absice0
4504 real , dimension(:,:) :: absice1
4505 real , dimension(:,:) :: absice2
4506 real , dimension(:,:) :: absice3
4507 real , dimension(:,:) :: absliq1
4523 end module gpu_rrtmg_lw_cldprmc
4525 ! (dmb 2012) This is the GPU version of the rtrnmc subroutine. This has been greatly
4526 ! modified to be efficiently run on the GPU. Originally, there was a g-point loop within
4527 ! this subroutine to perform the summation of the fluxes over the g-points. This has been
4528 ! modified so that this subroutine can be run in parallel across the g-points. This was
4529 ! absolutely critical because of two reasons.
4530 ! 1. For a relatively low number of profiles, there wouldn't be enough threads to keep
4531 ! the GPU busy enough to run at full potential. As a result of this, this subroutine
4532 ! would end up being a bottleneck.
4533 ! 2. The memory access for the GPU arrays would be innefient because there would be very
4534 ! little coalescing which is critical for obtaining optimal performance.
4536 module gpu_rrtmg_lw_rtrnmc
4538 ! --------------------------------------------------------------------------
4540 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
4541 ! | This software may be used, copied, or redistributed as long as it is |
4542 ! | not sold and this copyright notice is reproduced on each copy made. |
4543 ! | This model is provided as is without any express or implied warranties. |
4544 ! | (http://www.rtweb.aer.com/) |
4546 ! --------------------------------------------------------------------------
4548 ! --------- Modules ----------
4550 ! use parkind, only : im => kind , rb => kind
4551 use parrrtm_f, only : mg, nbndlw, ngptlw, mxlay
4552 use rrlw_con_f, only: fluxfac, heatfac
4553 ! (jm 2014) not sure why the GPU version defines ntbl 2x instead of using it
4554 ! from rrlw_tbl, but will leave it alone for now. However, it is an error when
4555 ! compiling for CPU, at least with the Intel compiler. Says it's defined twice.
4557 use rrlw_tbl_f, only: bpade, tblint, tau_tbl, exp_tbl, tfn_tbl
4559 use rrlw_tbl_f, only: bpade, tblint, tau_tbl, exp_tbl, tfn_tbl, ntbl
4569 ! (jm 2014) see comment above)
4570 integer(kind=4), parameter :: ntbl = 10000
4573 integer _gpucon :: ngsd(nbndlw)
4575 ! (dmb 2012) I moved most GPU variables so that they are module level variables.
4576 ! PGI Fortran seems to sometimes have trouble passing arrays into kernels correctly.
4577 ! Using module level variables bypasses this issue and allows for cleaner code.
4578 ! (jm 2014) but not thread safe.
4581 real , allocatable _gpudev :: taucmcd(:,:,:)
4583 real , allocatable _gpudev, dimension(:,:) :: pzd ! level (interface) pressures (hPa, mb)
4584 ! Dimensions: (ncol,0:nlayers)
4585 real , allocatable _gpudev, dimension(:) :: pwvcmd ! precipitable water vapor (cm)
4586 ! Dimensions: (ncol)
4587 real , allocatable _gpudev, dimension(:,:) :: semissd ! lw surface emissivity
4588 ! Dimensions: (ncol,nbndlw)
4589 real , allocatable _gpudev, dimension(:,:,:) :: planklayd !
4590 ! Dimensions: (ncol,nlayers,nbndlw)
4591 real , allocatable _gpudev, dimension(:,:,:) :: planklevd !
4592 ! Dimensions: (ncol,0:nlayers,nbndlw)
4593 real, allocatable _gpudev, dimension(:,:) :: plankbndd !
4594 ! Dimensions: (ncol,nbndlw)
4596 real , allocatable _gpudev :: gurad(:,:,:) ! upward longwave flux (w/m2)
4597 real , allocatable _gpudev :: gdrad(:,:,:) ! downward longwave flux (w/m2)
4598 real , allocatable _gpudev :: gclrurad(:,:,:) ! clear sky upward longwave flux (w/m2)
4599 real , allocatable _gpudev :: gclrdrad(:,:,:) ! clear sky downward longwave flux (w/m2)
4601 real _gpudev, allocatable :: gdtotuflux_dtd(:,:,:) ! change in upward longwave flux (w/m2/k)
4602 ! with respect to surface temperature
4604 real _gpudev, allocatable :: gdtotuclfl_dtd(:,:,:) ! change in clear sky upward longwave flux (w/m2/k)
4605 ! with respect to surface temperature
4609 integer _gpudev :: idrvd ! flag for calculation of dF/dt from
4610 ! Planck derivative [0=off, 1=on]
4611 real _gpucon :: bpaded
4612 real _gpucon :: heatfacd
4613 real _gpucon :: fluxfacd
4614 real _gpucon :: a0d(nbndlw), a1d(nbndlw), a2d(nbndlw)
4615 integer _gpucon :: delwaved(nbndlw)
4616 real , allocatable _gpudev :: totufluxd(:,:) ! upward longwave flux (w/m2)
4617 real , allocatable _gpudev :: totdfluxd(:,:) ! downward longwave flux (w/m2)
4618 real , allocatable _gpudev :: fnetd(:,:) ! net longwave flux (w/m2)
4619 real , allocatable _gpudev :: htrd(:,:) ! longwave heating rate (k/day)
4620 real , allocatable _gpudev :: totuclfld(:,:) ! clear sky upward longwave flux (w/m2)
4621 real , allocatable _gpudev :: totdclfld(:,:) ! clear sky downward longwave flux (w/m2)
4622 real , allocatable _gpudev :: fnetcd(:,:) ! clear sky net longwave flux (w/m2)
4623 real , allocatable _gpudev :: htrcd(:,:) ! clear sky longwave heating rate (k/day)
4624 real , allocatable _gpudev :: dtotuflux_dtd(:,:) ! change in upward longwave flux (w/m2/k)
4625 ! with respect to surface temperature
4626 real , allocatable _gpudev :: dtotuclfl_dtd(:,:) ! change in clear sky upward longwave flux (w/m2/k)
4627 ! with respect to surface temperature
4628 real , allocatable _gpudev :: dplankbnd_dtd(:,:)
4631 !$OMP THREADPRIVATE( taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad,&
4632 !$OMP gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d, &
4633 !$OMP delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd, &
4634 !$OMP dtotuclfl_dtd,dplankbnd_dtd )
4639 !-----------------------------------------------------------------------------
4640 _gpuker subroutine rtrnmcg(ncol, nlayers, istart, iend, iout &
4641 #include "rrtmg_lw_cpu_args.h"
4642 ,ngb,icldlyr, taug, fracsd, cldfmcd)
4643 !-----------------------------------------------------------------------------
4645 ! Original version: E. J. Mlawer, et al. RRTM_V3.0
4646 ! Revision for GCMs: Michael J. Iacono; October, 2002
4647 ! Revision for F90: Michael J. Iacono; June, 2006
4648 ! Revision for dFdT option: M. J. Iacono and E. J. Mlawer, November 2009
4650 ! This program calculates the upward fluxes, downward fluxes, and
4651 ! heating rates for an arbitrary clear or cloudy atmosphere. The input
4652 ! to this program is the atmospheric profile, all Planck function
4653 ! information, and the cloud fraction by layer. A variable diffusivity
4654 ! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9
4655 ! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of
4656 ! the column water vapor, and other bands use a value of 1.66. The Gaussian
4657 ! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that
4658 ! use of the emissivity angle for the flux integration can cause errors of
4659 ! 1 to 4 W/m2 within cloudy layers.
4660 ! Clouds are treated with the McICA stochastic approach and maximum-random
4662 ! This subroutine also provides the optional capability to calculate
4663 ! the derivative of upward flux respect to surface temperature using
4664 ! the pre-tabulated derivative of the Planck function with respect to
4665 ! temperature integrated over each spectral band.
4666 !***************************************************************************
4668 ! ------- Declarations -------
4671 integer(kind=4), value, intent(in) :: nlayers ! total number of layers
4672 integer(kind=4), value, intent(in) :: ncol ! total number of columns
4673 integer(kind=4), value, intent(in) :: istart ! beginning band of calculation
4674 integer(kind=4), value, intent(in) :: iend ! ending band of calculation
4675 integer(kind=4), value, intent(in) :: iout ! output option flag
4676 integer , intent(in) :: ngb(:) ! band index
4678 integer , intent(in) :: icldlyr(:,:)
4679 real _gpudev :: taug(:,:,:)
4680 real _gpudev :: fracsd(:,:,:)
4681 real _gpudev :: cldfmcd(:,:,:)
4683 #include "rrtmg_lw_cpu_defs.h"
4686 ! Declarations for radiative transfer
4689 # define IDIM (ncol)
4690 # define IDIM1 ncol,
4696 real :: atot( IDIM1 mxlay)
4697 real :: atrans( IDIM1 mxlay)
4698 real :: bbugas( IDIM1 mxlay)
4699 real :: bbutot( IDIM1 mxlay)
4701 real :: uflux( IDIM1 0:mxlay)
4702 real :: dflux( IDIM1 0:mxlay)
4703 real :: uclfl( IDIM1 0:mxlay)
4704 real :: dclfl( IDIM1 0:mxlay)
4707 # define atot(X) ATOT(iplon,X)
4708 # define atrans(X) ATRANS(iplon,X)
4709 # define bbugas(X) BBUGAS(iplon,X)
4710 # define bbutot(X) BBUTOT(iplon,X)
4711 # define uflux(X) UFLUX(iplon,X)
4712 # define dflux(X) DFLUX(iplon,X)
4713 # define uclfl(X) UCLFL(iplon,X)
4714 # define dclfl(X) DCLFL(iplon,X)
4721 real :: secdiff IDIM ! secant of diffusivity angle
4722 real :: transcld, radld IDIM, radclrd IDIM, plfrac, blay, dplankup, dplankdn
4723 real :: odepth, odtot, odepth_rec, odtot_rec, gassrc
4724 real :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac
4725 real :: rad0, reflect, radlu IDIM , radclru IDIM
4726 real :: d_rad0_dt, d_radlu_dt IDIM , d_radclru_dt IDIM
4728 integer :: ibnd, ib, lay, lev, l, ig ! loop indices
4729 integer :: igc ! g-point interval counter
4730 integer :: iclddn IDIM ! flag for cloud in down path
4731 integer :: ittot, itgas, itr ! lookup table indices
4733 ! ------- Definitions -------
4735 ! nlayers ! number of model layers
4736 ! ngptlw ! total number of g-point subintervals
4737 ! nbndlw ! number of longwave spectral bands
4738 ! ncbands ! number of spectral bands for clouds
4739 ! secdiff ! diffusivity angle
4740 ! wtdiff ! weight for radiance to flux conversion
4741 ! pavel ! layer pressures (mb)
4742 ! pz ! level (interface) pressures (mb)
4743 ! tavel ! layer temperatures (k)
4744 ! tz ! level (interface) temperatures(mb)
4745 ! tbound ! surface temperature (k)
4746 ! cldfrac ! layer cloud fraction
4747 ! taucloud ! layer cloud optical depth
4748 ! itr ! integer look-up table index
4749 ! icldlyr ! flag for cloudy layers
4750 ! iclddn ! flag for cloud in column at any layer
4751 ! semiss ! surface emissivities for each band
4752 ! reflect ! surface reflectance
4753 ! bpade ! 1/(pade constant)
4754 ! tau_tbl ! clear sky optical depth look-up table
4755 ! exp_tbl ! exponential look-up table for transmittance
4756 ! tfn_tbl ! tau transition function look-up table
4759 ! atrans ! gaseous absorptivity
4760 ! abscld ! cloud absorptivity
4761 ! atot ! combined gaseous and cloud absorptivity
4762 ! odclr ! clear sky (gaseous) optical depth
4763 ! odcld ! cloud optical depth
4764 ! odtot ! optical depth of gas and cloud
4765 ! tfacgas ! gas-only pade factor, used for planck fn
4766 ! tfactot ! gas and cloud pade factor, used for planck fn
4767 ! bbdgas ! gas-only planck function for downward rt
4768 ! bbugas ! gas-only planck function for upward rt
4769 ! bbdtot ! gas and cloud planck function for downward rt
4770 ! bbutot ! gas and cloud planck function for upward calc.
4771 ! gassrc ! source radiance due to gas only
4772 ! efclfrac ! effective cloud fraction
4773 ! radlu ! spectrally summed upward radiance
4774 ! radclru ! spectrally summed clear sky upward radiance
4775 ! urad ! upward radiance by layer
4776 ! clrurad ! clear sky upward radiance by layer
4777 ! radld ! spectrally summed downward radiance
4778 ! radclrd ! spectrally summed clear sky downward radiance
4779 ! drad ! downward radiance by layer
4780 ! clrdrad ! clear sky downward radiance by layer
4781 ! d_radlu_dt ! spectrally summed upward radiance
4782 ! d_radclru_dt ! spectrally summed clear sky upward radiance
4783 ! d_urad_dt ! upward radiance by layer
4784 ! d_clrurad_dt ! clear sky upward radiance by layer
4787 ! totuflux ! upward longwave flux (w/m2)
4788 ! totdflux ! downward longwave flux (w/m2)
4789 ! fnet ! net longwave flux (w/m2)
4790 ! htr ! longwave heating rate (k/day)
4791 ! totuclfl ! clear sky upward longwave flux (w/m2)
4792 ! totdclfl ! clear sky downward longwave flux (w/m2)
4793 ! fnetc ! clear sky net longwave flux (w/m2)
4794 ! htrc ! clear sky longwave heating rate (k/day)
4795 ! dtotuflux_dt ! change in upward longwave flux (w/m2/k)
4796 ! ! with respect to surface temperature
4797 ! dtotuclfl_dt ! change in clear sky upward longwave flux (w/m2/k)
4801 ! This secant and weight corresponds to the standard diffusivity
4802 ! angle. This initial value is redefined below for some bands.
4803 real , parameter :: wtdiff = 0.5
4804 real , parameter :: rec_6 = 0.166667
4806 ! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50
4807 ! and 1.80) as a function of total column water vapor. The function
4808 ! has been defined to minimize flux and cooling rate errors in these bands
4809 ! over a wide range of precipitable water values.
4814 ! (dmb 2012) Here we compute the index for the column and band dimensions
4816 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
4817 igc = (blockidx%y-1) * blockdim%y + threadidx%y
4818 ! (dmb 2012) Make sure that the column and bands are within the proper ranges
4819 if (iplon <= ncol .and. igc<=140) then
4824 # define secdiff SECDIFF(iplon)
4829 if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then
4832 secdiff = a0d(ibnd) + a1d(ibnd)*exp(a2d(ibnd)*pwvcmd(iplon))
4833 if (secdiff .gt. 1.80 ) secdiff = 1.80
4834 if (secdiff .lt. 1.50 ) secdiff = 1.50
4836 gurad(iplon, igc, 0) = 0.0
4837 gdrad(iplon, igc, 0) = 0.0
4838 !totuflux(iplon,igc,0) = 0.0
4839 !totdflux(iplon,igc,0) = 0.0
4840 gclrurad(iplon, igc, 0) = 0.0
4841 gclrdrad(iplon, igc, 0) = 0.0
4842 !totuclfl(iplon,igc,0) = 0.0
4843 !totdclfl(iplon,igc,0) = 0.0
4844 if (idrvd .eq. 1) then
4845 gdtotuflux_dtd(iplon,igc,0) = 0.0
4846 gdtotuclfl_dtd(iplon,igc,0) = 0.0
4852 gurad(iplon, igc, lay) = 0.0
4853 gdrad(iplon, igc, lay) = 0.0
4854 gclrurad(iplon, igc, lay) = 0.0
4855 gclrdrad(iplon, igc, lay) = 0.0
4857 ! (dmb 2012) I removed the band loop here because it was terribly inefficient
4858 ! I now set the required variables outside of the kernel
4860 if (idrvd .eq. 1) then
4861 gdtotuflux_dtd(iplon,igc,lay) = 0.0
4862 gdtotuclfl_dtd(iplon,igc,lay) = 0.0
4867 ! Radiative transfer starts here.
4872 ! Downward radiative transfer loop.
4875 # define radld RADLD(iplon)
4876 # define radclrd RADCLRD(iplon)
4877 # define iclddn ICLDDN(iplon)
4880 do lev = nlayers, 1, -1
4882 plfrac = fracsd(iplon,lev,igc)
4883 blay = planklayd(iplon,lev,ibnd)
4884 dplankup = planklevd(iplon,lev,ibnd) - blay
4885 dplankdn = planklevd(iplon,lev-1,ibnd) - blay
4886 odepth = secdiff * taug(iplon,lev,igc)
4887 if (odepth .lt. 0.0 ) odepth = 0.0
4889 if (icldlyr(iplon, lev).eq.1) then
4891 ! (dmb 2012) Here instead of using the lookup tables to compute
4892 ! the optical depth and related quantities, I compute them on the
4893 ! fly because this is actually much more efficient on the GPU.
4894 odclds = secdiff * taucmcd(iplon,igc,lev)
4895 absclds = 1. - exp(-odclds)
4896 efclfracs = absclds * cldfmcd(iplon, igc,lev)
4897 odtot = odepth + odclds
4900 tblind = odepth/(bpaded+odepth)
4901 itgas = tblint*tblind+0.5
4902 bbb = itgas / float(tblint)
4903 odepth = bpaded * bbb / (1. - bbb)
4905 atrans(lev) = exp( -odepth)
4906 atrans(lev) = 1 -atrans(lev)
4907 ! (dmb 2012) Compute tfacgas on the fly. Even though this is an expensive operation,
4908 ! it is more efficient to do the calculation within the kernel on the GPU.
4909 if (odepth < 0.06) then
4912 tfacgas = 1. -2. *((1. /odepth)-((1. - atrans(lev))/(atrans(lev))))
4914 gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
4916 odtot = odepth + odclds
4917 tblind = odtot/(bpaded+odtot)
4918 ittot = tblint*tblind + 0.5
4919 bbb = ittot / float(tblint)
4920 bbb = bpaded * bbb / (1. - bbb)
4921 atot(lev) = 1. - exp(-bbb)
4922 if (bbb < 0.06) then
4925 tfactot = 1. -2. *((1. /bbb)-((1-atot(lev))/(atot(lev))))
4927 bbdtot = plfrac * (blay + tfactot*dplankdn)
4928 bbd = plfrac*(blay+tfacgas*dplankdn)
4930 tblind = odepth/(bpade+odepth)
4931 itgas = tblint*tblind+0.5
4932 odepth = tau_tbl(itgas)
4933 atrans(lev) = 1. - exp_tbl(itgas)
4934 tfacgas = tfn_tbl(itgas)
4935 gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn)
4937 odtot = odepth + odclds
4938 tblind = odtot/(bpade+odtot)
4939 ittot = tblint*tblind + 0.5
4940 tfactot = tfn_tbl(ittot)
4941 bbdtot = plfrac * (blay + tfactot*dplankdn)
4942 bbd = plfrac*(blay+tfacgas*dplankdn)
4943 atot(lev) = 1. - exp_tbl(ittot)
4946 radld = radld - radld * (atrans(lev) + &
4947 efclfracs * (1. - atrans(lev))) + &
4948 gassrc + cldfmcd(iplon, igc,lev) * &
4949 (bbdtot * atot(lev) - gassrc)
4950 gdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1) + radld
4951 bbugas(lev) = plfrac * (blay + tfacgas * dplankup)
4952 bbutot(lev) = plfrac * (blay + tfactot * dplankup)
4958 tblind = odepth/(bpaded+odepth)
4959 itr = tblint*tblind+0.5
4960 ! (dmb 2012) Compute the atrans and related values on the fly instead
4961 ! of using the lookup tables.
4962 bbb = itr/float(tblint)
4963 bbb = bpaded * bbb / (1. - bbb)
4964 transc = exp( -bbb )
4965 if (transc < 1.e-20 ) transc = 1.e-20
4966 atrans(lev) = 1. -transc
4968 if (bbb < 0.06 ) then
4971 tausfac = 1. -2. *((1. /bbb)-(transc/(1.-transc)))
4974 bbd = plfrac*(blay+tausfac*dplankdn)
4975 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
4978 tblind = odepth/(bpade+odepth)
4979 itr = tblint*tblind+0.5
4980 transc = exp_tbl(itr)
4981 atrans(lev) = 1. -transc
4982 tausfac = tfn_tbl(itr)
4983 bbd = plfrac*(blay+tausfac*dplankdn)
4984 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
4986 ! jm agree with the calculation in module_ra_rrtmg_lw.F ~line 3340
4987 if (odepth .le. 0.06) then
4988 atrans(lev) = odepth-0.5*odepth*odepth
4989 odepth = rec_6*odepth
4990 bbd = plfrac*(blay+dplankdn*odepth)
4991 bbugas(lev) = plfrac*(blay+dplankup*odepth)
4993 tblind = odepth/(bpade+odepth)
4994 itr = tblint*tblind+0.5
4995 transc = exp_tbl(itr)
4996 atrans(lev) = 1.-transc
4997 tausfac = tfn_tbl(itr)
4998 bbd = plfrac*(blay+tausfac*dplankdn)
4999 bbugas(lev) = plfrac * (blay + tausfac * dplankup)
5003 radld = radld + (bbd-radld )*atrans(lev)
5004 gdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1) + radld
5008 ! Set clear sky stream to total sky stream as long as layers
5009 ! remain clear. Streams diverge when a cloud is reached (iclddn=1),
5010 ! and clear sky stream must be computed separately from that point.
5011 if (iclddn .eq.1) then
5012 radclrd = radclrd + (bbd-radclrd) * atrans(lev)
5013 ! (dmb 2012) Rather than summing up the results and then computing the
5014 ! total fluxes, I store the g-point specific values in GPU arrays to be
5015 ! summed up later in a new kernel. This ensures that we can parallelize
5016 ! across enough dimensions so that the GPU remains busy.
5017 gclrdrad(iplon, igc, lev-1) = gclrdrad(iplon, igc, lev-1) + radclrd
5020 gclrdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1)
5023 enddo ! end of downward radiation loop
5025 ! Spectral emissivity & reflectance
5026 ! Include the contribution of spectrally varying longwave emissivity
5027 ! and reflection from the surface to the upward radiative transfer.
5028 ! Note: Spectral and Lambertian reflection are identical for the
5029 ! diffusivity angle flux integration used here.
5030 ! Note: The emissivity is applied to plankbnd and dplankbnd_dt when
5031 ! they are defined in subroutine setcoef.
5034 # define radlu RADLU(iplon)
5035 # define radclru RADCLRU(iplon)
5036 # define d_radlu_dt D_RADLU_DT(iplon)
5037 # define d_radclru_dt D_RADCLRU_DT(iplon)
5041 rad0 = fracsd(iplon,1,igc) * plankbndd(iplon,ibnd)
5042 ! Add in specular reflection of surface downward radiance.
5043 reflect = 1. - semissd(iplon,ibnd)
5044 radlu = rad0 + reflect * radld
5045 radclru = rad0 + reflect * radclrd
5047 ! Upward radiative transfer loop.
5048 gurad(iplon, igc, 0) = gurad(iplon, igc, 0) + radlu
5049 gclrurad(iplon, igc, 0) = gclrurad(iplon, igc, 0) + radclru
5055 if (icldlyr(iplon, lev) .eq. 1) then
5056 gassrc = bbugas(lev) * atrans(lev)
5057 odclds = secdiff * taucmcd(iplon,igc,lev)
5058 absclds = 1. - exp(-odclds)
5059 efclfracs = absclds * cldfmcd(iplon, igc,lev)
5060 radlu = radlu - radlu * (atrans(lev) + &
5061 efclfracs * (1. - atrans(lev))) + &
5062 gassrc + cldfmcd(iplon, igc,lev) * &
5063 (bbutot(lev) * atot(lev) - gassrc)
5064 gurad(iplon, igc, lev) = gurad(iplon, igc, lev) + radlu
5067 radlu = radlu + (bbugas(lev)-radlu)*atrans(lev)
5068 gurad(iplon, igc, lev) = gurad(iplon, igc, lev) + radlu
5073 ! Set clear sky stream to total sky stream as long as all layers
5074 ! are clear (iclddn=0). Streams must be calculated separately at
5075 ! all layers when a cloud is present (ICLDDN=1), because surface
5076 ! reflectance is different for each stream.
5077 if (iclddn.eq.1) then
5078 radclru = radclru + (bbugas(lev)-radclru)*atrans(lev)
5079 gclrurad(iplon, igc, lev) = gclrurad(iplon, igc, lev) + radclru
5082 gclrurad(iplon, igc, lev) = gurad(iplon, igc, lev)
5088 tblind = wtdiff * delwaved(ibnd) * fluxfacd
5089 ! (dmb 2012) Now that the g-points values were created, we modify them
5090 ! so that later summation (integration) will be simpler.
5093 gurad(iplon, igc, lev) = gurad(iplon, igc, lev) * tblind
5094 gdrad(iplon, igc, lev) = gdrad(iplon, igc, lev) * tblind
5095 gclrurad(iplon, igc, lev) = gclrurad(iplon, igc, lev) * tblind
5096 gclrdrad(iplon, igc, lev) = gclrdrad(iplon, igc, lev) * tblind
5106 end subroutine rtrnmcg
5108 ! (dmb 2012) This subroutine adds up the indivial g-point fluxes to arrive at a
5109 ! final upward and downward flux value for each column and layer. This subroutine
5110 ! is parallelized across the column and layer dimensions. As long as we parallelize
5111 ! across two of the three dimesnions, we should usually have enough GPU saturation.
5112 _gpuker subroutine rtrnadd(ncol, nlay, ngpt, drvf &
5113 #include "rrtmg_lw_cpu_args.h"
5116 integer, intent(in), value :: ncol
5117 integer, intent(in), value :: nlay
5118 integer, intent(in), value :: ngpt
5119 integer, intent(in), value :: drvf
5120 #include "rrtmg_lw_cpu_defs.h"
5122 integer :: iplon, ilay, igp
5125 ! (dmb 2012) compute the column and layer indices from the grid and block
5129 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
5130 ilay = (blockidx%y-1) * blockdim%y + threadidx%y - 1
5132 ! (dmb 2012) make sure that the column and layer are within range
5133 if (ilay <= nlay .and. iplon <= ncol) then
5135 ! zap should move this inside the igp loop
5142 totufluxd(iplon, ilay)=totufluxd(iplon, ilay)+gurad(iplon, igp, ilay)
5143 totdfluxd(iplon, ilay)=totdfluxd(iplon, ilay)+gdrad(iplon, igp, ilay)
5144 totuclfld(iplon, ilay)=totuclfld(iplon, ilay)+gclrurad(iplon, igp, ilay)
5145 totdclfld(iplon, ilay)=totdclfld(iplon, ilay)+gclrdrad(iplon, igp, ilay)
5149 if (drvf .eq. 1) then
5153 dtotuflux_dtd(iplon, ilay) = dtotuflux_dtd(iplon, ilay) + gdtotuflux_dtd( iplon, igp, ilay)
5154 dtotuclfl_dtd(iplon, ilay) = dtotuclfl_dtd(iplon, ilay) + gdtotuclfl_dtd( iplon, igp, ilay)
5169 ! (dmb 2012) This kernel computes the heating rates separately. It is parallelized across the
5170 ! columnn and layer dimensions.
5171 _gpuker subroutine rtrnheatrates(ncol, nlay &
5173 ,ncol_,nlayers_,nbndlw_,ngptlw_ &
5174 ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad &
5175 ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d &
5176 ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd &
5177 ,dtotuclfl_dtd,dplankbnd_dtd &
5181 integer, intent(in), value :: ncol
5182 integer, intent(in), value :: nlay
5184 integer :: ncol_,nlayers_,nbndlw_,ngptlw_
5185 ! changed to arguments for thread safety
5189 integer :: ngsd(nbndlw)
5192 real :: taucmcd(ncol_, ngptlw_, nlayers_+1)
5194 real , dimension(ncol_, 0:nlayers_+1) :: pzd ! level (interface) pressures (hPa, mb)
5195 ! Dimensions: (ncol,0:nlayers)
5196 real , dimension(ncol_) :: pwvcmd ! precipitable water vapor (cm)
5197 ! Dimensions: (ncol)
5198 real , dimension(ncol_,nbndlw_) :: semissd ! lw surface emissivity
5199 ! Dimensions: (ncol,nbndlw)
5200 real , dimension(ncol_,nlayers_+1,nbndlw_) :: planklayd !
5201 ! Dimensions: (ncol,nlayers+1,nbndlw)
5202 real , dimension(ncol_,0:nlayers_+1,nbndlw_) :: planklevd !
5203 ! Dimensions: (ncol,0:nlayers+1,nbndlw)
5204 real, dimension(ncol_,nbndlw_) :: plankbndd !
5205 ! Dimensions: (ncol,nbndlw)
5207 real :: gurad(ncol_,ngptlw_,0:nlayers_+1) ! upward longwave flux (w/m2)
5208 real :: gdrad(ncol_,ngptlw_,0:nlayers_+1) ! downward longwave flux (w/m2)
5209 real :: gclrurad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky upward longwave flux (w/m2)
5210 real :: gclrdrad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky downward longwave flux (w/m2)
5212 real :: gdtotuflux_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in upward longwave flux (w/m1/k)
5213 ! with respect to surface temperature
5215 real :: gdtotuclfl_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k)
5216 ! with respect to surface temperature
5219 integer :: idrvd ! flag for calculation of dF/dt from
5220 ! Planck derivative [0=off, 1=on]
5224 real :: a0d(nbndlw_), a1d(nbndlw_), a2d(nbndlw_)
5225 real :: delwaved(nbndlw_)
5226 real :: totufluxd(ncol_, 0:nlayers_+1) ! upward longwave flux (w/m2)
5227 real :: totdfluxd(ncol_, 0:nlayers_+1) ! downward longwave flux (w/m2)
5228 real :: fnetd(ncol_, 0:nlayers_+1) ! net longwave flux (w/m2)
5229 real :: htrd(ncol_, 0:nlayers_+1) ! longwave heating rate (k/day)
5230 real :: totuclfld(ncol_, 0:nlayers_+1) ! clear sky upward longwave flux (w/m2)
5231 real :: totdclfld(ncol_, 0:nlayers_+1) ! clear sky downward longwave flux (w/m2)
5232 real :: fnetcd(ncol_, 0:nlayers_+1) ! clear sky net longwave flux (w/m2)
5233 real :: htrcd(ncol_, 0:nlayers_+1) ! clear sky longwave heating rate (k/day)
5234 real :: dtotuflux_dtd(ncol_, 0:nlayers_+1) ! change in upward longwave flux (w/m2/k)
5235 ! with respect to surface temperature
5236 real :: dtotuclfl_dtd(ncol_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k)
5237 ! with respect to surface temperature
5238 real :: dplankbnd_dtd(ncol_,nbndlw_)
5243 integer :: iplon, ilay
5246 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
5247 ilay = (blockidx%y-1) * blockdim%y + threadidx%y - 1
5250 if (ilay<nlay .and. iplon<=ncol) then
5253 do ilay = 0, nlay - 1
5255 t2 = pzd(iplon, ilay ) - pzd(iplon, ilay + 1)
5256 htrd(iplon, ilay) = heatfacd * ((totufluxd(iplon, ilay) - totdfluxd(iplon, ilay)) &
5257 - (totufluxd(iplon, ilay+1) - totdfluxd(iplon, ilay+1)))/t2
5258 htrcd(iplon, ilay) = heatfacd * ((totuclfld(iplon, ilay) - totdclfld(iplon, ilay)) &
5259 - (totuclfld(iplon, ilay+1) - totdclfld(iplon, ilay+1)))/t2
5270 ! (dmb 2012) Copy needed variables over to the GPU. These arrays are pretty small so simple
5271 ! stream 0 assignment operators suffice.
5272 subroutine copyGPUrtrnmcg(pz, pwvcm, idrv, taut)
5274 real , intent(in) :: pz(:,:) ! level (interface) pressures (hPa, mb)
5275 integer , intent(in) :: idrv ! flag for calculation of dF/dt from
5276 real , intent(in) :: taut(:,:,:)
5277 real , intent(in) :: pwvcm(:)
5290 ! (dmb 2012) Allocate the arrays for the rtrnmc routine on the GPU. Some of these arrays are
5291 ! quite large as they contain all 3 dimensions. Luckily, for the gurad arrays, no copying of data
5292 ! from the CPU is needed because they are only stored on the GPU.
5293 subroutine allocateGPUrtrnmcg(ncol, nlay, ngptlw, drvf)
5295 integer , intent(in) :: ncol, nlay, ngptlw, drvf
5296 integer,external :: omp_get_thread_num
5299 allocate( taucmcd(ncol, ngptlw, nlay+1))
5300 allocate( pzd(ncol, 0:nlay+1))
5301 allocate( pwvcmd(ncol))
5302 allocate( semissd(ncol, nbndlw))
5303 allocate( planklayd(ncol,nlay+1,nbndlw))
5304 allocate( planklevd(ncol, 0:nlay+1, nbndlw))
5305 allocate( plankbndd(ncol,nbndlw))
5306 allocate ( gurad(ncol,ngptlw,0:nlay+1)) ! upward longwave flux (w/m2)
5307 allocate ( gdrad(ncol,ngptlw,0:nlay+1)) ! downward longwave flux (w/m2)
5308 allocate ( gclrurad(ncol,ngptlw,0:nlay+1)) ! clear sky upward longwave flux (w/m2)
5309 allocate ( gclrdrad(ncol,ngptlw,0:nlay+1)) ! clear sky downward longwave flux (w/m2)
5311 ! (dmb 2012) Only allocate the optional derivative arrays if the flag is set
5312 if (drvf .eq. 1) then
5314 allocate( gdtotuflux_dtd( ncol, ngptlw, 0:nlay+1))
5315 allocate( gdtotuclfl_dtd( ncol, ngptlw, 0:nlay+1))
5319 allocate (totufluxd(ncol, 0:nlay+1)) ! upward longwave flux (w/m2)
5320 allocate (totdfluxd(ncol, 0:nlay+1)) ! downward longwave flux (w/m2)
5321 allocate (fnetd(ncol, 0:nlay+1)) ! net longwave flux (w/m2)
5322 allocate (htrd(ncol, 0:nlay+1)) ! longwave heating rate (k/day)
5323 allocate (totuclfld(ncol, 0:nlay+1)) ! clear sky upward longwave flux (w/m2)
5324 allocate (totdclfld(ncol, 0:nlay+1)) ! clear sky downward longwave flux (w/m2)
5325 allocate (fnetcd(ncol, 0:nlay+1)) ! clear sky net longwave flux (w/m2)
5326 allocate (htrcd(ncol, 0:nlay+1)) ! clear sky longwave heating rate (k/day)
5327 allocate (dtotuflux_dtd(ncol, 0:nlay+1)) ! change in upward longwave flux (w/m2/k)
5328 allocate (dtotuclfl_dtd(ncol, 0:nlay+1))
5329 allocate (dplankbnd_dtd(ncol,nbndlw))
5334 ! (dmb 2012) This subroutine deallocates rtrnmc related GPU arrays.
5335 subroutine deallocateGPUrtrnmcg( drvf )
5337 integer , intent(in) :: drvf
5340 deallocate( taucmcd)
5343 deallocate( semissd)
5344 deallocate( planklayd)
5345 deallocate( planklevd)
5346 deallocate( plankbndd)
5347 deallocate ( gurad) ! upward longwave flux (w/m2)
5348 deallocate ( gdrad) ! downward longwave flux (w/m2)
5349 deallocate ( gclrurad) ! clear sky upward longwave flux (w/m2)
5350 deallocate ( gclrdrad) ! clear sky downward longwave flux (w/m2)
5351 deallocate (totufluxd) ! upward longwave flux (w/m2)
5352 deallocate (totdfluxd) ! downward longwave flux (w/m2)
5353 deallocate (fnetd) ! net longwave flux (w/m2)
5354 deallocate (htrd) ! longwave heating rate (k/day)
5355 deallocate (totuclfld) ! clear sky upward longwave flux (w/m2)
5356 deallocate (totdclfld) ! clear sky downward longwave flux (w/m2)
5357 deallocate (fnetcd) ! clear sky net longwave flux (w/m2)
5358 deallocate (htrcd) ! clear sky longwave heating rate (k/day)
5359 deallocate (dtotuflux_dtd) ! change in upward longwave flux (w/m2/k)
5360 deallocate (dtotuclfl_dtd)
5361 deallocate (dplankbnd_dtd)
5363 if ( drvf .eq. 1) then
5364 deallocate( gdtotuflux_dtd, gdtotuclfl_dtd )
5370 end module gpu_rrtmg_lw_rtrnmc
5373 ! (dmb 2012) This is the GPU version of the taumol subroutines. At first I was going to
5374 ! try and combine the taumol routines into a single subroutine, but it turns out that
5375 ! all 16 can remain and run efficiently on the GPU.
5376 module gpu_rrtmg_lw_taumol
5378 ! --------------------------------------------------------------------------
5380 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
5381 ! | This software may be used, copied, or redistributed as long as it is |
5382 ! | not sold and this copyright notice is reproduced on each copy made. |
5383 ! | This model is provided as is without any express or implied warranties. |
5384 ! | (http://www.rtweb.aer.com/) |
5386 ! --------------------------------------------------------------------------
5388 ! ------- Modules -------
5390 ! use parkind, only : im => kind , rb => kind
5391 use parrrtm_f, only : mg, nbndlw, maxxsec, ngptlw
5392 use rrlw_con_f, only: oneminus
5393 use rrlw_wvn_f, only: nspa, nspb
5394 use rrlw_vsn_f, only: hvrtau, hnamtau
5395 use rrlw_wvn_f, only: ngb
5406 ! (dmb 2012) There are a lot of GPU module level variables in this module
5407 ! The parameter list for the taumol subroutines have been reduced for
5408 ! efficiency and readability.
5409 ! (jm 2014) not thread-safe
5410 real _gpudev, allocatable :: pavel(:,:)
5411 real _gpudev, allocatable :: wx1(:,:)
5412 real _gpudev, allocatable :: wx2(:,:)
5413 real _gpudev, allocatable :: wx3(:,:)
5414 real _gpudev, allocatable :: wx4(:,:)
5415 real _gpudev, allocatable :: coldry(:,:)
5416 integer _gpudev, allocatable :: laytrop(:)
5417 integer _gpudev, allocatable :: jp(:,:)
5418 integer _gpudev, allocatable :: jt(:,:)
5419 integer _gpudev, allocatable :: jt1(:,:)
5420 real _gpudev, allocatable :: colh2o(:,:)
5421 real _gpudev, allocatable :: colco2(:,:)
5422 real _gpudev, allocatable :: colo3(:,:)
5423 real _gpudev, allocatable :: coln2o(:,:)
5424 real _gpudev, allocatable :: colco(:,:)
5425 real _gpudev, allocatable :: colch4(:,:)
5426 real _gpudev, allocatable :: colo2(:,:)
5427 real _gpudev, allocatable :: colbrd(:,:)
5428 integer _gpudev, allocatable :: indself(:,:)
5429 integer _gpudev, allocatable :: indfor(:,:)
5430 real _gpudev, allocatable :: selffac(:,:)
5431 real _gpudev, allocatable :: selffrac(:,:)
5432 real _gpudev, allocatable :: forfac(:,:)
5433 real _gpudev, allocatable :: forfrac(:,:)
5434 integer _gpudev, allocatable :: indminor(:,:)
5435 real _gpudev, allocatable :: minorfrac(:,:)
5436 real _gpudev, allocatable :: scaleminor(:,:)
5437 real _gpudev, allocatable :: scaleminorn2(:,:)
5438 real _gpudev, allocatable :: fac00(:,:), fac01(:,:), fac10(:,:), fac11(:,:)
5439 real _gpudev, allocatable :: rat_h2oco2(:,:),rat_h2oco2_1(:,:), &
5440 rat_h2oo3(:,:),rat_h2oo3_1(:,:), &
5441 rat_h2on2o(:,:),rat_h2on2o_1(:,:), &
5442 rat_h2och4(:,:),rat_h2och4_1(:,:), &
5443 rat_n2oco2(:,:),rat_n2oco2_1(:,:), &
5444 rat_o3co2(:,:),rat_o3co2_1(:,:)
5445 ! Dimensions: (ncol,nlayers)
5446 real _gpudev, allocatable :: tauaa(:,:,:)
5447 ! Dimensions: (ncol,nlayers,ngptlw)
5449 integer _gpudev, allocatable :: nspad(:)
5450 integer _gpudev, allocatable :: nspbd(:)
5451 real _gpucon :: oneminusd
5452 !$OMP THREADPRIVATE( pavel,wx1,wx2,wx3,wx4,coldry,laytrop,jp,jt,jt1,colh2o,colco2,colo3,coln2o, &
5453 !$OMP colco,colch4,colo2,colbrd,indself,indfor,selffac,selffrac,forfac,forfrac, &
5454 !$OMP indminor,minorfrac,scaleminor,scaleminorn2,fac00,fac01,fac10,fac11, &
5455 !$OMP rat_h2oco2,rat_h2oco2_1,rat_h2oo3,rat_h2oo3_1,rat_h2on2o,rat_h2on2o_1, &
5456 !$OMP rat_h2och4,rat_h2och4_1,rat_n2oco2,rat_n2oco2_1,rat_o3co2,rat_o3co2_1, &
5457 !$OMP tauaa,nspad,nspbd,oneminusd )
5463 !defines for taugb functions
5467 # define absbod absbo
5469 # define ccl4od ccl4o
5470 # define cfc11adjd cfc11adj
5471 # define cfc11adjod cfc11adjo
5472 # define cfc12d cfc12
5473 # define cfc12od cfc12o
5474 # define cfc22adjd cfc22adj
5475 # define cfc22adjod cfc22adjo
5476 # define forrefd forref
5477 # define forrefod forrefo
5478 # define fracrefad fracrefa
5479 # define fracrefaod fracrefao
5480 # define fracrefbd fracrefb
5481 # define fracrefbod fracrefbo
5483 # define ka_mcod ka_mco
5484 # define ka_mco2d ka_mco2
5485 # define ka_mn2d ka_mn2
5486 # define ka_mn2od ka_mn2o
5487 # define ka_mo2d ka_mo2
5488 # define ka_mo3d ka_mo3
5490 # define kao_mcod kao_mco
5491 # define kao_mco2d kao_mco2
5492 # define kao_mn2d kao_mn2
5493 # define kao_mn2od kao_mn2o
5494 # define kao_mo3d kao_mo3
5496 # define kb_mco2d kb_mco2
5497 # define kb_mn2d kb_mn2
5498 # define kb_mn2od kb_mn2o
5499 # define kb_mo2d kb_mo2
5500 # define kb_mo3d kb_mo3
5502 # define kbo_mco2d kbo_mco2
5503 # define kbo_mn2od kbo_mn2o
5504 # define kbo_mo3d kbo_mo3
5505 # define selfrefd selfref
5506 # define selfrefod selfrefo
5509 !----------------------------------------------------------------------------
5510 _gpuker subroutine taugb1g( ncol, nlayers, taug, fracsd &
5511 #include "taug_cpu_args.h"
5514 !----------------------------------------------------------------------------
5516 ! ------- Modifications -------
5517 ! Written by Eli J. Mlawer, Atmospheric & Environmental Research.
5518 ! Revised by Michael J. Iacono, Atmospheric & Environmental Research.
5520 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
5521 ! (high key - h2o; high minor - n2)
5523 ! note: previous versions of rrtm band 1:
5524 ! 10-250 cm-1 (low - h2o; high - h2o)
5525 !----------------------------------------------------------------------------
5527 ! ------- Modules -------
5529 ! use parrrtm_f, only : ng1
5532 ! ------- Declarations -------
5534 integer :: lay, ind0, ind1, inds, indf, indm, ig
5535 real :: pp, corradj, scalen2, tauself, taufor, taun2
5536 integer , value, intent(in) :: ncol, nlayers
5537 real _gpudev :: taug(:,:,:)
5538 real _gpudev :: fracsd(:,:,:)
5539 #include "taug_cpu_defs.h"
5545 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
5546 lay = (blockidx%y-1) * blockdim%y + threadidx%y
5547 if (iplon <= ncol .and. lay <= nlayers) then
5553 ! Minor gas mapping levels:
5554 ! lower - n2, p = 142.5490 mbar, t = 215.70 k
5555 ! upper - n2, p = 142.5490 mbar, t = 215.70 k
5557 ! Compute the optical depth by interpolating in ln(pressure) and
5558 ! temperature. Below laytrop, the water vapor self-continuum and
5559 ! foreign continuum is interpolated (in temperature) separately.
5561 ! Lower atmosphere loop
5564 if (lay <= laytrop(iplon)) then
5566 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(1) + 1
5567 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(1) + 1
5568 inds = indself(iplon,lay)
5569 indf = indfor(iplon,lay)
5570 indm = indminor(iplon,lay)
5571 pp = pavel(iplon, lay)
5573 if (pp .lt. 250. ) then
5574 corradj = 1. - 0.15 * (250. -pp) / 154.4
5577 scalen2 = colbrd(iplon,lay) * scaleminorn2(iplon,lay)
5579 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
5580 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
5581 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
5582 (forrefd(indf+1,ig) - forrefd(indf,ig)))
5583 taun2 = scalen2*(ka_mn2d(indm,ig) + &
5584 minorfrac(iplon,lay) * (ka_mn2d(indm+1,ig) - ka_mn2d(indm,ig)))
5585 taug(iplon,lay,ig) = corradj * (colh2o(iplon,lay) * &
5586 (fac00(iplon,lay) * absad(ind0,ig) + &
5587 fac10(iplon,lay) * absad(ind0+1,ig) + &
5588 fac01(iplon,lay) * absad(ind1,ig) + &
5589 fac11(iplon,lay) * absad(ind1+1,ig)) &
5590 + tauself + taufor + taun2)
5591 fracsd(iplon,lay,ig) = fracrefad(ig)
5596 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(1) + 1
5597 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(1) + 1
5598 indf = indfor(iplon,lay)
5599 indm = indminor(iplon,lay)
5600 pp = pavel(iplon, lay)
5601 corradj = 1. - 0.15 * (pp / 95.6 )
5603 scalen2 = colbrd(iplon,lay) * scaleminorn2(iplon,lay)
5605 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + &
5606 forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig)))
5607 taun2 = scalen2*(kb_mn2d(indm,ig) + &
5608 minorfrac(iplon,lay) * (kb_mn2d(indm+1,ig) - kb_mn2d(indm,ig)))
5609 taug(iplon,lay,ig) = corradj * (colh2o(iplon,lay) * &
5610 (fac00(iplon,lay) * absbd(ind0,ig) + &
5611 fac10(iplon,lay) * absbd(ind0+1,ig) + &
5612 fac01(iplon,lay) * absbd(ind1,ig) + &
5613 fac11(iplon,lay) * absbd(ind1+1,ig)) &
5615 fracsd(iplon,lay,ig) = fracrefbd(ig)
5626 end subroutine taugb1g
5628 !----------------------------------------------------------------------------
5629 _gpuker subroutine taugb2g( ncol, nlayers , taug, fracsd &
5630 #include "taug_cpu_args.h"
5632 !----------------------------------------------------------------------------
5634 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
5636 ! note: previous version of rrtm band 2:
5637 ! 250 - 500 cm-1 (low - h2o; high - h2o)
5638 !----------------------------------------------------------------------------
5640 ! ------- Modules -------
5642 ! use parrrtm_f, only : ng2, ngs1
5643 use parrrtm_f, only : ngs1
5646 ! ------- Declarations -------
5647 real _gpudev :: taug(:,:,:)
5648 real _gpudev :: fracsd(:,:,:)
5649 #include "taug_cpu_defs.h"
5652 integer :: lay, ind0, ind1, inds, indf, ig
5653 real :: pp, corradj, tauself, taufor
5654 integer , value, intent(in) :: ncol, nlayers
5658 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
5659 lay = (blockidx%y-1) * blockdim%y + threadidx%y
5660 if (iplon <= ncol .and. lay <= nlayers) then
5665 ! Compute the optical depth by interpolating in ln(pressure) and
5666 ! temperature. Below laytrop, the water vapor self-continuum and
5667 ! foreign continuum is interpolated (in temperature) separately.
5669 ! Lower atmosphere loop
5670 if (lay <= laytrop(iplon)) then
5672 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(2) + 1
5673 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(2) + 1
5674 inds = indself(iplon,lay)
5675 indf = indfor(iplon,lay)
5676 pp = pavel(iplon, lay)
5677 corradj = 1. - .05 * (pp - 100. ) / 900.
5679 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
5680 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
5681 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
5682 (forrefd(indf+1,ig) - forrefd(indf,ig)))
5683 taug(iplon,lay,ngs1+ig) = corradj * (colh2o(iplon,lay) * &
5684 (fac00(iplon,lay) * absad(ind0,ig) + &
5685 fac10(iplon,lay) * absad(ind0+1,ig) + &
5686 fac01(iplon,lay) * absad(ind1,ig) + &
5687 fac11(iplon,lay) * absad(ind1+1,ig)) &
5689 fracsd(iplon,lay,ngs1+ig) = fracrefad(ig)
5693 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(2) + 1
5694 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(2) + 1
5695 indf = indfor(iplon,lay)
5697 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + &
5698 forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig)))
5699 taug(iplon,lay,ngs1+ig) = colh2o(iplon,lay) * &
5700 (fac00(iplon,lay) * absbd(ind0,ig) + &
5701 fac10(iplon,lay) * absbd(ind0+1,ig) + &
5702 fac01(iplon,lay) * absbd(ind1,ig) + &
5703 fac11(iplon,lay) * absbd(ind1+1,ig)) &
5705 fracsd(iplon,lay,ngs1+ig) = fracrefbd(ig)
5716 end subroutine taugb2g
5718 !----------------------------------------------------------------------------
5719 _gpuker subroutine taugb3g( ncol, nlayers, taug, fracsd &
5720 #include "taug_cpu_args.h"
5722 !----------------------------------------------------------------------------
5724 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
5725 ! (high key - h2o,co2; high minor - n2o)
5726 !----------------------------------------------------------------------------
5728 ! ------- Modules -------
5730 ! use parrrtm_f, only : ng3, ngs2
5731 use parrrtm_f, only : ngs2
5732 use rrlw_ref_f, only : chi_mlsd
5735 ! ------- Declarations -------
5736 #include "taug_cpu_defs.h"
5739 real _gpudev :: taug(:,:,:)
5740 real _gpudev :: fracsd(:,:,:)
5742 integer :: lay, ind0, ind1, inds, indf, indm, ig
5743 integer :: js, js1, jmn2o, jpl
5744 real :: speccomb, specparm, specmult, fs
5745 real :: speccomb1, specparm1, specmult1, fs1
5746 real :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, &
5747 fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o
5748 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
5749 real :: p, p4, fk0, fk1, fk2
5750 real :: fac000, fac100, fac200, fac010, fac110, fac210
5751 real :: fac001, fac101, fac201, fac011, fac111, fac211
5752 real :: tauself, taufor, n2om1, n2om2, absn2o
5753 real :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b
5754 real :: tau_major, tau_major1
5755 integer , value, intent(in) :: ncol, nlayers
5759 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
5760 lay = (blockidx%y-1) * blockdim%y + threadidx%y
5761 if (iplon <= ncol .and. lay <= nlayers) then
5766 ! Minor gas mapping levels:
5767 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
5768 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
5771 refrat_planck_a = chi_mlsd(1,9)/chi_mlsd(2,9)
5774 refrat_planck_b = chi_mlsd(1,13)/chi_mlsd(2,13)
5777 refrat_m_a = chi_mlsd(1,3)/chi_mlsd(2,3)
5780 refrat_m_b = chi_mlsd(1,13)/chi_mlsd(2,13)
5782 ! Compute the optical depth by interpolating in ln(pressure) and
5783 ! temperature, and appropriate species. Below laytrop, the water vapor
5784 ! self-continuum and foreign continuum is interpolated (in temperature)
5787 ! Lower atmosphere loop
5788 if (lay <= laytrop(iplon)) then
5790 speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay)
5791 specparm = colh2o(iplon,lay)/speccomb
5792 if (specparm .ge. oneminusd) specparm = oneminusd
5793 specmult = 8. *(specparm)
5794 js = 1 + int(specmult)
5795 fs = mod(specmult,1.0 )
5797 speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay)
5798 specparm1 = colh2o(iplon,lay)/speccomb1
5799 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
5800 specmult1 = 8. *(specparm1)
5801 js1 = 1 + int(specmult1)
5802 fs1 = mod(specmult1,1.0 )
5804 speccomb_mn2o = colh2o(iplon,lay) + refrat_m_a*colco2(iplon,lay)
5805 specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o
5806 if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd
5807 specmult_mn2o = 8. *specparm_mn2o
5808 jmn2o = 1 + int(specmult_mn2o)
5809 fmn2o = mod(specmult_mn2o,1.0 )
5810 fmn2omf = minorfrac(iplon,lay)*fmn2o
5811 ! In atmospheres where the amount of N2O is too great to be considered
5812 ! a minor species, adjust the column amount of N2O by an empirical factor
5813 ! to obtain the proper contribution.
5814 chi_n2o = coln2o(iplon,lay)/coldry(iplon,lay)
5815 ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1)
5816 if (ratn2o .gt. 1.5 ) then
5817 adjfac = 0.5 +(ratn2o-0.5 )**0.65
5818 adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
5820 adjcoln2o = coln2o(iplon,lay)
5823 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay)
5824 specparm_planck = colh2o(iplon,lay)/speccomb_planck
5825 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
5826 specmult_planck = 8. *specparm_planck
5827 jpl= 1 + int(specmult_planck)
5828 fpl = mod(specmult_planck,1.0 )
5830 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(3) + js
5831 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(3) + js1
5832 inds = indself(iplon,lay)
5833 indf = indfor(iplon,lay)
5834 indm = indminor(iplon,lay)
5836 if (specparm .lt. 0.125 ) then
5840 fk1 = 1 - p - 2.0 *p4
5842 fac000 = fk0*fac00(iplon,lay)
5843 fac100 = fk1*fac00(iplon,lay)
5844 fac200 = fk2*fac00(iplon,lay)
5845 fac010 = fk0*fac10(iplon,lay)
5846 fac110 = fk1*fac10(iplon,lay)
5847 fac210 = fk2*fac10(iplon,lay)
5848 else if (specparm .gt. 0.875 ) then
5852 fk1 = 1 - p - 2.0 *p4
5854 fac000 = fk0*fac00(iplon,lay)
5855 fac100 = fk1*fac00(iplon,lay)
5856 fac200 = fk2*fac00(iplon,lay)
5857 fac010 = fk0*fac10(iplon,lay)
5858 fac110 = fk1*fac10(iplon,lay)
5859 fac210 = fk2*fac10(iplon,lay)
5861 fac000 = (1. - fs) * fac00(iplon,lay)
5862 fac010 = (1. - fs) * fac10(iplon,lay)
5863 fac100 = fs * fac00(iplon,lay)
5864 fac110 = fs * fac10(iplon,lay)
5866 if (specparm1 .lt. 0.125 ) then
5870 fk1 = 1 - p - 2.0 *p4
5872 fac001 = fk0*fac01(iplon,lay)
5873 fac101 = fk1*fac01(iplon,lay)
5874 fac201 = fk2*fac01(iplon,lay)
5875 fac011 = fk0*fac11(iplon,lay)
5876 fac111 = fk1*fac11(iplon,lay)
5877 fac211 = fk2*fac11(iplon,lay)
5878 else if (specparm1 .gt. 0.875 ) then
5882 fk1 = 1 - p - 2.0 *p4
5884 fac001 = fk0*fac01(iplon,lay)
5885 fac101 = fk1*fac01(iplon,lay)
5886 fac201 = fk2*fac01(iplon,lay)
5887 fac011 = fk0*fac11(iplon,lay)
5888 fac111 = fk1*fac11(iplon,lay)
5889 fac211 = fk2*fac11(iplon,lay)
5891 fac001 = (1. - fs1) * fac01(iplon,lay)
5892 fac011 = (1. - fs1) * fac11(iplon,lay)
5893 fac101 = fs1 * fac01(iplon,lay)
5894 fac111 = fs1 * fac11(iplon,lay)
5898 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
5899 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
5900 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
5901 (forrefd(indf+1,ig) - forrefd(indf,ig)))
5902 n2om1 = ka_mn2od(jmn2o,indm,ig) + fmn2o * &
5903 (ka_mn2od(jmn2o+1,indm,ig) - ka_mn2od(jmn2o,indm,ig))
5904 n2om2 = ka_mn2od(jmn2o,indm+1,ig) + fmn2o * &
5905 (ka_mn2od(jmn2o+1,indm+1,ig) - ka_mn2od(jmn2o,indm+1,ig))
5906 absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1)
5908 if (specparm .lt. 0.125 ) then
5909 tau_major = speccomb * &
5910 (fac000 * absad(ind0,ig) + &
5911 fac100 * absad(ind0+1,ig) + &
5912 fac200 * absad(ind0+2,ig) + &
5913 fac010 * absad(ind0+9,ig) + &
5914 fac110 * absad(ind0+10,ig) + &
5915 fac210 * absad(ind0+11,ig))
5916 else if (specparm .gt. 0.875 ) then
5917 tau_major = speccomb * &
5918 (fac200 * absad(ind0-1,ig) + &
5919 fac100 * absad(ind0,ig) + &
5920 fac000 * absad(ind0+1,ig) + &
5921 fac210 * absad(ind0+8,ig) + &
5922 fac110 * absad(ind0+9,ig) + &
5923 fac010 * absad(ind0+10,ig))
5925 tau_major = speccomb * &
5926 (fac000 * absad(ind0,ig) + &
5927 fac100 * absad(ind0+1,ig) + &
5928 fac010 * absad(ind0+9,ig) + &
5929 fac110 * absad(ind0+10,ig))
5932 if (specparm1 .lt. 0.125 ) then
5933 tau_major1 = speccomb1 * &
5934 (fac001 * absad(ind1,ig) + &
5935 fac101 * absad(ind1+1,ig) + &
5936 fac201 * absad(ind1+2,ig) + &
5937 fac011 * absad(ind1+9,ig) + &
5938 fac111 * absad(ind1+10,ig) + &
5939 fac211 * absad(ind1+11,ig))
5940 else if (specparm1 .gt. 0.875 ) then
5941 tau_major1 = speccomb1 * &
5942 (fac201 * absad(ind1-1,ig) + &
5943 fac101 * absad(ind1,ig) + &
5944 fac001 * absad(ind1+1,ig) + &
5945 fac211 * absad(ind1+8,ig) + &
5946 fac111 * absad(ind1+9,ig) + &
5947 fac011 * absad(ind1+10,ig))
5949 tau_major1 = speccomb1 * &
5950 (fac001 * absad(ind1,ig) + &
5951 fac101 * absad(ind1+1,ig) + &
5952 fac011 * absad(ind1+9,ig) + &
5953 fac111 * absad(ind1+10,ig))
5956 taug(iplon,lay,ngs2+ig) = tau_major + tau_major1 &
5957 + tauself + taufor &
5959 fracsd(iplon,lay,ngs2+ig) = fracrefad(ig,jpl) + fpl * &
5960 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
5964 ! Upper atmosphere loop
5967 speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay)
5968 specparm = colh2o(iplon,lay)/speccomb
5969 if (specparm .ge. oneminusd) specparm = oneminusd
5970 specmult = 4. *(specparm)
5971 js = 1 + int(specmult)
5972 fs = mod(specmult,1.0 )
5974 speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay)
5975 specparm1 = colh2o(iplon,lay)/speccomb1
5976 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
5977 specmult1 = 4. *(specparm1)
5978 js1 = 1 + int(specmult1)
5979 fs1 = mod(specmult1,1.0 )
5981 fac000 = (1. - fs) * fac00(iplon,lay)
5982 fac010 = (1. - fs) * fac10(iplon,lay)
5983 fac100 = fs * fac00(iplon,lay)
5984 fac110 = fs * fac10(iplon,lay)
5985 fac001 = (1. - fs1) * fac01(iplon,lay)
5986 fac011 = (1. - fs1) * fac11(iplon,lay)
5987 fac101 = fs1 * fac01(iplon,lay)
5988 fac111 = fs1 * fac11(iplon,lay)
5990 speccomb_mn2o = colh2o(iplon,lay) + refrat_m_b*colco2(iplon,lay)
5991 specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o
5992 if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd
5993 specmult_mn2o = 4. *specparm_mn2o
5994 jmn2o = 1 + int(specmult_mn2o)
5995 fmn2o = mod(specmult_mn2o,1.0 )
5996 fmn2omf = minorfrac(iplon,lay)*fmn2o
5997 ! In atmospheres where the amount of N2O is too great to be considered
5998 ! a minor species, adjust the column amount of N2O by an empirical factor
5999 ! to obtain the proper contribution.
6000 chi_n2o = coln2o(iplon,lay)/coldry(iplon,lay)
6001 ratn2o = 1.e20*chi_n2o/chi_mlsd(4,jp(iplon,lay)+1)
6002 if (ratn2o .gt. 1.5 ) then
6003 adjfac = 0.5 +(ratn2o-0.5 )**0.65
6004 adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
6006 adjcoln2o = coln2o(iplon,lay)
6009 speccomb_planck = colh2o(iplon,lay)+refrat_planck_b*colco2(iplon,lay)
6010 specparm_planck = colh2o(iplon,lay)/speccomb_planck
6011 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6012 specmult_planck = 4. *specparm_planck
6013 jpl= 1 + int(specmult_planck)
6014 fpl = mod(specmult_planck,1.0 )
6016 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(3) + js
6017 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(3) + js1
6018 indf = indfor(iplon,lay)
6019 indm = indminor(iplon,lay)
6022 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + &
6023 forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig)))
6024 n2om1 = kb_mn2od(jmn2o,indm,ig) + fmn2o * &
6025 (kb_mn2od(jmn2o+1,indm,ig)-kb_mn2od(jmn2o,indm,ig))
6026 n2om2 = kb_mn2od(jmn2o,indm+1,ig) + fmn2o * &
6027 (kb_mn2od(jmn2o+1,indm+1,ig)-kb_mn2od(jmn2o,indm+1,ig))
6028 absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1)
6029 taug(iplon,lay,ngs2+ig) = speccomb * &
6030 (fac000 * absbd(ind0,ig) + &
6031 fac100 * absbd(ind0+1,ig) + &
6032 fac010 * absbd(ind0+5,ig) + &
6033 fac110 * absbd(ind0+6,ig)) &
6035 (fac001 * absbd(ind1,ig) + &
6036 fac101 * absbd(ind1+1,ig) + &
6037 fac011 * absbd(ind1+5,ig) + &
6038 fac111 * absbd(ind1+6,ig)) &
6041 fracsd(iplon,lay,ngs2+ig) = fracrefbd(ig,jpl) + fpl * &
6042 (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl))
6053 end subroutine taugb3g
6055 !----------------------------------------------------------------------------
6056 _gpuker subroutine taugb4g( ncol, nlayers, taug, fracsd &
6057 #include "taug_cpu_args.h"
6059 !----------------------------------------------------------------------------
6061 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
6062 !----------------------------------------------------------------------------
6064 ! ------- Modules -------
6066 ! use parrrtm_f, only : ng4, ngs3
6067 use parrrtm_f, only : ngs3
6068 use rrlw_ref_f, only : chi_mlsd
6071 ! ------- Declarations -------
6072 #include "taug_cpu_defs.h"
6075 real _gpudev :: taug(:,:,:)
6076 real _gpudev :: fracsd(:,:,:)
6079 integer :: lay, ind0, ind1, inds, indf, ig
6080 integer :: js, js1, jpl
6081 real :: speccomb, specparm, specmult, fs
6082 real :: speccomb1, specparm1, specmult1, fs1
6083 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
6084 real :: p, p4, fk0, fk1, fk2
6085 real :: fac000, fac100, fac200, fac010, fac110, fac210
6086 real :: fac001, fac101, fac201, fac011, fac111, fac211
6087 real :: tauself, taufor
6088 real :: refrat_planck_a, refrat_planck_b
6089 real :: tau_major, tau_major1
6090 integer , value, intent(in) :: ncol, nlayers
6094 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
6095 lay = (blockidx%y-1) * blockdim%y + threadidx%y
6096 if (iplon <= ncol .and. lay <= nlayers) then
6102 refrat_planck_a = chi_mlsd(1,11)/chi_mlsd(2,11)
6105 refrat_planck_b = chi_mlsd(3,13)/chi_mlsd(2,13)
6107 ! Compute the optical depth by interpolating in ln(pressure) and
6108 ! temperature, and appropriate species. Below laytrop, the water
6109 ! vapor self-continuum and foreign continuum is interpolated (in temperature)
6112 ! Lower atmosphere loop
6113 if (lay <= laytrop(iplon)) then
6115 speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay)
6116 specparm = colh2o(iplon,lay)/speccomb
6117 if (specparm .ge. oneminusd) specparm = oneminusd
6118 specmult = 8. *(specparm)
6119 js = 1 + int(specmult)
6120 fs = mod(specmult,1.0 )
6122 speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay)
6123 specparm1 = colh2o(iplon,lay)/speccomb1
6124 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
6125 specmult1 = 8. *(specparm1)
6126 js1 = 1 + int(specmult1)
6127 fs1 = mod(specmult1,1.0 )
6129 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay)
6130 specparm_planck = colh2o(iplon,lay)/speccomb_planck
6131 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6132 specmult_planck = 8. *specparm_planck
6133 jpl= 1 + int(specmult_planck)
6134 fpl = mod(specmult_planck,1.0 )
6136 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(4) + js
6137 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(4) + js1
6138 inds = indself(iplon,lay)
6139 indf = indfor(iplon,lay)
6141 if (specparm .lt. 0.125 ) then
6145 fk1 = 1 - p - 2.0 *p4
6147 fac000 = fk0*fac00(iplon,lay)
6148 fac100 = fk1*fac00(iplon,lay)
6149 fac200 = fk2*fac00(iplon,lay)
6150 fac010 = fk0*fac10(iplon,lay)
6151 fac110 = fk1*fac10(iplon,lay)
6152 fac210 = fk2*fac10(iplon,lay)
6153 else if (specparm .gt. 0.875 ) then
6157 fk1 = 1 - p - 2.0 *p4
6159 fac000 = fk0*fac00(iplon,lay)
6160 fac100 = fk1*fac00(iplon,lay)
6161 fac200 = fk2*fac00(iplon,lay)
6162 fac010 = fk0*fac10(iplon,lay)
6163 fac110 = fk1*fac10(iplon,lay)
6164 fac210 = fk2*fac10(iplon,lay)
6166 fac000 = (1. - fs) * fac00(iplon,lay)
6167 fac010 = (1. - fs) * fac10(iplon,lay)
6168 fac100 = fs * fac00(iplon,lay)
6169 fac110 = fs * fac10(iplon,lay)
6172 if (specparm1 .lt. 0.125 ) then
6176 fk1 = 1 - p - 2.0 *p4
6178 fac001 = fk0*fac01(iplon,lay)
6179 fac101 = fk1*fac01(iplon,lay)
6180 fac201 = fk2*fac01(iplon,lay)
6181 fac011 = fk0*fac11(iplon,lay)
6182 fac111 = fk1*fac11(iplon,lay)
6183 fac211 = fk2*fac11(iplon,lay)
6184 else if (specparm1 .gt. 0.875 ) then
6188 fk1 = 1 - p - 2.0 *p4
6190 fac001 = fk0*fac01(iplon,lay)
6191 fac101 = fk1*fac01(iplon,lay)
6192 fac201 = fk2*fac01(iplon,lay)
6193 fac011 = fk0*fac11(iplon,lay)
6194 fac111 = fk1*fac11(iplon,lay)
6195 fac211 = fk2*fac11(iplon,lay)
6197 fac001 = (1. - fs1) * fac01(iplon,lay)
6198 fac011 = (1. - fs1) * fac11(iplon,lay)
6199 fac101 = fs1 * fac01(iplon,lay)
6200 fac111 = fs1 * fac11(iplon,lay)
6204 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
6205 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
6206 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
6207 (forrefd(indf+1,ig) - forrefd(indf,ig)))
6209 if (specparm .lt. 0.125 ) then
6210 tau_major = speccomb * &
6211 (fac000 * absad(ind0,ig) + &
6212 fac100 * absad(ind0+1,ig) + &
6213 fac200 * absad(ind0+2,ig) + &
6214 fac010 * absad(ind0+9,ig) + &
6215 fac110 * absad(ind0+10,ig) + &
6216 fac210 * absad(ind0+11,ig))
6217 else if (specparm .gt. 0.875 ) then
6218 tau_major = speccomb * &
6219 (fac200 * absad(ind0-1,ig) + &
6220 fac100 * absad(ind0,ig) + &
6221 fac000 * absad(ind0+1,ig) + &
6222 fac210 * absad(ind0+8,ig) + &
6223 fac110 * absad(ind0+9,ig) + &
6224 fac010 * absad(ind0+10,ig))
6226 tau_major = speccomb * &
6227 (fac000 * absad(ind0,ig) + &
6228 fac100 * absad(ind0+1,ig) + &
6229 fac010 * absad(ind0+9,ig) + &
6230 fac110 * absad(ind0+10,ig))
6233 if (specparm1 .lt. 0.125 ) then
6234 tau_major1 = speccomb1 * &
6235 (fac001 * absad(ind1,ig) + &
6236 fac101 * absad(ind1+1,ig) + &
6237 fac201 * absad(ind1+2,ig) + &
6238 fac011 * absad(ind1+9,ig) + &
6239 fac111 * absad(ind1+10,ig) + &
6240 fac211 * absad(ind1+11,ig))
6241 else if (specparm1 .gt. 0.875 ) then
6242 tau_major1 = speccomb1 * &
6243 (fac201 * absad(ind1-1,ig) + &
6244 fac101 * absad(ind1,ig) + &
6245 fac001 * absad(ind1+1,ig) + &
6246 fac211 * absad(ind1+8,ig) + &
6247 fac111 * absad(ind1+9,ig) + &
6248 fac011 * absad(ind1+10,ig))
6250 tau_major1 = speccomb1 * &
6251 (fac001 * absad(ind1,ig) + &
6252 fac101 * absad(ind1+1,ig) + &
6253 fac011 * absad(ind1+9,ig) + &
6254 fac111 * absad(ind1+10,ig))
6257 taug(iplon,lay,ngs3+ig) = tau_major + tau_major1 &
6259 fracsd(iplon,lay,ngs3+ig) = fracrefad(ig,jpl) + fpl * &
6260 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
6264 ! Upper atmosphere loop
6267 speccomb = colo3(iplon,lay) + rat_o3co2(iplon,lay)*colco2(iplon,lay)
6268 specparm = colo3(iplon,lay)/speccomb
6269 if (specparm .ge. oneminusd) specparm = oneminusd
6270 specmult = 4. *(specparm)
6271 js = 1 + int(specmult)
6272 fs = mod(specmult,1.0 )
6274 speccomb1 = colo3(iplon,lay) + rat_o3co2_1(iplon,lay)*colco2(iplon,lay)
6275 specparm1 = colo3(iplon,lay)/speccomb1
6276 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
6277 specmult1 = 4. *(specparm1)
6278 js1 = 1 + int(specmult1)
6279 fs1 = mod(specmult1,1.0 )
6281 fac000 = (1. - fs) * fac00(iplon,lay)
6282 fac010 = (1. - fs) * fac10(iplon,lay)
6283 fac100 = fs * fac00(iplon,lay)
6284 fac110 = fs * fac10(iplon,lay)
6285 fac001 = (1. - fs1) * fac01(iplon,lay)
6286 fac011 = (1. - fs1) * fac11(iplon,lay)
6287 fac101 = fs1 * fac01(iplon,lay)
6288 fac111 = fs1 * fac11(iplon,lay)
6290 speccomb_planck = colo3(iplon,lay)+refrat_planck_b*colco2(iplon,lay)
6291 specparm_planck = colo3(iplon,lay)/speccomb_planck
6292 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6293 specmult_planck = 4. *specparm_planck
6294 jpl= 1 + int(specmult_planck)
6295 fpl = mod(specmult_planck,1.0 )
6297 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(4) + js
6298 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(4) + js1
6301 taug(iplon,lay,ngs3+ig) = speccomb * &
6302 (fac000 * absbd(ind0,ig) + &
6303 fac100 * absbd(ind0+1,ig) + &
6304 fac010 * absbd(ind0+5,ig) + &
6305 fac110 * absbd(ind0+6,ig)) &
6307 (fac001 * absbd(ind1,ig) + &
6308 fac101 * absbd(ind1+1,ig) + &
6309 fac011 * absbd(ind1+5,ig) + &
6310 fac111 * absbd(ind1+6,ig))
6311 fracsd(iplon,lay,ngs3+ig) = fracrefbd(ig,jpl) + fpl * &
6312 (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl))
6315 ! Empirical modification to code to improve stratospheric cooling rates
6316 ! for co2. Revised to apply weighting for g-point reduction in this band.
6318 taug(iplon,lay,ngs3+8)=taug(iplon,lay,ngs3+8)*0.92
6319 taug(iplon,lay,ngs3+9)=taug(iplon,lay,ngs3+9)*0.88
6320 taug(iplon,lay,ngs3+10)=taug(iplon,lay,ngs3+10)*1.07
6321 taug(iplon,lay,ngs3+11)=taug(iplon,lay,ngs3+11)*1.1
6322 taug(iplon,lay,ngs3+12)=taug(iplon,lay,ngs3+12)*0.99
6323 taug(iplon,lay,ngs3+13)=taug(iplon,lay,ngs3+13)*0.88
6324 taug(iplon,lay,ngs3+14)=taug(iplon,lay,ngs3+14)*0.943
6335 end subroutine taugb4g
6337 !----------------------------------------------------------------------------
6338 _gpuker subroutine taugb5g( ncol, nlayers , taug, fracsd &
6339 #include "taug_cpu_args.h"
6341 !----------------------------------------------------------------------------
6343 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
6344 ! (high key - o3,co2)
6345 !----------------------------------------------------------------------------
6347 ! ------- Modules -------
6349 ! use parrrtm_f, only : ng5, ngs4
6350 use parrrtm_f, only : ngs4
6351 use rrlw_ref_f, only : chi_mlsd
6354 ! ------- Declarations -------
6355 #include "taug_cpu_defs.h"
6358 real _gpudev :: taug(:,:,:)
6359 real _gpudev :: fracsd(:,:,:)
6361 integer :: lay, ind0, ind1, inds, indf, indm, ig
6362 integer :: js, js1, jmo3, jpl
6363 real :: speccomb, specparm, specmult, fs
6364 real :: speccomb1, specparm1, specmult1, fs1
6365 real :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3
6366 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
6367 real :: p, p4, fk0, fk1, fk2
6368 real :: fac000, fac100, fac200, fac010, fac110, fac210
6369 real :: fac001, fac101, fac201, fac011, fac111, fac211
6370 real :: tauself, taufor, o3m1, o3m2, abso3
6371 real :: refrat_planck_a, refrat_planck_b, refrat_m_a
6372 real :: tau_major, tau_major1
6373 integer , value, intent(in) :: ncol, nlayers
6377 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
6378 lay = (blockidx%y-1) * blockdim%y + threadidx%y
6379 if (iplon <= ncol .and. lay <= nlayers) then
6384 ! Minor gas mapping level :
6385 ! lower - o3, p = 317.34 mbar, t = 240.77 k
6388 ! Calculate reference ratio to be used in calculation of Planck
6389 ! fraction in lower/upper atmosphere.
6392 refrat_planck_a = chi_mlsd(1,5)/chi_mlsd(2,5)
6395 refrat_planck_b = chi_mlsd(3,43)/chi_mlsd(2,43)
6398 refrat_m_a = chi_mlsd(1,7)/chi_mlsd(2,7)
6400 ! Compute the optical depth by interpolating in ln(pressure) and
6401 ! temperature, and appropriate species. Below laytrop, the
6402 ! water vapor self-continuum and foreign continuum is
6403 ! interpolated (in temperature) separately.
6405 ! Lower atmosphere loop
6406 !do lay = 1, laytrop(iplon)
6407 if (lay <= laytrop(iplon)) then
6408 speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay)
6409 specparm = colh2o(iplon,lay)/speccomb
6410 if (specparm .ge. oneminusd) specparm = oneminusd
6411 specmult = 8. *(specparm)
6412 js = 1 + int(specmult)
6413 fs = mod(specmult,1.0 )
6415 speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay)
6416 specparm1 = colh2o(iplon,lay)/speccomb1
6417 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
6418 specmult1 = 8. *(specparm1)
6419 js1 = 1 + int(specmult1)
6420 fs1 = mod(specmult1,1.0 )
6422 speccomb_mo3 = colh2o(iplon,lay) + refrat_m_a*colco2(iplon,lay)
6423 specparm_mo3 = colh2o(iplon,lay)/speccomb_mo3
6424 if (specparm_mo3 .ge. oneminusd) specparm_mo3 = oneminusd
6425 specmult_mo3 = 8. *specparm_mo3
6426 jmo3 = 1 + int(specmult_mo3)
6427 fmo3 = mod(specmult_mo3,1.0 )
6429 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay)
6430 specparm_planck = colh2o(iplon,lay)/speccomb_planck
6431 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6432 specmult_planck = 8. *specparm_planck
6433 jpl= 1 + int(specmult_planck)
6434 fpl = mod(specmult_planck,1.0 )
6436 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(5) + js
6437 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(5) + js1
6438 inds = indself(iplon,lay)
6439 indf = indfor(iplon,lay)
6440 indm = indminor(iplon,lay)
6442 if (specparm .lt. 0.125 ) then
6446 fk1 = 1 - p - 2.0 *p4
6448 fac000 = fk0*fac00(iplon,lay)
6449 fac100 = fk1*fac00(iplon,lay)
6450 fac200 = fk2*fac00(iplon,lay)
6451 fac010 = fk0*fac10(iplon,lay)
6452 fac110 = fk1*fac10(iplon,lay)
6453 fac210 = fk2*fac10(iplon,lay)
6454 else if (specparm .gt. 0.875 ) then
6458 fk1 = 1 - p - 2.0 *p4
6460 fac000 = fk0*fac00(iplon,lay)
6461 fac100 = fk1*fac00(iplon,lay)
6462 fac200 = fk2*fac00(iplon,lay)
6463 fac010 = fk0*fac10(iplon,lay)
6464 fac110 = fk1*fac10(iplon,lay)
6465 fac210 = fk2*fac10(iplon,lay)
6467 fac000 = (1. - fs) * fac00(iplon,lay)
6468 fac010 = (1. - fs) * fac10(iplon,lay)
6469 fac100 = fs * fac00(iplon,lay)
6470 fac110 = fs * fac10(iplon,lay)
6473 if (specparm1 .lt. 0.125 ) then
6477 fk1 = 1 - p - 2.0 *p4
6479 fac001 = fk0*fac01(iplon,lay)
6480 fac101 = fk1*fac01(iplon,lay)
6481 fac201 = fk2*fac01(iplon,lay)
6482 fac011 = fk0*fac11(iplon,lay)
6483 fac111 = fk1*fac11(iplon,lay)
6484 fac211 = fk2*fac11(iplon,lay)
6485 else if (specparm1 .gt. 0.875 ) then
6489 fk1 = 1 - p - 2.0 *p4
6491 fac001 = fk0*fac01(iplon,lay)
6492 fac101 = fk1*fac01(iplon,lay)
6493 fac201 = fk2*fac01(iplon,lay)
6494 fac011 = fk0*fac11(iplon,lay)
6495 fac111 = fk1*fac11(iplon,lay)
6496 fac211 = fk2*fac11(iplon,lay)
6498 fac001 = (1. - fs1) * fac01(iplon,lay)
6499 fac011 = (1. - fs1) * fac11(iplon,lay)
6500 fac101 = fs1 * fac01(iplon,lay)
6501 fac111 = fs1 * fac11(iplon,lay)
6505 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
6506 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
6507 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
6508 (forrefd(indf+1,ig) - forrefd(indf,ig)))
6509 o3m1 = ka_mo3d(jmo3,indm,ig) + fmo3 * &
6510 (ka_mo3d(jmo3+1,indm,ig)-ka_mo3d(jmo3,indm,ig))
6511 o3m2 = ka_mo3d(jmo3,indm+1,ig) + fmo3 * &
6512 (ka_mo3d(jmo3+1,indm+1,ig)-ka_mo3d(jmo3,indm+1,ig))
6513 abso3 = o3m1 + minorfrac(iplon,lay)*(o3m2-o3m1)
6515 if (specparm .lt. 0.125 ) then
6516 tau_major = speccomb * &
6517 (fac000 * absad(ind0,ig) + &
6518 fac100 * absad(ind0+1,ig) + &
6519 fac200 * absad(ind0+2,ig) + &
6520 fac010 * absad(ind0+9,ig) + &
6521 fac110 * absad(ind0+10,ig) + &
6522 fac210 * absad(ind0+11,ig))
6523 else if (specparm .gt. 0.875 ) then
6524 tau_major = speccomb * &
6525 (fac200 * absad(ind0-1,ig) + &
6526 fac100 * absad(ind0,ig) + &
6527 fac000 * absad(ind0+1,ig) + &
6528 fac210 * absad(ind0+8,ig) + &
6529 fac110 * absad(ind0+9,ig) + &
6530 fac010 * absad(ind0+10,ig))
6532 tau_major = speccomb * &
6533 (fac000 * absad(ind0,ig) + &
6534 fac100 * absad(ind0+1,ig) + &
6535 fac010 * absad(ind0+9,ig) + &
6536 fac110 * absad(ind0+10,ig))
6539 if (specparm1 .lt. 0.125 ) then
6540 tau_major1 = speccomb1 * &
6541 (fac001 * absad(ind1,ig) + &
6542 fac101 * absad(ind1+1,ig) + &
6543 fac201 * absad(ind1+2,ig) + &
6544 fac011 * absad(ind1+9,ig) + &
6545 fac111 * absad(ind1+10,ig) + &
6546 fac211 * absad(ind1+11,ig))
6547 else if (specparm1 .gt. 0.875 ) then
6548 tau_major1 = speccomb1 * &
6549 (fac201 * absad(ind1-1,ig) + &
6550 fac101 * absad(ind1,ig) + &
6551 fac001 * absad(ind1+1,ig) + &
6552 fac211 * absad(ind1+8,ig) + &
6553 fac111 * absad(ind1+9,ig) + &
6554 fac011 * absad(ind1+10,ig))
6556 tau_major1 = speccomb1 * &
6557 (fac001 * absad(ind1,ig) + &
6558 fac101 * absad(ind1+1,ig) + &
6559 fac011 * absad(ind1+9,ig) + &
6560 fac111 * absad(ind1+10,ig))
6563 taug(iplon,lay,ngs4+ig) = tau_major + tau_major1 &
6564 + tauself + taufor &
6565 + abso3*colo3(iplon,lay) &
6566 + wx1(iplon,lay) * coldry(iplon,lay) * 1.e-20 * ccl4d(ig)
6567 fracsd(iplon,lay,ngs4+ig) = fracrefad(ig,jpl) + fpl * &
6568 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
6572 ! Upper atmosphere loop
6573 !do lay = laytrop(iplon)+1, nlayers
6575 speccomb = colo3(iplon,lay) + rat_o3co2(iplon,lay)*colco2(iplon,lay)
6576 specparm = colo3(iplon,lay)/speccomb
6577 if (specparm .ge. oneminusd) specparm = oneminusd
6578 specmult = 4. *(specparm)
6579 js = 1 + int(specmult)
6580 fs = mod(specmult,1.0 )
6582 speccomb1 = colo3(iplon,lay) + rat_o3co2_1(iplon,lay)*colco2(iplon,lay)
6583 specparm1 = colo3(iplon,lay)/speccomb1
6584 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
6585 specmult1 = 4. *(specparm1)
6586 js1 = 1 + int(specmult1)
6587 fs1 = mod(specmult1,1.0 )
6589 fac000 = (1. - fs) * fac00(iplon,lay)
6590 fac010 = (1. - fs) * fac10(iplon,lay)
6591 fac100 = fs * fac00(iplon,lay)
6592 fac110 = fs * fac10(iplon,lay)
6593 fac001 = (1. - fs1) * fac01(iplon,lay)
6594 fac011 = (1. - fs1) * fac11(iplon,lay)
6595 fac101 = fs1 * fac01(iplon,lay)
6596 fac111 = fs1 * fac11(iplon,lay)
6598 speccomb_planck = colo3(iplon,lay)+refrat_planck_b*colco2(iplon,lay)
6599 specparm_planck = colo3(iplon,lay)/speccomb_planck
6600 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6601 specmult_planck = 4. *specparm_planck
6602 jpl= 1 + int(specmult_planck)
6603 fpl = mod(specmult_planck,1.0 )
6605 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(5) + js
6606 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(5) + js1
6609 taug(iplon,lay,ngs4+ig) = speccomb * &
6610 (fac000 * absbd(ind0,ig) + &
6611 fac100 * absbd(ind0+1,ig) + &
6612 fac010 * absbd(ind0+5,ig) + &
6613 fac110 * absbd(ind0+6,ig)) &
6615 (fac001 * absbd(ind1,ig) + &
6616 fac101 * absbd(ind1+1,ig) + &
6617 fac011 * absbd(ind1+5,ig) + &
6618 fac111 * absbd(ind1+6,ig)) &
6619 + wx1(iplon, lay) * coldry(iplon,lay) * 1.e-20 * ccl4d(ig)
6620 fracsd(iplon,lay,ngs4+ig) = fracrefbd(ig,jpl) + fpl * &
6621 (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl))
6632 end subroutine taugb5g
6634 !----------------------------------------------------------------------------
6635 _gpuker subroutine taugb6g( ncol, nlayers, taug, fracsd &
6636 #include "taug_cpu_args.h"
6638 !----------------------------------------------------------------------------
6640 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
6641 ! (high key - nothing; high minor - cfc11, cfc12)
6642 !----------------------------------------------------------------------------
6644 ! ------- Modules -------
6646 ! use parrrtm_f, only : ng6, ngs5
6647 use parrrtm_f, only : ngs5
6648 use rrlw_ref_f, only : chi_mlsd
6651 ! ------- Declarations -------
6652 #include "taug_cpu_defs.h"
6655 integer :: lay, ind0, ind1, inds, indf, indm, ig
6656 real :: chi_co2, ratco2, adjfac, adjcolco2
6657 real :: tauself, taufor, absco2
6658 integer , value, intent(in) :: ncol, nlayers
6660 real _gpudev :: taug(:,:,:)
6661 real _gpudev :: fracsd(:,:,:)
6664 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
6665 lay = (blockidx%y-1) * blockdim%y + threadidx%y
6666 if (iplon <= ncol .and. lay <= nlayers) then
6671 ! Minor gas mapping level:
6672 ! lower - co2, p = 706.2720 mb, t = 294.2 k
6673 ! upper - cfc11, cfc12
6675 ! Compute the optical depth by interpolating in ln(pressure) and
6676 ! temperature. The water vapor self-continuum and foreign continuum
6677 ! is interpolated (in temperature) separately.
6679 ! Lower atmosphere loop
6680 if (lay <= laytrop(iplon)) then
6682 ! In atmospheres where the amount of CO2 is too great to be considered
6683 ! a minor species, adjust the column amount of CO2 by an empirical factor
6684 ! to obtain the proper contribution.
6685 chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay))
6686 ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1)
6687 if (ratco2 .gt. 3.0 ) then
6688 adjfac = 2.0 +(ratco2-2.0 )**0.77
6689 adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
6691 adjcolco2 = colco2(iplon,lay)
6694 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(6) + 1
6695 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(6) + 1
6696 inds = indself(iplon,lay)
6697 indf = indfor(iplon,lay)
6698 indm = indminor(iplon,lay)
6701 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
6702 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
6703 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
6704 (forrefd(indf+1,ig) - forrefd(indf,ig)))
6705 absco2 = (ka_mco2d(indm,ig) + minorfrac(iplon,lay) * &
6706 (ka_mco2d(indm+1,ig) - ka_mco2d(indm,ig)))
6707 taug(iplon,lay,ngs5+ig) = colh2o(iplon,lay) * &
6708 (fac00(iplon,lay) * absad(ind0,ig) + &
6709 fac10(iplon,lay) * absad(ind0+1,ig) + &
6710 fac01(iplon,lay) * absad(ind1,ig) + &
6711 fac11(iplon,lay) * absad(ind1+1,ig)) &
6712 + tauself + taufor &
6713 + adjcolco2 * absco2 &
6714 + wx2(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc11adjd(ig) &
6715 + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig)
6716 fracsd(iplon,lay,ngs5+ig) = fracrefad(ig)
6721 taug(iplon,lay,ngs5+ig) = 0.0 &
6722 + wx2(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc11adjd(ig) &
6723 + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig)
6724 fracsd(iplon,lay,ngs5+ig) = fracrefad(ig)
6735 end subroutine taugb6g
6737 !----------------------------------------------------------------------------
6738 _gpuker subroutine taugb7g( ncol, nlayers , taug, fracsd &
6739 #include "taug_cpu_args.h"
6741 !----------------------------------------------------------------------------
6743 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
6744 ! (high key - o3; high minor - co2)
6745 !----------------------------------------------------------------------------
6747 ! ------- Modules -------
6749 ! use parrrtm_f, only : ng7, ngs6
6750 use parrrtm_f, only : ngs6
6751 use rrlw_ref_f, only : chi_mlsd
6754 ! ------- Declarations -------
6755 #include "taug_cpu_defs.h"
6758 real _gpudev :: taug(:,:,:)
6759 real _gpudev :: fracsd(:,:,:)
6761 integer :: lay, ind0, ind1, inds, indf, indm, ig
6762 integer :: js, js1, jmco2, jpl
6763 real :: speccomb, specparm, specmult, fs
6764 real :: speccomb1, specparm1, specmult1, fs1
6765 real :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
6766 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
6767 real :: p, p4, fk0, fk1, fk2
6768 real :: fac000, fac100, fac200, fac010, fac110, fac210
6769 real :: fac001, fac101, fac201, fac011, fac111, fac211
6770 real :: tauself, taufor, co2m1, co2m2, absco2
6771 real :: chi_co2, ratco2, adjfac, adjcolco2
6772 real :: refrat_planck_a, refrat_m_a
6773 real :: tau_major, tau_major1
6774 integer , value, intent(in) :: ncol, nlayers
6778 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
6779 lay = (blockidx%y-1) * blockdim%y + threadidx%y
6780 if (iplon <= ncol .and. lay <= nlayers) then
6785 ! Minor gas mapping level :
6786 ! lower - co2, p = 706.2620 mbar, t= 278.94 k
6787 ! upper - co2, p = 12.9350 mbar, t = 234.01 k
6789 ! Calculate reference ratio to be used in calculation of Planck
6790 ! fraction in lower atmosphere.
6793 refrat_planck_a = chi_mlsd(1,3)/chi_mlsd(3,3)
6796 refrat_m_a = chi_mlsd(1,3)/chi_mlsd(3,3)
6798 ! Compute the optical depth by interpolating in ln(pressure),
6799 ! temperature, and appropriate species. Below laytrop, the water
6800 ! vapor self-continuum and foreign continuum is interpolated
6801 ! (in temperature) separately.
6803 ! Lower atmosphere loop
6804 if (lay <= laytrop(iplon)) then
6806 speccomb = colh2o(iplon,lay) + rat_h2oo3(iplon,lay)*colo3(iplon,lay)
6807 specparm = colh2o(iplon,lay)/speccomb
6808 if (specparm .ge. oneminusd) specparm = oneminusd
6809 specmult = 8. *(specparm)
6810 js = 1 + int(specmult)
6811 fs = mod(specmult,1.0 )
6813 speccomb1 = colh2o(iplon,lay) + rat_h2oo3_1(iplon,lay)*colo3(iplon,lay)
6814 specparm1 = colh2o(iplon,lay)/speccomb1
6815 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
6816 specmult1 = 8. *(specparm1)
6817 js1 = 1 + int(specmult1)
6818 fs1 = mod(specmult1,1.0 )
6820 speccomb_mco2 = colh2o(iplon,lay) + refrat_m_a*colo3(iplon,lay)
6821 specparm_mco2 = colh2o(iplon,lay)/speccomb_mco2
6822 if (specparm_mco2 .ge. oneminusd) specparm_mco2 = oneminusd
6823 specmult_mco2 = 8. *specparm_mco2
6825 jmco2 = 1 + int(specmult_mco2)
6826 fmco2 = mod(specmult_mco2,1.0 )
6828 ! In atmospheres where the amount of CO2 is too great to be considered
6829 ! a minor species, adjust the column amount of CO2 by an empirical factor
6830 ! to obtain the proper contribution.
6831 chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay))
6832 ratco2 = 1.e20*chi_co2/chi_mlsd(2,jp(iplon,lay)+1)
6833 if (ratco2 .gt. 3.0 ) then
6834 adjfac = 3.0 +(ratco2-3.0 )**0.79
6835 adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
6837 adjcolco2 = colco2(iplon,lay)
6840 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colo3(iplon,lay)
6841 specparm_planck = colh2o(iplon,lay)/speccomb_planck
6842 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
6843 specmult_planck = 8. *specparm_planck
6844 jpl= 1 + int(specmult_planck)
6845 fpl = mod(specmult_planck,1.0 )
6847 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(7) + js
6848 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(7) + js1
6849 inds = indself(iplon,lay)
6850 indf = indfor(iplon,lay)
6851 indm = indminor(iplon,lay)
6853 if (specparm .lt. 0.125 ) then
6857 fk1 = 1 - p - 2.0 *p4
6859 fac000 = fk0*fac00(iplon,lay)
6860 fac100 = fk1*fac00(iplon,lay)
6861 fac200 = fk2*fac00(iplon,lay)
6862 fac010 = fk0*fac10(iplon,lay)
6863 fac110 = fk1*fac10(iplon,lay)
6864 fac210 = fk2*fac10(iplon,lay)
6865 else if (specparm .gt. 0.875 ) then
6869 fk1 = 1 - p - 2.0 *p4
6871 fac000 = fk0*fac00(iplon,lay)
6872 fac100 = fk1*fac00(iplon,lay)
6873 fac200 = fk2*fac00(iplon,lay)
6874 fac010 = fk0*fac10(iplon,lay)
6875 fac110 = fk1*fac10(iplon,lay)
6876 fac210 = fk2*fac10(iplon,lay)
6878 fac000 = (1. - fs) * fac00(iplon,lay)
6879 fac010 = (1. - fs) * fac10(iplon,lay)
6880 fac100 = fs * fac00(iplon,lay)
6881 fac110 = fs * fac10(iplon,lay)
6883 if (specparm1 .lt. 0.125 ) then
6887 fk1 = 1 - p - 2.0 *p4
6889 fac001 = fk0*fac01(iplon,lay)
6890 fac101 = fk1*fac01(iplon,lay)
6891 fac201 = fk2*fac01(iplon,lay)
6892 fac011 = fk0*fac11(iplon,lay)
6893 fac111 = fk1*fac11(iplon,lay)
6894 fac211 = fk2*fac11(iplon,lay)
6895 else if (specparm1 .gt. 0.875 ) then
6899 fk1 = 1 - p - 2.0 *p4
6901 fac001 = fk0*fac01(iplon,lay)
6902 fac101 = fk1*fac01(iplon,lay)
6903 fac201 = fk2*fac01(iplon,lay)
6904 fac011 = fk0*fac11(iplon,lay)
6905 fac111 = fk1*fac11(iplon,lay)
6906 fac211 = fk2*fac11(iplon,lay)
6908 fac001 = (1. - fs1) * fac01(iplon,lay)
6909 fac011 = (1. - fs1) * fac11(iplon,lay)
6910 fac101 = fs1 * fac01(iplon,lay)
6911 fac111 = fs1 * fac11(iplon,lay)
6915 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
6916 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
6917 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
6918 (forrefd(indf+1,ig) - forrefd(indf,ig)))
6919 co2m1 = ka_mco2d(jmco2,indm,ig) + fmco2 * &
6920 (ka_mco2d(jmco2+1,indm,ig) - ka_mco2d(jmco2,indm,ig))
6921 co2m2 = ka_mco2d(jmco2,indm+1,ig) + fmco2 * &
6922 (ka_mco2d(jmco2+1,indm+1,ig) - ka_mco2d(jmco2,indm+1,ig))
6923 absco2 = co2m1 + minorfrac(iplon,lay) * (co2m2 - co2m1)
6925 if (specparm .lt. 0.125 ) then
6926 tau_major = speccomb * &
6927 (fac000 * absad(ind0,ig) + &
6928 fac100 * absad(ind0+1,ig) + &
6929 fac200 * absad(ind0+2,ig) + &
6930 fac010 * absad(ind0+9,ig) + &
6931 fac110 * absad(ind0+10,ig) + &
6932 fac210 * absad(ind0+11,ig))
6933 else if (specparm .gt. 0.875 ) then
6934 tau_major = speccomb * &
6935 (fac200 * absad(ind0-1,ig) + &
6936 fac100 * absad(ind0,ig) + &
6937 fac000 * absad(ind0+1,ig) + &
6938 fac210 * absad(ind0+8,ig) + &
6939 fac110 * absad(ind0+9,ig) + &
6940 fac010 * absad(ind0+10,ig))
6942 tau_major = speccomb * &
6943 (fac000 * absad(ind0,ig) + &
6944 fac100 * absad(ind0+1,ig) + &
6945 fac010 * absad(ind0+9,ig) + &
6946 fac110 * absad(ind0+10,ig))
6949 if (specparm1 .lt. 0.125 ) then
6950 tau_major1 = speccomb1 * &
6951 (fac001 * absad(ind1,ig) + &
6952 fac101 * absad(ind1+1,ig) + &
6953 fac201 * absad(ind1+2,ig) + &
6954 fac011 * absad(ind1+9,ig) + &
6955 fac111 * absad(ind1+10,ig) + &
6956 fac211 * absad(ind1+11,ig))
6957 else if (specparm1 .gt. 0.875 ) then
6958 tau_major1 = speccomb1 * &
6959 (fac201 * absad(ind1-1,ig) + &
6960 fac101 * absad(ind1,ig) + &
6961 fac001 * absad(ind1+1,ig) + &
6962 fac211 * absad(ind1+8,ig) + &
6963 fac111 * absad(ind1+9,ig) + &
6964 fac011 * absad(ind1+10,ig))
6966 tau_major1 = speccomb1 * &
6967 (fac001 * absad(ind1,ig) + &
6968 fac101 * absad(ind1+1,ig) + &
6969 fac011 * absad(ind1+9,ig) + &
6970 fac111 * absad(ind1+10,ig))
6973 taug(iplon,lay,ngs6+ig) = tau_major + tau_major1 &
6974 + tauself + taufor &
6976 fracsd(iplon,lay,ngs6+ig) = fracrefad(ig,jpl) + fpl * &
6977 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
6980 ! In atmospheres where the amount of CO2 is too great to be considered
6981 ! a minor species, adjust the column amount of CO2 by an empirical factor
6982 ! to obtain the proper contribution.
6983 chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay))
6984 ratco2 = 1.e20*chi_co2/chi_mlsd(2,jp(iplon,lay)+1)
6985 if (ratco2 .gt. 3.0 ) then
6986 adjfac = 2.0 +(ratco2-2.0 )**0.79
6987 adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
6989 adjcolco2 = colco2(iplon,lay)
6992 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(7) + 1
6993 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(7) + 1
6994 indm = indminor(iplon,lay)
6997 absco2 = kb_mco2d(indm,ig) + minorfrac(iplon,lay) * &
6998 (kb_mco2d(indm+1,ig) - kb_mco2d(indm,ig))
6999 taug(iplon,lay,ngs6+ig) = colo3(iplon,lay) * &
7000 (fac00(iplon,lay) * absbd(ind0,ig) + &
7001 fac10(iplon,lay) * absbd(ind0+1,ig) + &
7002 fac01(iplon,lay) * absbd(ind1,ig) + &
7003 fac11(iplon,lay) * absbd(ind1+1,ig)) &
7004 + adjcolco2 * absco2
7005 fracsd(iplon,lay,ngs6+ig) = fracrefbd(ig)
7008 ! Empirical modification to code to improve stratospheric cooling rates
7009 ! for o3. Revised to apply weighting for g-point reduction in this band.
7011 taug(iplon,lay,ngs6+6)=taug(iplon,lay,ngs6+6)*0.92
7012 taug(iplon,lay,ngs6+7)=taug(iplon,lay,ngs6+7)*0.88
7013 taug(iplon,lay,ngs6+8)=taug(iplon,lay,ngs6+8)*1.07
7014 taug(iplon,lay,ngs6+9)=taug(iplon,lay,ngs6+9)*1.1
7015 taug(iplon,lay,ngs6+10)=taug(iplon,lay,ngs6+10)*0.99
7016 taug(iplon,lay,ngs6+11)=taug(iplon,lay,ngs6+11)*0.855
7027 end subroutine taugb7g
7029 !----------------------------------------------------------------------------
7030 _gpuker subroutine taugb8g( ncol, nlayers, taug, fracsd &
7031 #include "taug_cpu_args.h"
7033 !----------------------------------------------------------------------------
7035 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
7036 ! (high key - o3; high minor - co2, n2o)
7037 !----------------------------------------------------------------------------
7039 ! ------- Modules -------
7041 ! use parrrtm_f, only : ng8, ngs7
7042 use parrrtm_f, only : ngs7
7043 use rrlw_ref_f, only : chi_mlsd
7046 ! ------- Declarations -------
7047 #include "taug_cpu_defs.h"
7050 real _gpudev :: taug(:,:,:)
7051 real _gpudev :: fracsd(:,:,:)
7053 integer :: lay, ind0, ind1, inds, indf, indm, ig
7054 real :: tauself, taufor, absco2, abso3, absn2o
7055 real :: chi_co2, ratco2, adjfac, adjcolco2
7056 integer , value, intent(in) :: ncol, nlayers
7060 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7061 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7062 if (iplon <= ncol .and. lay <= nlayers) then
7067 ! Minor gas mapping level:
7068 ! lower - co2, p = 1053.63 mb, t = 294.2 k
7069 ! lower - o3, p = 317.348 mb, t = 240.77 k
7070 ! lower - n2o, p = 706.2720 mb, t= 278.94 k
7071 ! lower - cfc12,cfc11
7072 ! upper - co2, p = 35.1632 mb, t = 223.28 k
7073 ! upper - n2o, p = 8.716e-2 mb, t = 226.03 k
7075 ! Compute the optical depth by interpolating in ln(pressure) and
7076 ! temperature, and appropriate species. Below laytrop, the water vapor
7077 ! self-continuum and foreign continuum is interpolated (in temperature)
7080 ! Lower atmosphere loop
7081 if (lay <= laytrop(iplon)) then
7083 ! In atmospheres where the amount of CO2 is too great to be considered
7084 ! a minor species, adjust the column amount of CO2 by an empirical factor
7085 ! to obtain the proper contribution.
7086 chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay))
7087 ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1)
7088 if (ratco2 .gt. 3.0 ) then
7089 adjfac = 2.0 +(ratco2-2.0 )**0.65
7090 adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
7092 adjcolco2 = colco2(iplon,lay)
7095 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(8) + 1
7096 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(8) + 1
7097 inds = indself(iplon,lay)
7098 indf = indfor(iplon,lay)
7099 indm = indminor(iplon,lay)
7102 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
7103 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
7104 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7105 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7106 absco2 = (ka_mco2d(indm,ig) + minorfrac(iplon,lay) * &
7107 (ka_mco2d(indm+1,ig) - ka_mco2d(indm,ig)))
7108 abso3 = (ka_mo3d(indm,ig) + minorfrac(iplon,lay) * &
7109 (ka_mo3d(indm+1,ig) - ka_mo3d(indm,ig)))
7110 absn2o = (ka_mn2od(indm,ig) + minorfrac(iplon,lay) * &
7111 (ka_mn2od(indm+1,ig) - ka_mn2od(indm,ig)))
7112 taug(iplon,lay,ngs7+ig) = colh2o(iplon,lay) * &
7113 (fac00(iplon,lay) * absad(ind0,ig) + &
7114 fac10(iplon,lay) * absad(ind0+1,ig) + &
7115 fac01(iplon,lay) * absad(ind1,ig) + &
7116 fac11(iplon,lay) * absad(ind1+1,ig)) &
7117 + tauself + taufor &
7118 + adjcolco2*absco2 &
7119 + colo3(iplon,lay) * abso3 &
7120 + coln2o(iplon,lay) * absn2o &
7121 + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) &
7122 + wx4(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc22adjd(ig)
7123 fracsd(iplon,lay,ngs7+ig) = fracrefad(ig)
7126 ! In atmospheres where the amount of CO2 is too great to be considered
7127 ! a minor species, adjust the column amount of CO2 by an empirical factor
7128 ! to obtain the proper contribution.
7129 chi_co2 = colco2(iplon,lay)/coldry(iplon,lay)
7130 ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1)
7131 if (ratco2 .gt. 3.0 ) then
7132 adjfac = 2.0 +(ratco2-2.0 )**0.65
7133 adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1) * coldry(iplon,lay)*1.e-20
7135 adjcolco2 = colco2(iplon,lay)
7138 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(8) + 1
7139 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(8) + 1
7140 indm = indminor(iplon,lay)
7143 absco2 = (kb_mco2d(indm,ig) + minorfrac(iplon,lay) * &
7144 (kb_mco2d(indm+1,ig) - kb_mco2d(indm,ig)))
7145 absn2o = (kb_mn2od(indm,ig) + minorfrac(iplon,lay) * &
7146 (kb_mn2od(indm+1,ig) - kb_mn2od(indm,ig)))
7147 taug(iplon,lay,ngs7+ig) = colo3(iplon,lay) * &
7148 (fac00(iplon,lay) * absbd(ind0,ig) + &
7149 fac10(iplon,lay) * absbd(ind0+1,ig) + &
7150 fac01(iplon,lay) * absbd(ind1,ig) + &
7151 fac11(iplon,lay) * absbd(ind1+1,ig)) &
7152 + adjcolco2*absco2 &
7153 + coln2o(iplon,lay)*absn2o &
7154 + wx3(iplon,lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) &
7155 + wx4(iplon,lay) * coldry(iplon,lay) * 1.e-20 * cfc22adjd(ig)
7156 fracsd(iplon,lay,ngs7+ig) = fracrefbd(ig)
7167 end subroutine taugb8g
7169 !----------------------------------------------------------------------------
7170 _gpuker subroutine taugb9g( ncol, nlayers, taug, fracsd &
7171 #include "taug_cpu_args.h"
7173 !----------------------------------------------------------------------------
7175 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
7176 ! (high key - ch4; high minor - n2o)
7177 !----------------------------------------------------------------------------
7179 ! ------- Modules -------
7181 ! use parrrtm_f, only : ng9, ngs8
7182 use parrrtm_f, only : ngs8
7183 use rrlw_ref_f, only : chi_mlsd
7186 ! ------- Declarations -------
7187 real _gpudev :: taug(:,:,:)
7188 real _gpudev :: fracsd(:,:,:)
7189 #include "taug_cpu_defs.h"
7192 integer :: lay, ind0, ind1, inds, indf, indm, ig
7193 integer :: js, js1, jmn2o, jpl
7194 real :: speccomb, specparm, specmult, fs
7195 real :: speccomb1, specparm1, specmult1, fs1
7196 real :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o
7197 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
7198 real :: p, p4, fk0, fk1, fk2
7199 real :: fac000, fac100, fac200, fac010, fac110, fac210
7200 real :: fac001, fac101, fac201, fac011, fac111, fac211
7201 real :: tauself, taufor, n2om1, n2om2, absn2o
7202 real :: chi_n2o, ratn2o, adjfac, adjcoln2o
7203 real :: refrat_planck_a, refrat_m_a
7204 real :: tau_major, tau_major1
7205 integer , value, intent(in) :: ncol, nlayers
7209 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7210 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7211 if (iplon <= ncol .and. lay <= nlayers) then
7216 ! Minor gas mapping level :
7217 ! lower - n2o, p = 706.272 mbar, t = 278.94 k
7218 ! upper - n2o, p = 95.58 mbar, t = 215.7 k
7220 ! Calculate reference ratio to be used in calculation of Planck
7221 ! fraction in lower/upper atmosphere.
7224 refrat_planck_a = chi_mlsd(1,9)/chi_mlsd(6,9)
7227 refrat_m_a = chi_mlsd(1,3)/chi_mlsd(6,3)
7229 ! Compute the optical depth by interpolating in ln(pressure),
7230 ! temperature, and appropriate species. Below laytrop, the water
7231 ! vapor self-continuum and foreign continuum is interpolated
7232 ! (in temperature) separately.
7234 ! Lower atmosphere loop
7235 if (lay <= laytrop(iplon)) then
7237 speccomb = colh2o(iplon,lay) + rat_h2och4(iplon,lay)*colch4(iplon,lay)
7238 specparm = colh2o(iplon,lay)/speccomb
7239 if (specparm .ge. oneminusd) specparm = oneminusd
7240 specmult = 8. *(specparm)
7241 js = 1 + int(specmult)
7242 fs = mod(specmult,1.0 )
7244 speccomb1 = colh2o(iplon,lay) + rat_h2och4_1(iplon,lay)*colch4(iplon,lay)
7245 specparm1 = colh2o(iplon,lay)/speccomb1
7246 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
7247 specmult1 = 8. *(specparm1)
7248 js1 = 1 + int(specmult1)
7249 fs1 = mod(specmult1,1.0 )
7251 speccomb_mn2o = colh2o(iplon,lay) + refrat_m_a*colch4(iplon,lay)
7252 specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o
7253 if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd
7254 specmult_mn2o = 8. *specparm_mn2o
7255 jmn2o = 1 + int(specmult_mn2o)
7256 fmn2o = mod(specmult_mn2o,1.0 )
7258 ! In atmospheres where the amount of N2O is too great to be considered
7259 ! a minor species, adjust the column amount of N2O by an empirical factor
7260 ! to obtain the proper contribution.
7261 chi_n2o = coln2o(iplon,lay)/(coldry(iplon,lay))
7262 ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1)
7263 if (ratn2o .gt. 1.5 ) then
7264 adjfac = 0.5 +(ratn2o-0.5 )**0.65
7265 adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
7267 adjcoln2o = coln2o(iplon,lay)
7270 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colch4(iplon,lay)
7271 specparm_planck = colh2o(iplon,lay)/speccomb_planck
7272 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
7273 specmult_planck = 8. *specparm_planck
7274 jpl= 1 + int(specmult_planck)
7275 fpl = mod(specmult_planck,1.0 )
7277 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(9) + js
7278 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(9) + js1
7279 inds = indself(iplon,lay)
7280 indf = indfor(iplon,lay)
7281 indm = indminor(iplon,lay)
7283 if (specparm .lt. 0.125 ) then
7287 fk1 = 1 - p - 2.0 *p4
7289 fac000 = fk0*fac00(iplon,lay)
7290 fac100 = fk1*fac00(iplon,lay)
7291 fac200 = fk2*fac00(iplon,lay)
7292 fac010 = fk0*fac10(iplon,lay)
7293 fac110 = fk1*fac10(iplon,lay)
7294 fac210 = fk2*fac10(iplon,lay)
7295 else if (specparm .gt. 0.875 ) then
7299 fk1 = 1 - p - 2.0 *p4
7301 fac000 = fk0*fac00(iplon,lay)
7302 fac100 = fk1*fac00(iplon,lay)
7303 fac200 = fk2*fac00(iplon,lay)
7304 fac010 = fk0*fac10(iplon,lay)
7305 fac110 = fk1*fac10(iplon,lay)
7306 fac210 = fk2*fac10(iplon,lay)
7308 fac000 = (1. - fs) * fac00(iplon,lay)
7309 fac010 = (1. - fs) * fac10(iplon,lay)
7310 fac100 = fs * fac00(iplon,lay)
7311 fac110 = fs * fac10(iplon,lay)
7314 if (specparm1 .lt. 0.125 ) then
7318 fk1 = 1 - p - 2.0 *p4
7320 fac001 = fk0*fac01(iplon,lay)
7321 fac101 = fk1*fac01(iplon,lay)
7322 fac201 = fk2*fac01(iplon,lay)
7323 fac011 = fk0*fac11(iplon,lay)
7324 fac111 = fk1*fac11(iplon,lay)
7325 fac211 = fk2*fac11(iplon,lay)
7326 else if (specparm1 .gt. 0.875 ) then
7330 fk1 = 1 - p - 2.0 *p4
7332 fac001 = fk0*fac01(iplon,lay)
7333 fac101 = fk1*fac01(iplon,lay)
7334 fac201 = fk2*fac01(iplon,lay)
7335 fac011 = fk0*fac11(iplon,lay)
7336 fac111 = fk1*fac11(iplon,lay)
7337 fac211 = fk2*fac11(iplon,lay)
7339 fac001 = (1. - fs1) * fac01(iplon,lay)
7340 fac011 = (1. - fs1) * fac11(iplon,lay)
7341 fac101 = fs1 * fac01(iplon,lay)
7342 fac111 = fs1 * fac11(iplon,lay)
7346 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
7347 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
7348 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7349 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7350 n2om1 = ka_mn2od(jmn2o,indm,ig) + fmn2o * &
7351 (ka_mn2od(jmn2o+1,indm,ig) - ka_mn2od(jmn2o,indm,ig))
7352 n2om2 = ka_mn2od(jmn2o,indm+1,ig) + fmn2o * &
7353 (ka_mn2od(jmn2o+1,indm+1,ig) - ka_mn2od(jmn2o,indm+1,ig))
7354 absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1)
7356 if (specparm .lt. 0.125 ) then
7357 tau_major = speccomb * &
7358 (fac000 * absad(ind0,ig) + &
7359 fac100 * absad(ind0+1,ig) + &
7360 fac200 * absad(ind0+2,ig) + &
7361 fac010 * absad(ind0+9,ig) + &
7362 fac110 * absad(ind0+10,ig) + &
7363 fac210 * absad(ind0+11,ig))
7364 else if (specparm .gt. 0.875 ) then
7365 tau_major = speccomb * &
7366 (fac200 * absad(ind0-1,ig) + &
7367 fac100 * absad(ind0,ig) + &
7368 fac000 * absad(ind0+1,ig) + &
7369 fac210 * absad(ind0+8,ig) + &
7370 fac110 * absad(ind0+9,ig) + &
7371 fac010 * absad(ind0+10,ig))
7373 tau_major = speccomb * &
7374 (fac000 * absad(ind0,ig) + &
7375 fac100 * absad(ind0+1,ig) + &
7376 fac010 * absad(ind0+9,ig) + &
7377 fac110 * absad(ind0+10,ig))
7380 if (specparm1 .lt. 0.125 ) then
7381 tau_major1 = speccomb1 * &
7382 (fac001 * absad(ind1,ig) + &
7383 fac101 * absad(ind1+1,ig) + &
7384 fac201 * absad(ind1+2,ig) + &
7385 fac011 * absad(ind1+9,ig) + &
7386 fac111 * absad(ind1+10,ig) + &
7387 fac211 * absad(ind1+11,ig))
7388 else if (specparm1 .gt. 0.875 ) then
7389 tau_major1 = speccomb1 * &
7390 (fac201 * absad(ind1-1,ig) + &
7391 fac101 * absad(ind1,ig) + &
7392 fac001 * absad(ind1+1,ig) + &
7393 fac211 * absad(ind1+8,ig) + &
7394 fac111 * absad(ind1+9,ig) + &
7395 fac011 * absad(ind1+10,ig))
7397 tau_major1 = speccomb1 * &
7398 (fac001 * absad(ind1,ig) + &
7399 fac101 * absad(ind1+1,ig) + &
7400 fac011 * absad(ind1+9,ig) + &
7401 fac111 * absad(ind1+10,ig))
7404 taug(iplon,lay,ngs8+ig) = tau_major + tau_major1 &
7405 + tauself + taufor &
7407 fracsd(iplon,lay,ngs8+ig) = fracrefad(ig,jpl) + fpl * &
7408 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
7411 ! In atmospheres where the amount of N2O is too great to be considered
7412 ! a minor species, adjust the column amount of N2O by an empirical factor
7413 ! to obtain the proper contribution.
7414 chi_n2o = coln2o(iplon,lay)/(coldry(iplon,lay))
7415 ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1)
7416 if (ratn2o .gt. 1.5 ) then
7417 adjfac = 0.5 +(ratn2o-0.5 )**0.65
7418 adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20
7420 adjcoln2o = coln2o(iplon,lay)
7423 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(9) + 1
7424 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(9) + 1
7425 indm = indminor(iplon,lay)
7428 absn2o = kb_mn2od(indm,ig) + minorfrac(iplon,lay) * &
7429 (kb_mn2od(indm+1,ig) - kb_mn2od(indm,ig))
7430 taug(iplon,lay,ngs8+ig) = colch4(iplon,lay) * &
7431 (fac00(iplon,lay) * absbd(ind0,ig) + &
7432 fac10(iplon,lay) * absbd(ind0+1,ig) + &
7433 fac01(iplon,lay) * absbd(ind1,ig) + &
7434 fac11(iplon,lay) * absbd(ind1+1,ig)) &
7436 fracsd(iplon,lay,ngs8+ig) = fracrefbd(ig)
7447 end subroutine taugb9g
7449 !----------------------------------------------------------------------------
7450 _gpuker subroutine taugb10g( ncol, nlayers, taug, fracsd &
7451 #include "taug_cpu_args.h"
7453 !----------------------------------------------------------------------------
7455 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
7456 !----------------------------------------------------------------------------
7458 ! ------- Modules -------
7460 ! use parrrtm_f, only : ng10, ngs9
7461 use parrrtm_f, only : ngs9
7464 ! ------- Declarations -------
7465 real _gpudev :: taug(:,:,:)
7466 real _gpudev :: fracsd(:,:,:)
7467 #include "taug_cpu_defs.h"
7470 integer :: lay, ind0, ind1, inds, indf, ig
7471 real :: tauself, taufor
7472 integer , value, intent(in) :: ncol, nlayers
7476 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7477 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7478 if (iplon <= ncol .and. lay <= nlayers) then
7483 ! Compute the optical depth by interpolating in ln(pressure) and
7484 ! temperature. Below laytrop, the water vapor self-continuum and
7485 ! foreign continuum is interpolated (in temperature) separately.
7487 ! Lower atmosphere loop
7488 if (lay <= laytrop(iplon)) then
7489 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(10) + 1
7490 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(10) + 1
7491 inds = indself(iplon,lay)
7492 indf = indfor(iplon,lay)
7495 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
7496 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
7497 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7498 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7499 taug(iplon,lay,ngs9+ig) = colh2o(iplon,lay) * &
7500 (fac00(iplon,lay) * absad(ind0,ig) + &
7501 fac10(iplon,lay) * absad(ind0+1,ig) + &
7502 fac01(iplon,lay) * absad(ind1,ig) + &
7503 fac11(iplon,lay) * absad(ind1+1,ig)) &
7505 fracsd(iplon,lay,ngs9+ig) = fracrefad(ig)
7509 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(10) + 1
7510 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(10) + 1
7511 indf = indfor(iplon,lay)
7514 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7515 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7516 taug(iplon,lay,ngs9+ig) = colh2o(iplon,lay) * &
7517 (fac00(iplon,lay) * absbd(ind0,ig) + &
7518 fac10(iplon,lay) * absbd(ind0+1,ig) + &
7519 fac01(iplon,lay) * absbd(ind1,ig) + &
7520 fac11(iplon,lay) * absbd(ind1+1,ig)) &
7522 fracsd(iplon,lay,ngs9+ig) = fracrefbd(ig)
7532 end subroutine taugb10g
7534 !----------------------------------------------------------------------------
7535 _gpuker subroutine taugb11g( ncol, nlayers, taug, fracsd &
7536 #include "taug_cpu_args.h"
7538 !----------------------------------------------------------------------------
7540 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
7541 ! (high key - h2o; high minor - o2)
7542 !----------------------------------------------------------------------------
7544 ! ------- Modules -------
7546 ! use parrrtm_f, only : ng11, ngs10
7547 use parrrtm_f, only : ngs10
7550 ! ------- Declarations -------
7551 real _gpudev :: taug(:,:,:)
7552 real _gpudev :: fracsd(:,:,:)
7553 #include "taug_cpu_defs.h"
7556 integer :: lay, ind0, ind1, inds, indf, indm, ig
7557 real :: scaleo2, tauself, taufor, tauo2
7558 integer , value, intent(in) :: ncol, nlayers
7562 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7563 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7564 if (iplon <= ncol .and. lay <= nlayers) then
7569 ! Minor gas mapping level :
7570 ! lower - o2, p = 706.2720 mbar, t = 278.94 k
7571 ! upper - o2, p = 4.758820 mbarm t = 250.85 k
7573 ! Compute the optical depth by interpolating in ln(pressure) and
7574 ! temperature. Below laytrop, the water vapor self-continuum and
7575 ! foreign continuum is interpolated (in temperature) separately.
7577 ! Lower atmosphere loop
7578 if (lay <= laytrop(iplon)) then
7579 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(11) + 1
7580 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(11) + 1
7581 inds = indself(iplon,lay)
7582 indf = indfor(iplon,lay)
7583 indm = indminor(iplon,lay)
7584 scaleo2 = colo2(iplon,lay)*scaleminor(iplon,lay)
7586 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
7587 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
7588 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7589 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7590 tauo2 = scaleo2 * (ka_mo2d(indm,ig) + minorfrac(iplon,lay) * &
7591 (ka_mo2d(indm+1,ig) - ka_mo2d(indm,ig)))
7592 taug(iplon,lay,ngs10+ig) = colh2o(iplon,lay) * &
7593 (fac00(iplon,lay) * absad(ind0,ig) + &
7594 fac10(iplon,lay) * absad(ind0+1,ig) + &
7595 fac01(iplon,lay) * absad(ind1,ig) + &
7596 fac11(iplon,lay) * absad(ind1+1,ig)) &
7597 + tauself + taufor &
7599 fracsd(iplon,lay,ngs10+ig) = fracrefad(ig)
7602 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(11) + 1
7603 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(11) + 1
7604 indf = indfor(iplon,lay)
7605 indm = indminor(iplon,lay)
7606 scaleo2 = colo2(iplon,lay)*scaleminor(iplon,lay)
7608 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7609 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7610 tauo2 = scaleo2 * (kb_mo2d(indm,ig) + minorfrac(iplon,lay) * &
7611 (kb_mo2d(indm+1,ig) - kb_mo2d(indm,ig)))
7612 taug(iplon,lay,ngs10+ig) = colh2o(iplon,lay) * &
7613 (fac00(iplon,lay) * absbd(ind0,ig) + &
7614 fac10(iplon,lay) * absbd(ind0+1,ig) + &
7615 fac01(iplon,lay) * absbd(ind1,ig) + &
7616 fac11(iplon,lay) * absbd(ind1+1,ig)) &
7619 fracsd(iplon,lay,ngs10+ig) = fracrefbd(ig)
7630 end subroutine taugb11g
7632 !----------------------------------------------------------------------------
7633 _gpuker subroutine taugb12g( ncol, nlayers, taug, fracsd &
7634 #include "taug_cpu_args.h"
7636 !----------------------------------------------------------------------------
7638 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
7639 !----------------------------------------------------------------------------
7641 ! ------- Modules -------
7643 ! use parrrtm_f, only : ng12, ngs11
7644 use parrrtm_f, only : ngs11
7645 use rrlw_ref_f, only : chi_mlsd
7648 ! ------- Declarations -------
7649 real _gpudev :: taug(:,:,:)
7650 real _gpudev :: fracsd(:,:,:)
7651 #include "taug_cpu_defs.h"
7654 integer :: lay, ind0, ind1, inds, indf, ig
7655 integer :: js, js1, jpl
7656 real :: speccomb, specparm, specmult, fs
7657 real :: speccomb1, specparm1, specmult1, fs1
7658 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
7659 real :: p, p4, fk0, fk1, fk2
7660 real :: fac000, fac100, fac200, fac010, fac110, fac210
7661 real :: fac001, fac101, fac201, fac011, fac111, fac211
7662 real :: tauself, taufor
7663 real :: refrat_planck_a
7664 real :: tau_major, tau_major1
7665 integer , value, intent(in) :: ncol, nlayers
7669 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7670 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7671 if (iplon <= ncol .and. lay <= nlayers) then
7676 ! Calculate reference ratio to be used in calculation of Planck
7677 ! fraction in lower/upper atmosphere.
7680 refrat_planck_a = chi_mlsd(1,10)/chi_mlsd(2,10)
7682 ! Compute the optical depth by interpolating in ln(pressure),
7683 ! temperature, and appropriate species. Below laytrop, the water
7684 ! vapor self-continuum adn foreign continuum is interpolated
7685 ! (in temperature) separately.
7687 ! Lower atmosphere loop
7688 if (lay <= laytrop(iplon)) then
7690 speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay)
7691 specparm = colh2o(iplon,lay)/speccomb
7692 if (specparm .ge. oneminusd) specparm = oneminusd
7693 specmult = 8. *(specparm)
7694 js = 1 + int(specmult)
7695 fs = mod(specmult,1.0 )
7697 speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay)
7698 specparm1 = colh2o(iplon,lay)/speccomb1
7699 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
7700 specmult1 = 8. *(specparm1)
7701 js1 = 1 + int(specmult1)
7702 fs1 = mod(specmult1,1.0 )
7704 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay)
7705 specparm_planck = colh2o(iplon,lay)/speccomb_planck
7706 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
7707 specmult_planck = 8. *specparm_planck
7708 jpl= 1 + int(specmult_planck)
7709 fpl = mod(specmult_planck,1.0 )
7711 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(12) + js
7712 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(12) + js1
7713 inds = indself(iplon,lay)
7714 indf = indfor(iplon,lay)
7716 if (specparm .lt. 0.125 ) then
7720 fk1 = 1 - p - 2.0 *p4
7722 fac000 = fk0*fac00(iplon,lay)
7723 fac100 = fk1*fac00(iplon,lay)
7724 fac200 = fk2*fac00(iplon,lay)
7725 fac010 = fk0*fac10(iplon,lay)
7726 fac110 = fk1*fac10(iplon,lay)
7727 fac210 = fk2*fac10(iplon,lay)
7728 else if (specparm .gt. 0.875 ) then
7732 fk1 = 1 - p - 2.0 *p4
7734 fac000 = fk0*fac00(iplon,lay)
7735 fac100 = fk1*fac00(iplon,lay)
7736 fac200 = fk2*fac00(iplon,lay)
7737 fac010 = fk0*fac10(iplon,lay)
7738 fac110 = fk1*fac10(iplon,lay)
7739 fac210 = fk2*fac10(iplon,lay)
7741 fac000 = (1. - fs) * fac00(iplon,lay)
7742 fac010 = (1. - fs) * fac10(iplon,lay)
7743 fac100 = fs * fac00(iplon,lay)
7744 fac110 = fs * fac10(iplon,lay)
7747 if (specparm1 .lt. 0.125 ) then
7751 fk1 = 1 - p - 2.0 *p4
7753 fac001 = fk0*fac01(iplon,lay)
7754 fac101 = fk1*fac01(iplon,lay)
7755 fac201 = fk2*fac01(iplon,lay)
7756 fac011 = fk0*fac11(iplon,lay)
7757 fac111 = fk1*fac11(iplon,lay)
7758 fac211 = fk2*fac11(iplon,lay)
7759 else if (specparm1 .gt. 0.875 ) then
7763 fk1 = 1 - p - 2.0 *p4
7765 fac001 = fk0*fac01(iplon,lay)
7766 fac101 = fk1*fac01(iplon,lay)
7767 fac201 = fk2*fac01(iplon,lay)
7768 fac011 = fk0*fac11(iplon,lay)
7769 fac111 = fk1*fac11(iplon,lay)
7770 fac211 = fk2*fac11(iplon,lay)
7772 fac001 = (1. - fs1) * fac01(iplon,lay)
7773 fac011 = (1. - fs1) * fac11(iplon,lay)
7774 fac101 = fs1 * fac01(iplon,lay)
7775 fac111 = fs1 * fac11(iplon,lay)
7779 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
7780 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
7781 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
7782 (forrefd(indf+1,ig) - forrefd(indf,ig)))
7784 if (specparm .lt. 0.125 ) then
7785 tau_major = speccomb * &
7786 (fac000 * absad(ind0,ig) + &
7787 fac100 * absad(ind0+1,ig) + &
7788 fac200 * absad(ind0+2,ig) + &
7789 fac010 * absad(ind0+9,ig) + &
7790 fac110 * absad(ind0+10,ig) + &
7791 fac210 * absad(ind0+11,ig))
7792 else if (specparm .gt. 0.875 ) then
7793 tau_major = speccomb * &
7794 (fac200 * absad(ind0-1,ig) + &
7795 fac100 * absad(ind0,ig) + &
7796 fac000 * absad(ind0+1,ig) + &
7797 fac210 * absad(ind0+8,ig) + &
7798 fac110 * absad(ind0+9,ig) + &
7799 fac010 * absad(ind0+10,ig))
7801 tau_major = speccomb * &
7802 (fac000 * absad(ind0,ig) + &
7803 fac100 * absad(ind0+1,ig) + &
7804 fac010 * absad(ind0+9,ig) + &
7805 fac110 * absad(ind0+10,ig))
7808 if (specparm1 .lt. 0.125 ) then
7809 tau_major1 = speccomb1 * &
7810 (fac001 * absad(ind1,ig) + &
7811 fac101 * absad(ind1+1,ig) + &
7812 fac201 * absad(ind1+2,ig) + &
7813 fac011 * absad(ind1+9,ig) + &
7814 fac111 * absad(ind1+10,ig) + &
7815 fac211 * absad(ind1+11,ig))
7816 else if (specparm1 .gt. 0.875 ) then
7817 tau_major1 = speccomb1 * &
7818 (fac201 * absad(ind1-1,ig) + &
7819 fac101 * absad(ind1,ig) + &
7820 fac001 * absad(ind1+1,ig) + &
7821 fac211 * absad(ind1+8,ig) + &
7822 fac111 * absad(ind1+9,ig) + &
7823 fac011 * absad(ind1+10,ig))
7825 tau_major1 = speccomb1 * &
7826 (fac001 * absad(ind1,ig) + &
7827 fac101 * absad(ind1+1,ig) + &
7828 fac011 * absad(ind1+9,ig) + &
7829 fac111 * absad(ind1+10,ig))
7832 taug(iplon,lay,ngs11+ig) = tau_major + tau_major1 &
7834 fracsd(iplon,lay,ngs11+ig) = fracrefad(ig,jpl) + fpl * &
7835 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
7840 taug(iplon,lay,ngs11+ig) = 0.0
7841 fracsd(iplon,lay,ngs11+ig) = 0.0
7852 end subroutine taugb12g
7854 !----------------------------------------------------------------------------
7855 _gpuker subroutine taugb13g( ncol, nlayers, taug, fracsd &
7856 #include "taug_cpu_args.h"
7858 !----------------------------------------------------------------------------
7860 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
7861 !----------------------------------------------------------------------------
7863 ! ------- Modules -------
7865 ! use parrrtm_f, only : ng13, ngs12
7866 use parrrtm_f, only : ngs12
7867 use rrlw_ref_f, only : chi_mlsd
7869 ! ------- Declarations -------
7870 real _gpudev :: taug(:,:,:)
7871 real _gpudev :: fracsd(:,:,:)
7872 #include "taug_cpu_defs.h"
7875 integer :: lay, ind0, ind1, inds, indf, indm, ig
7876 integer :: js, js1, jmco2, jmco, jpl
7877 real :: speccomb, specparm, specmult, fs
7878 real :: speccomb1, specparm1, specmult1, fs1
7879 real :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2
7880 real :: speccomb_mco, specparm_mco, specmult_mco, fmco
7881 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
7882 real :: p, p4, fk0, fk1, fk2
7883 real :: fac000, fac100, fac200, fac010, fac110, fac210
7884 real :: fac001, fac101, fac201, fac011, fac111, fac211
7885 real :: tauself, taufor, co2m1, co2m2, absco2
7886 real :: com1, com2, absco, abso3
7887 real :: chi_co2, ratco2, adjfac, adjcolco2
7888 real :: refrat_planck_a, refrat_m_a, refrat_m_a3
7889 real :: tau_major, tau_major1
7890 integer , value, intent(in) :: ncol, nlayers
7894 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
7895 lay = (blockidx%y-1) * blockdim%y + threadidx%y
7896 if (iplon <= ncol .and. lay <= nlayers) then
7901 ! Minor gas mapping levels :
7902 ! lower - co2, p = 1053.63 mb, t = 294.2 k
7903 ! lower - co, p = 706 mb, t = 278.94 k
7904 ! upper - o3, p = 95.5835 mb, t = 215.7 k
7906 ! Calculate reference ratio to be used in calculation of Planck
7907 ! fraction in lower/upper atmosphere.
7909 ! P = 473.420 mb (Level 5)
7910 refrat_planck_a = chi_mlsd(1,5)/chi_mlsd(4,5)
7912 ! P = 1053. (Level 1)
7913 refrat_m_a = chi_mlsd(1,1)/chi_mlsd(4,1)
7915 ! P = 706. (Level 3)
7916 refrat_m_a3 = chi_mlsd(1,3)/chi_mlsd(4,3)
7918 ! Compute the optical depth by interpolating in ln(pressure),
7919 ! temperature, and appropriate species. Below laytrop, the water
7920 ! vapor self-continuum and foreign continuum is interpolated
7921 ! (in temperature) separately.
7923 ! Lower atmosphere loop
7924 if (lay <= laytrop(iplon)) then
7926 speccomb = colh2o(iplon,lay) + rat_h2on2o(iplon,lay)*coln2o(iplon,lay)
7927 specparm = colh2o(iplon,lay)/speccomb
7928 if (specparm .ge. oneminusd) specparm = oneminusd
7929 specmult = 8. *(specparm)
7930 js = 1 + int(specmult)
7931 fs = mod(specmult,1.0 )
7933 speccomb1 = colh2o(iplon,lay) + rat_h2on2o_1(iplon,lay)*coln2o(iplon,lay)
7934 specparm1 = colh2o(iplon,lay)/speccomb1
7935 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
7936 specmult1 = 8. *(specparm1)
7937 js1 = 1 + int(specmult1)
7938 fs1 = mod(specmult1,1.0 )
7940 speccomb_mco2 = colh2o(iplon,lay) + refrat_m_a*coln2o(iplon,lay)
7941 specparm_mco2 = colh2o(iplon,lay)/speccomb_mco2
7942 if (specparm_mco2 .ge. oneminusd) specparm_mco2 = oneminusd
7943 specmult_mco2 = 8. *specparm_mco2
7944 jmco2 = 1 + int(specmult_mco2)
7945 fmco2 = mod(specmult_mco2,1.0 )
7947 ! In atmospheres where the amount of CO2 is too great to be considered
7948 ! a minor species, adjust the column amount of CO2 by an empirical factor
7949 ! to obtain the proper contribution.
7950 chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay))
7951 ratco2 = 1.e20 *chi_co2/3.55e-4
7952 if (ratco2 .gt. 3.0 ) then
7953 adjfac = 2.0 +(ratco2-2.0 )**0.68
7954 adjcolco2 = adjfac*3.55e-4*coldry(iplon,lay)*1.e-20
7956 adjcolco2 = colco2(iplon,lay)
7959 speccomb_mco = colh2o(iplon,lay) + refrat_m_a3*coln2o(iplon,lay)
7960 specparm_mco = colh2o(iplon,lay)/speccomb_mco
7961 if (specparm_mco .ge. oneminusd) specparm_mco = oneminusd
7962 specmult_mco = 8. *specparm_mco
7963 jmco = 1 + int(specmult_mco)
7964 fmco = mod(specmult_mco,1.0 )
7966 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*coln2o(iplon,lay)
7967 specparm_planck = colh2o(iplon,lay)/speccomb_planck
7968 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
7969 specmult_planck = 8. *specparm_planck
7970 jpl= 1 + int(specmult_planck)
7971 fpl = mod(specmult_planck,1.0 )
7973 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(13) + js
7974 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(13) + js1
7975 inds = indself(iplon,lay)
7976 indf = indfor(iplon,lay)
7977 indm = indminor(iplon,lay)
7979 if (specparm .lt. 0.125 ) then
7983 fk1 = 1 - p - 2.0 *p4
7985 fac000 = fk0*fac00(iplon,lay)
7986 fac100 = fk1*fac00(iplon,lay)
7987 fac200 = fk2*fac00(iplon,lay)
7988 fac010 = fk0*fac10(iplon,lay)
7989 fac110 = fk1*fac10(iplon,lay)
7990 fac210 = fk2*fac10(iplon,lay)
7991 else if (specparm .gt. 0.875 ) then
7995 fk1 = 1 - p - 2.0 *p4
7997 fac000 = fk0*fac00(iplon,lay)
7998 fac100 = fk1*fac00(iplon,lay)
7999 fac200 = fk2*fac00(iplon,lay)
8000 fac010 = fk0*fac10(iplon,lay)
8001 fac110 = fk1*fac10(iplon,lay)
8002 fac210 = fk2*fac10(iplon,lay)
8004 fac000 = (1. - fs) * fac00(iplon,lay)
8005 fac010 = (1. - fs) * fac10(iplon,lay)
8006 fac100 = fs * fac00(iplon,lay)
8007 fac110 = fs * fac10(iplon,lay)
8010 if (specparm1 .lt. 0.125 ) then
8014 fk1 = 1 - p - 2.0 *p4
8016 fac001 = fk0*fac01(iplon,lay)
8017 fac101 = fk1*fac01(iplon,lay)
8018 fac201 = fk2*fac01(iplon,lay)
8019 fac011 = fk0*fac11(iplon,lay)
8020 fac111 = fk1*fac11(iplon,lay)
8021 fac211 = fk2*fac11(iplon,lay)
8022 else if (specparm1 .gt. 0.875 ) then
8026 fk1 = 1 - p - 2.0 *p4
8028 fac001 = fk0*fac01(iplon,lay)
8029 fac101 = fk1*fac01(iplon,lay)
8030 fac201 = fk2*fac01(iplon,lay)
8031 fac011 = fk0*fac11(iplon,lay)
8032 fac111 = fk1*fac11(iplon,lay)
8033 fac211 = fk2*fac11(iplon,lay)
8035 fac001 = (1. - fs1) * fac01(iplon,lay)
8036 fac011 = (1. - fs1) * fac11(iplon,lay)
8037 fac101 = fs1 * fac01(iplon,lay)
8038 fac111 = fs1 * fac11(iplon,lay)
8042 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
8043 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
8044 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
8045 (forrefd(indf+1,ig) - forrefd(indf,ig)))
8046 co2m1 = ka_mco2d(jmco2,indm,ig) + fmco2 * &
8047 (ka_mco2d(jmco2+1,indm,ig) - ka_mco2d(jmco2,indm,ig))
8048 co2m2 = ka_mco2d(jmco2,indm+1,ig) + fmco2 * &
8049 (ka_mco2d(jmco2+1,indm+1,ig) - ka_mco2d(jmco2,indm+1,ig))
8050 absco2 = co2m1 + minorfrac(iplon,lay) * (co2m2 - co2m1)
8051 com1 = ka_mcod(jmco,indm,ig) + fmco * &
8052 (ka_mcod(jmco+1,indm,ig) - ka_mcod(jmco,indm,ig))
8053 com2 = ka_mcod(jmco,indm+1,ig) + fmco * &
8054 (ka_mcod(jmco+1,indm+1,ig) - ka_mcod(jmco,indm+1,ig))
8055 absco = com1 + minorfrac(iplon,lay) * (com2 - com1)
8057 if (specparm .lt. 0.125 ) then
8058 tau_major = speccomb * &
8059 (fac000 * absad(ind0,ig) + &
8060 fac100 * absad(ind0+1,ig) + &
8061 fac200 * absad(ind0+2,ig) + &
8062 fac010 * absad(ind0+9,ig) + &
8063 fac110 * absad(ind0+10,ig) + &
8064 fac210 * absad(ind0+11,ig))
8065 else if (specparm .gt. 0.875 ) then
8066 tau_major = speccomb * &
8067 (fac200 * absad(ind0-1,ig) + &
8068 fac100 * absad(ind0,ig) + &
8069 fac000 * absad(ind0+1,ig) + &
8070 fac210 * absad(ind0+8,ig) + &
8071 fac110 * absad(ind0+9,ig) + &
8072 fac010 * absad(ind0+10,ig))
8074 tau_major = speccomb * &
8075 (fac000 * absad(ind0,ig) + &
8076 fac100 * absad(ind0+1,ig) + &
8077 fac010 * absad(ind0+9,ig) + &
8078 fac110 * absad(ind0+10,ig))
8081 if (specparm1 .lt. 0.125 ) then
8082 tau_major1 = speccomb1 * &
8083 (fac001 * absad(ind1,ig) + &
8084 fac101 * absad(ind1+1,ig) + &
8085 fac201 * absad(ind1+2,ig) + &
8086 fac011 * absad(ind1+9,ig) + &
8087 fac111 * absad(ind1+10,ig) + &
8088 fac211 * absad(ind1+11,ig))
8089 else if (specparm1 .gt. 0.875 ) then
8090 tau_major1 = speccomb1 * &
8091 (fac201 * absad(ind1-1,ig) + &
8092 fac101 * absad(ind1,ig) + &
8093 fac001 * absad(ind1+1,ig) + &
8094 fac211 * absad(ind1+8,ig) + &
8095 fac111 * absad(ind1+9,ig) + &
8096 fac011 * absad(ind1+10,ig))
8098 tau_major1 = speccomb1 * &
8099 (fac001 * absad(ind1,ig) + &
8100 fac101 * absad(ind1+1,ig) + &
8101 fac011 * absad(ind1+9,ig) + &
8102 fac111 * absad(ind1+10,ig))
8105 taug(iplon,lay,ngs12+ig) = tau_major + tau_major1 &
8106 + tauself + taufor &
8107 + adjcolco2*absco2 &
8108 + colco(iplon,lay)*absco
8109 fracsd(iplon,lay,ngs12+ig) = fracrefad(ig,jpl) + fpl * &
8110 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
8113 indm = indminor(iplon,lay)
8115 abso3 = kb_mo3d(indm,ig) + minorfrac(iplon,lay) * &
8116 (kb_mo3d(indm+1,ig) - kb_mo3d(indm,ig))
8117 taug(iplon,lay,ngs12+ig) = colo3(iplon,lay)*abso3
8118 fracsd(iplon,lay,ngs12+ig) = fracrefbd(ig)
8129 end subroutine taugb13g
8131 !----------------------------------------------------------------------------
8132 _gpuker subroutine taugb14g( ncol, nlayers , taug, fracsd &
8133 #include "taug_cpu_args.h"
8135 !----------------------------------------------------------------------------
8137 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
8138 !----------------------------------------------------------------------------
8140 ! ------- Modules -------
8142 ! use parrrtm_f, only : ng14, ngs13
8143 use parrrtm_f, only : ngs13
8146 ! ------- Declarations -------
8147 real _gpudev :: taug(:,:,:)
8148 real _gpudev :: fracsd(:,:,:)
8149 #include "taug_cpu_defs.h"
8152 integer :: lay, ind0, ind1, inds, indf, ig
8153 real :: tauself, taufor
8154 integer , value, intent(in) :: ncol, nlayers
8158 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
8159 lay = (blockidx%y-1) * blockdim%y + threadidx%y
8160 if (iplon <= ncol .and. lay <= nlayers) then
8165 ! Compute the optical depth by interpolating in ln(pressure) and
8166 ! temperature. Below laytrop, the water vapor self-continuum
8167 ! and foreign continuum is interpolated (in temperature) separately.
8169 ! Lower atmosphere loop
8170 if (lay <= laytrop(iplon)) then
8171 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(14) + 1
8172 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(14) + 1
8173 inds = indself(iplon,lay)
8174 indf = indfor(iplon,lay)
8176 tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * &
8177 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
8178 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
8179 (forrefd(indf+1,ig) - forrefd(indf,ig)))
8180 taug(iplon,lay,ngs13+ig) = colco2(iplon,lay) * &
8181 (fac00(iplon,lay) * absad(ind0,ig) + &
8182 fac10(iplon,lay) * absad(ind0+1,ig) + &
8183 fac01(iplon,lay) * absad(ind1,ig) + &
8184 fac11(iplon,lay) * absad(ind1+1,ig)) &
8186 fracsd(iplon,lay,ngs13+ig) = fracrefad(ig)
8189 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(14) + 1
8190 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(14) + 1
8192 taug(iplon,lay,ngs13+ig) = colco2(iplon,lay) * &
8193 (fac00(iplon,lay) * absbd(ind0,ig) + &
8194 fac10(iplon,lay) * absbd(ind0+1,ig) + &
8195 fac01(iplon,lay) * absbd(ind1,ig) + &
8196 fac11(iplon,lay) * absbd(ind1+1,ig))
8197 fracsd(iplon,lay,ngs13+ig) = fracrefbd(ig)
8208 end subroutine taugb14g
8210 !----------------------------------------------------------------------------
8211 _gpuker subroutine taugb15g( ncol, nlayers , taug, fracsd &
8212 #include "taug_cpu_args.h"
8214 !----------------------------------------------------------------------------
8216 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
8218 !----------------------------------------------------------------------------
8220 ! ------- Modules -------
8222 ! use parrrtm_f, only : ng15, ngs14
8223 use parrrtm_f, only : ngs14
8224 use rrlw_ref_f, only : chi_mlsd
8227 ! ------- Declarations -------
8228 real _gpudev :: taug(:,:,:)
8229 real _gpudev :: fracsd(:,:,:)
8230 #include "taug_cpu_defs.h"
8233 integer :: lay, ind0, ind1, inds, indf, indm, ig
8234 integer :: js, js1, jmn2, jpl
8235 real :: speccomb, specparm, specmult, fs
8236 real :: speccomb1, specparm1, specmult1, fs1
8237 real :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2
8238 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
8239 real :: p, p4, fk0, fk1, fk2
8240 real :: fac000, fac100, fac200, fac010, fac110, fac210
8241 real :: fac001, fac101, fac201, fac011, fac111, fac211
8242 real :: scalen2, tauself, taufor, n2m1, n2m2, taun2
8243 real :: refrat_planck_a, refrat_m_a
8244 real :: tau_major, tau_major1
8245 integer , value, intent(in) :: ncol, nlayers
8249 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
8250 lay = (blockidx%y-1) * blockdim%y + threadidx%y
8251 if (iplon <= ncol .and. lay <= nlayers) then
8256 ! Minor gas mapping level :
8257 ! Lower - Nitrogen Continuum, P = 1053., T = 294.
8259 ! Calculate reference ratio to be used in calculation of Planck
8260 ! fraction in lower atmosphere.
8261 ! P = 1053. mb (Level 1)
8262 refrat_planck_a = chi_mlsd(4,1)/chi_mlsd(2,1)
8265 refrat_m_a = chi_mlsd(4,1)/chi_mlsd(2,1)
8267 ! Compute the optical depth by interpolating in ln(pressure),
8268 ! temperature, and appropriate species. Below laytrop, the water
8269 ! vapor self-continuum and foreign continuum is interpolated
8270 ! (in temperature) separately.
8272 ! Lower atmosphere loop
8273 if (lay <= laytrop(iplon)) then
8275 speccomb = coln2o(iplon,lay) + rat_n2oco2(iplon,lay)*colco2(iplon,lay)
8276 specparm = coln2o(iplon,lay)/speccomb
8277 if (specparm .ge. oneminusd) specparm = oneminusd
8278 specmult = 8. *(specparm)
8279 js = 1 + int(specmult)
8280 fs = mod(specmult,1.0 )
8282 speccomb1 = coln2o(iplon,lay) + rat_n2oco2_1(iplon,lay)*colco2(iplon,lay)
8283 specparm1 = coln2o(iplon,lay)/speccomb1
8284 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
8285 specmult1 = 8. *(specparm1)
8286 js1 = 1 + int(specmult1)
8287 fs1 = mod(specmult1,1.0 )
8289 speccomb_mn2 = coln2o(iplon,lay) + refrat_m_a*colco2(iplon,lay)
8290 specparm_mn2 = coln2o(iplon,lay)/speccomb_mn2
8291 if (specparm_mn2 .ge. oneminusd) specparm_mn2 = oneminusd
8292 specmult_mn2 = 8. *specparm_mn2
8293 jmn2 = 1 + int(specmult_mn2)
8294 fmn2 = mod(specmult_mn2,1.0 )
8296 speccomb_planck = coln2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay)
8297 specparm_planck = coln2o(iplon,lay)/speccomb_planck
8298 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
8299 specmult_planck = 8. *specparm_planck
8300 jpl= 1 + int(specmult_planck)
8301 fpl = mod(specmult_planck,1.0 )
8303 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(15) + js
8304 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(15) + js1
8305 inds = indself(iplon,lay)
8306 indf = indfor(iplon,lay)
8307 indm = indminor(iplon,lay)
8309 scalen2 = colbrd(iplon,lay)*scaleminor(iplon,lay)
8311 if (specparm .lt. 0.125 ) then
8315 fk1 = 1 - p - 2.0 *p4
8317 fac000 = fk0*fac00(iplon,lay)
8318 fac100 = fk1*fac00(iplon,lay)
8319 fac200 = fk2*fac00(iplon,lay)
8320 fac010 = fk0*fac10(iplon,lay)
8321 fac110 = fk1*fac10(iplon,lay)
8322 fac210 = fk2*fac10(iplon,lay)
8323 else if (specparm .gt. 0.875 ) then
8327 fk1 = 1 - p - 2.0 *p4
8329 fac000 = fk0*fac00(iplon,lay)
8330 fac100 = fk1*fac00(iplon,lay)
8331 fac200 = fk2*fac00(iplon,lay)
8332 fac010 = fk0*fac10(iplon,lay)
8333 fac110 = fk1*fac10(iplon,lay)
8334 fac210 = fk2*fac10(iplon,lay)
8336 fac000 = (1. - fs) * fac00(iplon,lay)
8337 fac010 = (1. - fs) * fac10(iplon,lay)
8338 fac100 = fs * fac00(iplon,lay)
8339 fac110 = fs * fac10(iplon,lay)
8341 if (specparm1 .lt. 0.125 ) then
8345 fk1 = 1 - p - 2.0 *p4
8347 fac001 = fk0*fac01(iplon,lay)
8348 fac101 = fk1*fac01(iplon,lay)
8349 fac201 = fk2*fac01(iplon,lay)
8350 fac011 = fk0*fac11(iplon,lay)
8351 fac111 = fk1*fac11(iplon,lay)
8352 fac211 = fk2*fac11(iplon,lay)
8353 else if (specparm1 .gt. 0.875 ) then
8357 fk1 = 1 - p - 2.0 *p4
8359 fac001 = fk0*fac01(iplon,lay)
8360 fac101 = fk1*fac01(iplon,lay)
8361 fac201 = fk2*fac01(iplon,lay)
8362 fac011 = fk0*fac11(iplon,lay)
8363 fac111 = fk1*fac11(iplon,lay)
8364 fac211 = fk2*fac11(iplon,lay)
8366 fac001 = (1. - fs1) * fac01(iplon,lay)
8367 fac011 = (1. - fs1) * fac11(iplon,lay)
8368 fac101 = fs1 * fac01(iplon,lay)
8369 fac111 = fs1 * fac11(iplon,lay)
8373 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
8374 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
8375 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
8376 (forrefd(indf+1,ig) - forrefd(indf,ig)))
8377 n2m1 = ka_mn2d(jmn2,indm,ig) + fmn2 * &
8378 (ka_mn2d(jmn2+1,indm,ig) - ka_mn2d(jmn2,indm,ig))
8379 n2m2 = ka_mn2d(jmn2,indm+1,ig) + fmn2 * &
8380 (ka_mn2d(jmn2+1,indm+1,ig) - ka_mn2d(jmn2,indm+1,ig))
8381 taun2 = scalen2 * (n2m1 + minorfrac(iplon,lay) * (n2m2 - n2m1))
8383 if (specparm .lt. 0.125 ) then
8384 tau_major = speccomb * &
8385 (fac000 * absad(ind0,ig) + &
8386 fac100 * absad(ind0+1,ig) + &
8387 fac200 * absad(ind0+2,ig) + &
8388 fac010 * absad(ind0+9,ig) + &
8389 fac110 * absad(ind0+10,ig) + &
8390 fac210 * absad(ind0+11,ig))
8391 else if (specparm .gt. 0.875 ) then
8392 tau_major = speccomb * &
8393 (fac200 * absad(ind0-1,ig) + &
8394 fac100 * absad(ind0,ig) + &
8395 fac000 * absad(ind0+1,ig) + &
8396 fac210 * absad(ind0+8,ig) + &
8397 fac110 * absad(ind0+9,ig) + &
8398 fac010 * absad(ind0+10,ig))
8400 tau_major = speccomb * &
8401 (fac000 * absad(ind0,ig) + &
8402 fac100 * absad(ind0+1,ig) + &
8403 fac010 * absad(ind0+9,ig) + &
8404 fac110 * absad(ind0+10,ig))
8407 if (specparm1 .lt. 0.125 ) then
8408 tau_major1 = speccomb1 * &
8409 (fac001 * absad(ind1,ig) + &
8410 fac101 * absad(ind1+1,ig) + &
8411 fac201 * absad(ind1+2,ig) + &
8412 fac011 * absad(ind1+9,ig) + &
8413 fac111 * absad(ind1+10,ig) + &
8414 fac211 * absad(ind1+11,ig))
8415 else if (specparm1 .gt. 0.875 ) then
8416 tau_major1 = speccomb1 * &
8417 (fac201 * absad(ind1-1,ig) + &
8418 fac101 * absad(ind1,ig) + &
8419 fac001 * absad(ind1+1,ig) + &
8420 fac211 * absad(ind1+8,ig) + &
8421 fac111 * absad(ind1+9,ig) + &
8422 fac011 * absad(ind1+10,ig))
8424 tau_major1 = speccomb1 * &
8425 (fac001 * absad(ind1,ig) + &
8426 fac101 * absad(ind1+1,ig) + &
8427 fac011 * absad(ind1+9,ig) + &
8428 fac111 * absad(ind1+10,ig))
8431 taug(iplon,lay,ngs14+ig) = tau_major + tau_major1 &
8432 + tauself + taufor &
8434 fracsd(iplon,lay,ngs14+ig) = fracrefad(ig,jpl) + fpl * &
8435 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
8440 taug(iplon,lay,ngs14+ig) = 0.0
8441 fracsd(iplon,lay,ngs14+ig) = 0.0
8452 end subroutine taugb15g
8454 !----------------------------------------------------------------------------
8455 _gpuker subroutine taugb16g( ncol, nlayers , taug, fracsd &
8456 #include "taug_cpu_args.h"
8458 !----------------------------------------------------------------------------
8460 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
8461 !----------------------------------------------------------------------------
8463 ! ------- Modules -------
8465 ! use parrrtm_f, only : ng16, ngs15
8466 use parrrtm_f, only : ngs15
8467 use rrlw_ref_f, only : chi_mlsd
8470 ! ------- Declarations -------
8471 real _gpudev :: taug(:,:,:)
8472 real _gpudev :: fracsd(:,:,:)
8473 #include "taug_cpu_defs.h"
8476 integer :: lay, ind0, ind1, inds, indf, ig
8477 integer :: js, js1, jpl
8478 real :: speccomb, specparm, specmult, fs
8479 real :: speccomb1, specparm1, specmult1, fs1
8480 real :: speccomb_planck, specparm_planck, specmult_planck, fpl
8481 real :: p, p4, fk0, fk1, fk2
8482 real :: fac000, fac100, fac200, fac010, fac110, fac210
8483 real :: fac001, fac101, fac201, fac011, fac111, fac211
8484 real :: tauself, taufor
8485 real :: refrat_planck_a
8486 real :: tau_major, tau_major1
8487 integer , value, intent(in) :: ncol, nlayers
8491 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
8492 lay = (blockidx%y-1) * blockdim%y + threadidx%y
8493 if (iplon <= ncol .and. lay <= nlayers) then
8498 ! Calculate reference ratio to be used in calculation of Planck
8499 ! fraction in lower atmosphere.
8501 ! P = 387. mb (Level 6)
8502 refrat_planck_a = chi_mlsd(1,6)/chi_mlsd(6,6)
8504 ! Compute the optical depth by interpolating in ln(pressure),
8505 ! temperature,and appropriate species. Below laytrop, the water
8506 ! vapor self-continuum and foreign continuum is interpolated
8507 ! (in temperature) separately.
8509 ! Lower atmosphere loop
8510 if (lay <= laytrop(iplon)) then
8511 speccomb = colh2o(iplon,lay) + rat_h2och4(iplon,lay)*colch4(iplon,lay)
8512 specparm = colh2o(iplon,lay)/speccomb
8513 if (specparm .ge. oneminusd) specparm = oneminusd
8514 specmult = 8. *(specparm)
8515 js = 1 + int(specmult)
8516 fs = mod(specmult,1.0 )
8518 speccomb1 = colh2o(iplon,lay) + rat_h2och4_1(iplon,lay)*colch4(iplon,lay)
8519 specparm1 = colh2o(iplon,lay)/speccomb1
8520 if (specparm1 .ge. oneminusd) specparm1 = oneminusd
8521 specmult1 = 8. *(specparm1)
8522 js1 = 1 + int(specmult1)
8523 fs1 = mod(specmult1,1.0 )
8525 speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colch4(iplon,lay)
8526 specparm_planck = colh2o(iplon,lay)/speccomb_planck
8527 if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd
8528 specmult_planck = 8. *specparm_planck
8529 jpl= 1 + int(specmult_planck)
8530 fpl = mod(specmult_planck,1.0 )
8532 ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(16) + js
8533 ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(16) + js1
8534 inds = indself(iplon,lay)
8535 indf = indfor(iplon,lay)
8537 if (specparm .lt. 0.125 ) then
8541 fk1 = 1 - p - 2.0 *p4
8543 fac000 = fk0*fac00(iplon,lay)
8544 fac100 = fk1*fac00(iplon,lay)
8545 fac200 = fk2*fac00(iplon,lay)
8546 fac010 = fk0*fac10(iplon,lay)
8547 fac110 = fk1*fac10(iplon,lay)
8548 fac210 = fk2*fac10(iplon,lay)
8549 else if (specparm .gt. 0.875 ) then
8553 fk1 = 1 - p - 2.0 *p4
8555 fac000 = fk0*fac00(iplon,lay)
8556 fac100 = fk1*fac00(iplon,lay)
8557 fac200 = fk2*fac00(iplon,lay)
8558 fac010 = fk0*fac10(iplon,lay)
8559 fac110 = fk1*fac10(iplon,lay)
8560 fac210 = fk2*fac10(iplon,lay)
8562 fac000 = (1. - fs) * fac00(iplon,lay)
8563 fac010 = (1. - fs) * fac10(iplon,lay)
8564 fac100 = fs * fac00(iplon,lay)
8565 fac110 = fs * fac10(iplon,lay)
8568 if (specparm1 .lt. 0.125 ) then
8572 fk1 = 1 - p - 2.0 *p4
8574 fac001 = fk0*fac01(iplon,lay)
8575 fac101 = fk1*fac01(iplon,lay)
8576 fac201 = fk2*fac01(iplon,lay)
8577 fac011 = fk0*fac11(iplon,lay)
8578 fac111 = fk1*fac11(iplon,lay)
8579 fac211 = fk2*fac11(iplon,lay)
8580 else if (specparm1 .gt. 0.875 ) then
8584 fk1 = 1 - p - 2.0 *p4
8586 fac001 = fk0*fac01(iplon,lay)
8587 fac101 = fk1*fac01(iplon,lay)
8588 fac201 = fk2*fac01(iplon,lay)
8589 fac011 = fk0*fac11(iplon,lay)
8590 fac111 = fk1*fac11(iplon,lay)
8591 fac211 = fk2*fac11(iplon,lay)
8593 fac001 = (1. - fs1) * fac01(iplon,lay)
8594 fac011 = (1. - fs1) * fac11(iplon,lay)
8595 fac101 = fs1 * fac01(iplon,lay)
8596 fac111 = fs1 * fac11(iplon,lay)
8600 tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * &
8601 (selfrefd(inds+1,ig) - selfrefd(inds,ig)))
8602 taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * &
8603 (forrefd(indf+1,ig) - forrefd(indf,ig)))
8605 if (specparm .lt. 0.125 ) then
8606 tau_major = speccomb * &
8607 (fac000 * absad(ind0,ig) + &
8608 fac100 * absad(ind0+1,ig) + &
8609 fac200 * absad(ind0+2,ig) + &
8610 fac010 * absad(ind0+9,ig) + &
8611 fac110 * absad(ind0+10,ig) + &
8612 fac210 * absad(ind0+11,ig))
8613 else if (specparm .gt. 0.875 ) then
8614 tau_major = speccomb * &
8615 (fac200 * absad(ind0-1,ig) + &
8616 fac100 * absad(ind0,ig) + &
8617 fac000 * absad(ind0+1,ig) + &
8618 fac210 * absad(ind0+8,ig) + &
8619 fac110 * absad(ind0+9,ig) + &
8620 fac010 * absad(ind0+10,ig))
8622 tau_major = speccomb * &
8623 (fac000 * absad(ind0,ig) + &
8624 fac100 * absad(ind0+1,ig) + &
8625 fac010 * absad(ind0+9,ig) + &
8626 fac110 * absad(ind0+10,ig))
8629 if (specparm1 .lt. 0.125 ) then
8630 tau_major1 = speccomb1 * &
8631 (fac001 * absad(ind1,ig) + &
8632 fac101 * absad(ind1+1,ig) + &
8633 fac201 * absad(ind1+2,ig) + &
8634 fac011 * absad(ind1+9,ig) + &
8635 fac111 * absad(ind1+10,ig) + &
8636 fac211 * absad(ind1+11,ig))
8637 else if (specparm1 .gt. 0.875 ) then
8638 tau_major1 = speccomb1 * &
8639 (fac201 * absad(ind1-1,ig) + &
8640 fac101 * absad(ind1,ig) + &
8641 fac001 * absad(ind1+1,ig) + &
8642 fac211 * absad(ind1+8,ig) + &
8643 fac111 * absad(ind1+9,ig) + &
8644 fac011 * absad(ind1+10,ig))
8646 tau_major1 = speccomb1 * &
8647 (fac001 * absad(ind1,ig) + &
8648 fac101 * absad(ind1+1,ig) + &
8649 fac011 * absad(ind1+9,ig) + &
8650 fac111 * absad(ind1+10,ig))
8653 taug(iplon,lay,ngs15+ig) = tau_major + tau_major1 &
8655 fracsd(iplon,lay,ngs15+ig) = fracrefad(ig,jpl) + fpl * &
8656 (fracrefad(ig,jpl+1)-fracrefad(ig,jpl))
8659 ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(16) + 1
8660 ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(16) + 1
8662 taug(iplon,lay,ngs15+ig) = colch4(iplon,lay) * &
8663 (fac00(iplon,lay) * absbd(ind0,ig) + &
8664 fac10(iplon,lay) * absbd(ind0+1,ig) + &
8665 fac01(iplon,lay) * absbd(ind1,ig) + &
8666 fac11(iplon,lay) * absbd(ind1+1,ig))
8667 fracsd(iplon,lay,ngs15+ig) = fracrefbd(ig)
8678 end subroutine taugb16g
8680 _gpuker subroutine addAerosols( ncol, nlayers, ngptlw, nbndlw, ngbd, taug &
8681 #include "taug_cpu_args.h"
8684 integer , intent(in), value :: ncol, nlayers, ngptlw, nbndlw
8685 integer , intent(in) :: ngbd(:)
8687 #include "taug_cpu_defs.h"
8689 integer :: iplon, lay, ig
8690 real _gpudev :: taug(:,:,:)
8693 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
8694 lay = (blockidx%y-1) * blockdim%y + threadidx%y
8695 ig = (blockidx%z-1) * blockdim%z + threadidx%z
8696 if (iplon<=ncol .and. lay<=nlayers .and. ig<=ngptlw) then
8703 taug(iplon, lay, ig) = taug(iplon, lay, ig) + tauaa(iplon, lay, ngbd(ig))
8715 !----------------------------------------------------------------------------
8716 subroutine taumolg(iplon, ncol, nlayers, ngbd, taug, fracsd &
8717 #include "taug_cpu_args.h"
8719 !----------------------------------------------------------------------------
8721 ! *******************************************************************************
8723 ! * Optical depths developed for the *
8725 ! * RAPID RADIATIVE TRANSFER MODEL (RRTM) *
8728 ! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. *
8729 ! * 131 HARTWELL AVENUE *
8730 ! * LEXINGTON, MA 02421 *
8734 ! * JENNIFER DELAMERE *
8735 ! * STEVEN J. TAUBMAN *
8736 ! * SHEPARD A. CLOUGH *
8741 ! * email: mlawer@aer.com *
8742 ! * email: jdelamer@aer.com *
8744 ! * The authors wish to acknowledge the contributions of the *
8745 ! * following people: Karen Cady-Pereira, Patrick D. Brown, *
8746 ! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. *
8748 ! *******************************************************************************
8750 ! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. *
8752 ! *******************************************************************************
8755 ! * This file contains the subroutines TAUGBn (where n goes from *
8756 ! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions *
8757 ! * per g-value and layer for band n. *
8759 ! * Output: optical depths (unitless) *
8760 ! * fractions needed to compute Planck functions at every layer *
8763 ! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) *
8764 ! * COMMON /PLANKG/ fracsd(MXLAY,MG) *
8768 ! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) *
8769 ! * COMMON /PRECISE/ oneminusd *
8770 ! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), *
8771 ! * & PZ(0:MXLAY),TZ(0:MXLAY) *
8772 ! * COMMON /PROFDATA/ LAYTROP, *
8773 ! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), *
8774 ! * & COLN2O(MXLAY),colco(MXLAY),COLCH4(MXLAY), *
8776 ! * COMMON /INTFAC/ fac00(iplon,MXLAY),fac01(iplon,MXLAY), *
8777 ! * & FAC10(MXLAY),fac11(iplon,MXLAY) *
8778 ! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) *
8779 ! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) *
8782 ! * NG(IBAND) - number of g-values in band IBAND *
8783 ! * NSPA(IBAND) - for the lower atmosphere, the number of reference *
8784 ! * atmospheres that are stored for band IBAND per *
8785 ! * pressure level and temperature. Each of these *
8786 ! * atmospheres has different relative amounts of the *
8787 ! * key species for the band (i.e. different binary *
8788 ! * species parameters). *
8789 ! * NSPB(IBAND) - same for upper atmosphere *
8790 ! * oneminusd - since problems are caused in some cases by interpolation *
8791 ! * parameters equal to or greater than 1, for these cases *
8792 ! * these parameters are set to this value, slightly < 1. *
8793 ! * PAVEL - layer pressures (mb) *
8794 ! * TAVEL - layer temperatures (degrees K) *
8795 ! * PZ - level pressures (mb) *
8796 ! * TZ - level temperatures (degrees K) *
8797 ! * LAYTROP - layer at which switch is made from one combination of *
8798 ! * key species to another *
8799 ! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water *
8800 ! * vapor,carbon dioxide, ozone, nitrous ozide, methane, *
8801 ! * respectively (molecules/cm**2) *
8802 ! * FACij(LAY) - for layer LAY, these are factors that are needed to *
8803 ! * compute the interpolation factors that multiply the *
8804 ! * appropriate reference k-values. A value of 0 (1) for *
8805 ! * i,j indicates that the corresponding factor multiplies *
8806 ! * reference k-value for the lower (higher) of the two *
8807 ! * appropriate temperatures, and altitudes, respectively. *
8808 ! * JP - the index of the lower (in altitude) of the two appropriate *
8809 ! * reference pressure levels needed for interpolation *
8810 ! * JT, JT1 - the indices of the lower of the two appropriate reference *
8811 ! * temperatures needed for interpolation (for pressure *
8812 ! * levels JP and JP+1, respectively) *
8813 ! * SELFFAC - scale factor needed for water vapor self-continuum, equals *
8814 ! * (water vapor density)/(atmospheric density at 296K and *
8816 ! * SELFFRAC - factor needed for temperature interpolation of reference *
8817 ! * water vapor self-continuum data *
8818 ! * INDSELF - index of the lower of the two appropriate reference *
8819 ! * temperatures needed for the self-continuum interpolation *
8820 ! * FORFAC - scale factor needed for water vapor foreign-continuum. *
8821 ! * FORFRAC - factor needed for temperature interpolation of reference *
8822 ! * water vapor foreign-continuum data *
8823 ! * INDFOR - index of the lower of the two appropriate reference *
8824 ! * temperatures needed for the foreign-continuum interpolation *
8827 ! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),*
8828 ! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' *
8829 ! * (note: n is the band number,'MGAS' is the species name of the minor *
8833 ! * KA - k-values for low reference atmospheres (key-species only) *
8834 ! * (units: cm**2/molecule) *
8835 ! * KB - k-values for high reference atmospheres (key-species only) *
8836 ! * (units: cm**2/molecule) *
8837 ! * KA_M'MGAS' - k-values for low reference atmosphere minor species *
8838 ! * (units: cm**2/molecule) *
8839 ! * KB_M'MGAS' - k-values for high reference atmosphere minor species *
8840 ! * (units: cm**2/molecule) *
8841 ! * SELFREF - k-values for water vapor self-continuum for reference *
8842 ! * atmospheres (used below LAYTROP) *
8843 ! * (units: cm**2/molecule) *
8844 ! * FORREF - k-values for water vapor foreign-continuum for reference *
8845 ! * atmospheres (used below/above LAYTROP) *
8846 ! * (units: cm**2/molecule) *
8848 ! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) *
8849 ! * EQUIVALENCE (KA,ABSA),(KB,ABSB) *
8851 !*******************************************************************************
8853 use parrrtm_f, only : ng1
8855 ! ------- Declarations -------
8856 #include "taug_cpu_defs.h"
8859 integer , intent(in) :: iplon ! the column number (move to calculated in kernel)
8860 integer , intent(in) :: ncol ! the total number of columns
8861 integer , intent(in) :: nlayers ! total number of layers
8862 integer _gpudev, intent(in) :: ngbd(:)
8863 real , intent(in) _gpudev :: fracsd(:,:,:)
8864 real , intent(in) _gpudev :: taug(:,:,:)
8866 !real :: taugcc(ncol, nlayers, 140)
8868 ! ----- Output -----
8874 type(dim3) :: dimGrid, dimBlock
8877 !dimGrid = dim3( (ncol + 127) / 128, 1, 1)
8878 !dimBlock = dim3( 128,1,1)
8880 dimGrid = dim3( (ncol + 63) / 64, ((nlayers+1)/2), 1)
8881 dimBlock = dim3( 64, 2, 1)
8884 !jm this can be made constant if the arrays are padded out, otherwise
8885 !jm will generate a seg fault computing garbage data on unused ends of vectors
8886 !jm zap # define ncol CHNK
8889 ! Calculate gaseous optical depth and planck fractions for each spectral band.
8891 ! (dmb 2012) Here we configure the grid and thread blocks. These subroutines are
8892 ! only parallelized across the column dimension so the blocks are one dimensional.
8893 call taugb1g _gpuchv (ncol, nlayers, taug, fracsd &
8894 #include "taug_cpu_args.h"
8897 call taugb2g _gpuchv (ncol, nlayers, taug, fracsd &
8898 #include "taug_cpu_args.h"
8901 call taugb3g _gpuchv (ncol, nlayers, taug, fracsd &
8902 #include "taug_cpu_args.h"
8905 call taugb4g _gpuchv (ncol, nlayers, taug, fracsd &
8906 #include "taug_cpu_args.h"
8909 call taugb5g _gpuchv (ncol, nlayers, taug, fracsd &
8910 #include "taug_cpu_args.h"
8913 call taugb6g _gpuchv (ncol, nlayers, taug, fracsd &
8914 #include "taug_cpu_args.h"
8917 call taugb7g _gpuchv (ncol, nlayers, taug, fracsd &
8918 #include "taug_cpu_args.h"
8921 call taugb8g _gpuchv (ncol, nlayers, taug, fracsd &
8922 #include "taug_cpu_args.h"
8925 call taugb9g _gpuchv (ncol, nlayers, taug, fracsd &
8926 #include "taug_cpu_args.h"
8929 call taugb10g _gpuchv (ncol, nlayers, taug, fracsd &
8930 #include "taug_cpu_args.h"
8933 call taugb11g _gpuchv (ncol, nlayers, taug, fracsd &
8934 #include "taug_cpu_args.h"
8937 call taugb12g _gpuchv (ncol, nlayers, taug, fracsd &
8938 #include "taug_cpu_args.h"
8941 call taugb13g _gpuchv (ncol, nlayers, taug, fracsd &
8942 #include "taug_cpu_args.h"
8945 call taugb14g _gpuchv (ncol, nlayers, taug, fracsd &
8946 #include "taug_cpu_args.h"
8949 call taugb15g _gpuchv (ncol, nlayers, taug, fracsd &
8950 #include "taug_cpu_args.h"
8953 call taugb16g _gpuchv (ncol, nlayers, taug, fracsd &
8954 #include "taug_cpu_args.h"
8958 dimGrid = dim3( (ncol+ 255) / 256, nlayers, ngptlw )
8959 dimBlock = dim3( 256, 1, 1)
8962 ! (dmb 2012) This code used to be in the main rrtmg_lw_rad source file
8963 ! We add the aerosol optical depths to the gas optical depths
8964 call addAerosols _gpuchv (ncol, nlayers, ngptlw, nbndlw, ngbd, taug &
8965 #include "taug_cpu_args.h"
8968 end subroutine taumolg
8971 ! undefines for taug functions
9021 ! (dmb 2012) Allocate all of the needed memory for the taumol subroutines
9022 subroutine allocateGPUTaumol(ncol, nlayers, npart)
9024 integer , intent(in) :: ncol
9025 integer , intent(in) :: nlayers
9026 integer , intent(in) :: npart
9029 sreg( wx1 , ncol, nlayers )
9030 sreg( wx2 , ncol, nlayers )
9031 sreg( wx3 , ncol, nlayers )
9032 sreg( wx4 , ncol, nlayers )
9034 sreg( jp , ncol, nlayers )
9035 sreg( jt , ncol, nlayers )
9036 sreg( jt1 , ncol, nlayers )
9037 sreg( colh2o , ncol, nlayers )
9038 sreg( colco2 , ncol, nlayers )
9039 sreg( colo3 , ncol, nlayers )
9040 sreg( coln2o , ncol, nlayers )
9041 sreg( colco , ncol, nlayers )
9042 sreg( colch4 , ncol, nlayers )
9043 sreg( colo2 , ncol, nlayers )
9044 sreg( colbrd , ncol, nlayers )
9045 sreg( indself , ncol, nlayers )
9046 sreg( indfor , ncol, nlayers )
9047 sreg( selffac , ncol, nlayers )
9048 sreg( selffrac , ncol, nlayers )
9049 sreg( forfac , ncol, nlayers )
9050 sreg( forfrac , ncol, nlayers )
9051 sreg( indminor , ncol, nlayers )
9052 sreg( minorfrac , ncol, nlayers )
9053 sreg( scaleminor , ncol, nlayers )
9054 sreg( scaleminorn2 , ncol, nlayers )
9056 sreg( fac00 , ncol, nlayers )
9057 sreg( fac10 , ncol, nlayers )
9058 sreg( fac01 , ncol, nlayers )
9059 sreg( fac11 , ncol, nlayers )
9060 sreg( rat_h2oco2 , ncol, nlayers )
9061 sreg( rat_h2oco2_1 , ncol, nlayers )
9062 sreg( rat_h2oo3 , ncol, nlayers )
9063 sreg( rat_h2oo3_1 , ncol, nlayers )
9064 sreg( rat_h2on2o , ncol, nlayers )
9065 sreg( rat_h2on2o_1 , ncol, nlayers )
9066 sreg( rat_h2och4 , ncol, nlayers )
9067 sreg( rat_h2och4_1 , ncol, nlayers )
9068 sreg( rat_n2oco2 , ncol, nlayers )
9069 sreg( rat_n2oco2_1 , ncol, nlayers )
9070 sreg( rat_o3co2 , ncol, nlayers )
9071 sreg( rat_o3co2_1 , ncol, nlayers )
9075 allocate( pavel( ncol, nlayers ))
9076 dreg( wx1 , ncol, nlayers )
9077 dreg( wx2 , ncol, nlayers )
9078 dreg( wx3 , ncol, nlayers )
9079 dreg( wx4 , ncol, nlayers )
9081 allocate( coldry( ncol, nlayers ))
9083 dreg( jp , ncol, nlayers )
9084 dreg( jt , ncol, nlayers )
9085 dreg( jt1 , ncol, nlayers )
9086 dreg( colh2o , ncol, nlayers )
9087 dreg( colco2 , ncol, nlayers )
9088 dreg( colo3 , ncol, nlayers )
9089 dreg( coln2o , ncol, nlayers )
9090 dreg( colco , ncol, nlayers )
9091 dreg( colch4 , ncol, nlayers )
9092 dreg( colo2 , ncol, nlayers )
9093 dreg( colbrd , ncol, nlayers )
9094 dreg( indself , ncol, nlayers )
9095 dreg( indfor , ncol, nlayers )
9096 dreg( selffac , ncol, nlayers )
9097 dreg( selffrac , ncol, nlayers )
9098 dreg( forfac , ncol, nlayers )
9099 dreg( forfrac , ncol, nlayers )
9100 dreg( indminor , ncol, nlayers )
9101 dreg( minorfrac , ncol, nlayers )
9102 dreg( scaleminor , ncol, nlayers )
9103 dreg( scaleminorn2 , ncol, nlayers )
9105 dreg( fac00 , ncol, nlayers )
9106 dreg( fac10 , ncol, nlayers )
9107 dreg( fac01 , ncol, nlayers )
9108 dreg( fac11 , ncol, nlayers )
9109 dreg( rat_h2oco2 , ncol, nlayers )
9110 dreg( rat_h2oco2_1 , ncol, nlayers )
9111 dreg( rat_h2oo3 , ncol, nlayers )
9112 dreg( rat_h2oo3_1 , ncol, nlayers )
9113 dreg( rat_h2on2o , ncol, nlayers )
9114 dreg( rat_h2on2o_1 , ncol, nlayers )
9115 dreg( rat_h2och4 , ncol, nlayers )
9116 dreg( rat_h2och4_1 , ncol, nlayers )
9117 dreg( rat_n2oco2 , ncol, nlayers )
9118 dreg( rat_n2oco2_1 , ncol, nlayers )
9119 dreg( rat_o3co2 , ncol, nlayers )
9120 dreg( rat_o3co2_1 , ncol, nlayers )
9122 allocate( laytrop( ncol ))
9123 allocate( tauaa( ncol, nlayers, nbndlw ))
9124 allocate( nspad( nbndlw ))
9125 allocate( nspbd( nbndlw ))
9131 ! (dmb 2012) Perform the necessary cleanup of the GPU arrays
9132 subroutine deallocateGPUTaumol()
9140 deallocate( laytrop)
9149 subroutine copyGPUTaumolMol( colstart, pncol, nlayers, colh2oc, colco2c, colo3c, coln2oc, colch4c, colo2c,&
9150 px1,px2,px3,px4, npart)
9152 integer, value, intent(in) :: colstart, pncol, nlayers, npart
9153 real , intent(in) :: colh2oc(:,:), colco2c(:,:), colo3c(:,:), coln2oc(:,:), &
9154 colch4c(:,:), colo2c(:,:), px1(:,:), px2(:,:), px3(:,:), px4(:,:)
9158 colh2o(1:pncol, :) = colh2oc( colstart:(colstart+pncol-1), 1:nlayers)
9159 colco2(1:pncol, :) = colco2c( colstart:(colstart+pncol-1), 1:nlayers)
9160 colo3(1:pncol, :) = colo3c( colstart:(colstart+pncol-1), 1:nlayers)
9161 coln2o(1:pncol, :) = coln2oc( colstart:(colstart+pncol-1), 1:nlayers)
9163 colch4(1:pncol, :) = colch4c( colstart:(colstart+pncol-1), 1:nlayers)
9164 colo2(1:pncol, :) = colo2c( colstart:(colstart+pncol-1), 1:nlayers)
9165 wx1(1:pncol, :) = px1(colstart:(colstart+pncol-1), 1:nlayers)
9166 wx2(1:pncol, :) = px2(colstart:(colstart+pncol-1), 1:nlayers)
9167 wx3(1:pncol, :) = px3(colstart:(colstart+pncol-1), 1:nlayers)
9168 wx4(1:pncol, :) = px4(colstart:(colstart+pncol-1), 1:nlayers)
9186 ! (dmb 2012) Copy the needed data from the CPU to the GPU. I had to separate this
9187 ! out into 16 separate functions to correspond with the 16 taumol subroutines.
9188 subroutine copyGPUTaumol(pavelc, wxc, coldryc, tauap, pncol, colstart, nlay, npart)
9190 use rrlw_kg01_f, only : copyToGPU1, reg1
9191 use rrlw_kg02_f, only : copyToGPU2, reg2
9192 use rrlw_kg03_f, only : copyToGPU3, reg3
9193 use rrlw_kg04_f, only : copyToGPU4, reg4
9194 use rrlw_kg05_f, only : copyToGPU5, reg5
9195 use rrlw_kg06_f, only : copyToGPU6, reg6
9196 use rrlw_kg07_f, only : copyToGPU7, reg7
9197 use rrlw_kg08_f, only : copyToGPU8, reg8
9198 use rrlw_kg09_f, only : copyToGPU9, reg9
9199 use rrlw_kg10_f, only : copyToGPU10, reg10
9200 use rrlw_kg11_f, only : copyToGPU11, reg11
9201 use rrlw_kg12_f, only : copyToGPU12, reg12
9202 use rrlw_kg13_f, only : copyToGPU13, reg13
9203 use rrlw_kg14_f, only : copyToGPU14, reg14
9204 use rrlw_kg15_f, only : copyToGPU15, reg15
9205 use rrlw_kg16_f, only : copyToGPU16, reg16
9206 use rrlw_ref_f, only : copyToGPUref
9208 real , intent(in) :: pavelc(:,:) ! layer pressures (mb)
9209 ! Dimensions: (ncol,nlayers)
9210 real , intent(in) :: wxc(:,:,:) ! cross-section amounts (mol/cm2)
9211 ! Dimensions: (ncol,maxxsec,nlayers)
9212 real , intent(in) :: coldryc(:,:) ! column amount (dry air)
9213 ! Dimensions: (ncol,nlayers)
9215 real , intent(in) :: tauap(:,:,:)
9216 ! Dimensions: (ncol,nlayers,ngptlw)
9217 integer, intent(in) :: pncol, colstart, nlay, npart
9260 oneminusd = oneminus
9265 tauaa(1:pncol, :, :) = tauap(colstart:(colstart+pncol-1), :, :)
9272 end module gpu_rrtmg_lw_taumol
9274 ! This is the gpu version of the setcoef routine.
9275 module gpu_rrtmg_lw_setcoef
9277 use gpu_rrtmg_lw_rtrnmc
9279 use parrrtm_f, only : nbndlw, mg, maxxsec, mxmol
9280 use rrlw_wvn_f, only: totplnk, totplk16, totplnkderiv, totplk16deriv
9281 use rrlw_vsn_f, only: hvrset, hnamset
9282 use rrlw_ref_f, only : chi_mlsd
9284 use gpu_rrtmg_lw_taumol
9289 real _gpudev, allocatable :: taveld(:,:) ! layer temperatures (K)
9290 ! Dimensions: (ncol,nlayers)
9291 real _gpudev, allocatable :: tzd(:,:) ! level (interface) temperatures (K)
9292 ! Dimensions: (ncol,0:nlayers)
9293 real _gpudev, allocatable :: tboundd(:) ! surface temperature (K)
9294 ! Dimensions: (ncol)
9295 real _gpudev, allocatable :: wbroadd(:,:) ! broadening gas column density (mol/cm2)
9296 ! Dimensions: (ncol,nlayers)
9298 real _gpudev :: totplnkd(181,nbndlw)
9299 real _gpudev :: totplk16d(181)
9301 real _gpudev :: totplnkderivd(181,nbndlw)
9302 real _gpudev :: totplk16derivd(181)
9303 !$OMP THREADPRIVATE(taveld,tzd,tboundd,wbroadd,totplnkd,totplk16d,totplnkderivd,totplk16derivd)
9308 ! (dmb 2012) This subroutine allocates the needed GPU arrays
9309 subroutine allocateGPUSetCoef( ncol, nlayers )
9311 integer, intent(in) :: ncol
9312 integer, intent(in) :: nlayers
9314 allocate( taveld( ncol, nlayers) )
9315 allocate( tzd( ncol, 0:nlayers) )
9316 allocate( tboundd( ncol ))
9317 allocate( wbroadd( ncol, nlayers) )
9322 ! (dmb 2012) This subroutine deallocates the GPU arrays
9323 subroutine deallocateGPUSetCoef( )
9326 deallocate( taveld )
9328 deallocate( tboundd)
9329 deallocate( wbroadd)
9334 ! (dmb 2012) Copy the needed reference data from the CPU to the GPU
9335 subroutine copyGPUSetCoef()
9339 totplk16d = totplk16
9340 totplnkderivd = totplnkderiv
9341 totplk16derivd = totplk16deriv
9346 !----------------------------------------------------------------------------
9347 _gpuker subroutine setcoefg(ncol, nlayers, istart &
9348 # include "rrtmg_lw_cpu_args.h"
9349 # include "taug_cpu_args.h"
9351 ,taveld,tzd,tboundd,wbroadd,totplnkd,totplk16d,totplnkderivd,totplk16derivd &
9354 !----------------------------------------------------------------------------
9356 ! Purpose: For a given atmosphere, calculate the indices and
9357 ! fractions related to the pressure and temperature interpolations.
9358 ! Also calculate the values of the integrated Planck functions
9359 ! for each band at the level and layer temperatures.
9361 ! ------- Declarations -------
9363 # include "rrtmg_lw_cpu_defs.h"
9364 # include "taug_cpu_defs.h"
9365 real :: taveld(CHNK,nlayers+1) ! layer temperatures (K)
9366 ! Dimensions: (ncol,nlayers)
9367 real :: tzd(CHNK,0:nlayers+1) ! level (interface) temperatures (K)
9368 ! Dimensions: (ncol,0:nlayers)
9369 real :: tboundd(CHNK) ! surface temperature (K)
9370 ! Dimensions: (ncol)
9371 real :: wbroadd(CHNK,nlayers+1) ! broadening gas column density (mol/cm2)
9372 ! Dimensions: (ncol,nlayers)
9374 real :: totplnkd(181,nbndlw)
9375 real :: totplk16d(181)
9377 real :: totplnkderivd(181,nbndlw)
9378 real :: totplk16derivd(181)
9382 integer , value, intent(in) :: ncol
9383 integer , value, intent(in) :: nlayers ! total number of layers
9384 integer , value, intent(in) :: istart ! beginning band of calculation
9385 !jm integer , value, intent(in) :: idrv ! Planck derivative option flag
9388 integer :: indbound, indlev0
9389 integer :: lay, indlay, indlev, iband
9391 real :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac
9392 real :: dbdtlev, dbdtlay
9393 real :: plog, fp, ft, ft1, water, scalefac, factor, compfp
9398 iplon = (blockidx%x-1) * blockdim%x + threadidx%x
9399 if (iplon <= ncol) then
9404 stpfac = 296. /1013.
9406 indbound = tboundd(iplon) - 159.
9407 if (indbound .lt. 1) then
9409 elseif (indbound .gt. 180) then
9412 tbndfrac = tboundd(iplon) - 159. - float(indbound)
9413 indlev0 = tzd(iplon, 0) - 159.
9414 if (indlev0 .lt. 1) then
9416 elseif (indlev0 .gt. 180) then
9419 t0frac = tzd(iplon, 0) - 159. - float(indlev0)
9423 ! Calculate the integrated Planck functions for each band at the
9424 ! surface, level, and layer temperatures.
9426 indlay = taveld(iplon, lay) - 159.
9427 lcoldry = coldry( iplon, lay)
9428 wv = colh2o(iplon, lay) * lcoldry
9429 if (indlay .lt. 1) then
9431 elseif (indlay .gt. 180) then
9434 tlayfrac = taveld(iplon, lay) - 159. - float(indlay)
9435 indlev = tzd(iplon, lay) - 159.
9436 if (indlev .lt. 1) then
9438 elseif (indlev .gt. 180) then
9441 tlevfrac = tzd(iplon, lay) - 159. - float(indlev)
9443 ! Begin spectral band loop
9446 dbdtlev = totplnkd(indbound+1,iband) - totplnkd(indbound,iband)
9447 plankbndd(iplon, iband) = semissd(iplon, iband) * &
9448 (totplnkd(indbound,iband) + tbndfrac * dbdtlev)
9449 dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband)
9450 planklevd(iplon, 0,iband) = totplnkd(indlev0,iband) + t0frac * dbdtlev
9451 if (idrvd .eq. 1) then
9452 dbdtlev = totplnkderivd(indbound+1,iband) - totplnkderivd(indbound,iband)
9453 dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * &
9454 (totplnkderivd(indbound,iband) + tbndfrac * dbdtlev)
9457 dbdtlev = totplnkd(indlev+1,iband) - totplnkd(indlev,iband)
9458 dbdtlay = totplnkd(indlay+1,iband) - totplnkd(indlay,iband)
9459 planklayd(iplon, lay,iband) = totplnkd(indlay,iband) + tlayfrac * dbdtlay
9461 planklevd(iplon, lay,iband) = totplnkd(indlev,iband) + tlevfrac * dbdtlev
9464 ! For band 16, if radiative transfer will be performed on just
9465 ! this band, use integrated Planck values up to 3250 cm-1.
9466 ! If radiative transfer will be performed across all 16 bands,
9467 ! then include in the integrated Planck values for this band
9468 ! contributions from 2600 cm-1 to infinity.
9470 if (istart .eq. 16) then
9472 dbdtlev = totplk16d( indbound+1) - totplk16d( indbound)
9473 plankbndd(iplon, iband) = semissd(iplon, iband) * &
9474 (totplk16d( indbound) + tbndfrac * dbdtlev)
9475 if (idrvd .eq. 1) then
9476 dbdtlev = totplk16derivd( indbound+1) - totplk16derivd( indbound)
9477 dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * &
9478 (totplk16derivd(indbound) + tbndfrac * dbdtlev)
9480 dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband)
9481 planklevd(iplon, 0,iband) = totplk16d( indlev0) + &
9484 dbdtlev = totplk16d( indlev+1) - totplk16d( indlev)
9485 dbdtlay = totplk16d( indlay+1) - totplk16d( indlay)
9486 planklayd(iplon, lay,iband) = totplk16d( indlay) + tlayfrac * dbdtlay
9487 planklevd(iplon, lay,iband) = totplk16d( indlev) + tlevfrac * dbdtlev
9490 dbdtlev = totplnkd(indbound+1,iband) - totplnkd(indbound,iband)
9491 plankbndd(iplon, iband) = semissd(iplon, iband) * &
9492 (totplnkd(indbound,iband) + tbndfrac * dbdtlev)
9493 if (idrvd .eq. 1) then
9494 dbdtlev = totplnkderivd( indbound+1,iband) - totplnkderivd( indbound,iband)
9495 dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * &
9496 (totplnkderivd( indbound,iband) + tbndfrac * dbdtlev)
9498 dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband)
9499 planklevd(iplon, 0,iband) = totplnkd(indlev0,iband) + t0frac * dbdtlev
9501 dbdtlev = totplnkd(indlev+1,iband) - totplnkd(indlev,iband)
9502 dbdtlay = totplnkd(indlay+1,iband) - totplnkd(indlay,iband)
9503 planklayd(iplon, lay,iband) = totplnkd(indlay,iband) + tlayfrac * dbdtlay
9504 planklevd(iplon, lay,iband) = totplnkd(indlev,iband) + tlevfrac * dbdtlev
9508 ! Find the two reference pressures on either side of the
9509 ! layer pressure. Store them in JP and JP1. Store in FP the
9510 ! fraction of the difference (in ln(pressure)) between these
9511 ! two values that the layer pressure lies.
9512 ! plog = alog(pavel(lay))
9513 plog = alog(pavel(iplon, lay))
9514 jp(iplon, lay) = int(36. - 5*(plog+0.04 ))
9515 if (jp(iplon, lay) .lt. 1) then
9517 elseif (jp(iplon, lay) .gt. 58) then
9520 jp1 = jp(iplon, lay) + 1
9521 fp = 5. *(preflogd(jp(iplon, lay)) - plog)
9523 ! Determine, for each reference pressure (JP and JP1), which
9524 ! reference temperature (these are different for each
9525 ! reference pressure) is nearest the layer temperature but does
9526 ! not exceed it. Store these indices in JT and JT1, resp.
9527 ! Store in FT (resp. FT1) the fraction of the way between JT
9528 ! (JT1) and the next highest reference temperature that the
9529 ! layer temperature falls.
9530 jt(iplon, lay) = int(3. + (taveld(iplon, lay)-trefd(jp(iplon, lay)))/15. )
9531 if (jt(iplon, lay) .lt. 1) then
9533 elseif (jt(iplon, lay) .gt. 4) then
9536 ft = ((taveld(iplon, lay)-trefd(jp(iplon, lay)))/15. ) - float(jt(iplon, lay)-3)
9537 jt1(iplon, lay) = int(3. + (taveld(iplon, lay)-trefd( jp1))/15. )
9538 if (jt1(iplon, lay) .lt. 1) then
9540 elseif (jt1(iplon, lay) .gt. 4) then
9543 ft1 = ((taveld(iplon, lay)-trefd(jp1))/15. ) - float(jt1(iplon, lay)-3)
9545 scalefac = pavel(iplon, lay) * stpfac / taveld(iplon, lay)
9547 ! If the pressure is less than ~100mb, perform a different
9548 ! set of species interpolations.
9549 if (plog .le. 4.56 ) go to 5300
9550 laytrop(iplon) = laytrop(iplon) + 1
9552 forfac(iplon, lay) = scalefac / (1.+water)
9553 factor = (332.0 -taveld(iplon, lay))/36.0
9554 indfor(iplon, lay) = min(2, max(1, int(factor)))
9555 forfrac(iplon, lay) = factor - float(indfor(iplon, lay))
9557 ! Set up factors needed to separately include the water vapor
9558 ! self-continuum in the calculation of absorption coefficient.
9559 selffac(iplon, lay) = water * forfac(iplon, lay)
9560 factor = (taveld(iplon, lay)-188.0 )/7.2
9561 indself(iplon, lay) = min(9, max(1, int(factor)-7))
9562 selffrac(iplon, lay) = factor - float(indself(iplon, lay) + 7)
9564 ! Set up factors needed to separately include the minor gases
9565 ! in the calculation of absorption coefficient
9566 scaleminor(iplon, lay) = pavel(iplon, lay)/taveld(iplon, lay)
9567 scaleminorn2(iplon, lay) = (pavel(iplon, lay)/taveld(iplon, lay)) &
9568 *(wbroadd(iplon, lay)/(lcoldry+wv))
9569 factor = (taveld(iplon, lay)-180.8 )/7.2
9570 indminor(iplon, lay) = min(18, max(1, int(factor)))
9571 minorfrac(iplon, lay) = factor - float(indminor(iplon, lay))
9573 ! Setup reference ratio to be used in calculation of binary
9574 ! species parameter in lower atmosphere.
9575 rat_h2oco2(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay))
9576 rat_h2oco2_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1)
9578 rat_h2oo3(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 3,jp(iplon, lay))
9579 rat_h2oo3_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 3,jp(iplon, lay)+1)
9581 rat_h2on2o(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 4,jp(iplon, lay))
9582 rat_h2on2o_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 4,jp(iplon, lay)+1)
9584 rat_h2och4(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 6,jp(iplon, lay))
9585 rat_h2och4_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 6,jp(iplon, lay)+1)
9587 rat_n2oco2(iplon, lay)=chi_mlsd( 4,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay))
9588 rat_n2oco2_1(iplon, lay)=chi_mlsd( 4,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1)
9590 ! Calculate needed column amounts.
9591 colh2o(iplon, lay) = 1.e-20 * colh2o(iplon, lay) * lcoldry
9592 colco2(iplon, lay) = 1.e-20 * colco2(iplon, lay) * lcoldry
9593 colo3(iplon, lay) = 1.e-20 * colo3(iplon, lay) * lcoldry
9594 coln2o(iplon, lay) = 1.e-20 * coln2o(iplon, lay) * lcoldry
9595 colco(iplon, lay) = 1.e-20 * colco(iplon, lay) * lcoldry
9596 colch4(iplon, lay) = 1.e-20 * colch4(iplon, lay) * lcoldry
9597 colo2(iplon, lay) = 1.e-20 * colo2(iplon, lay) * lcoldry
9598 if (colco2(iplon, lay) .eq. 0. ) colco2(iplon, lay) = 1.e-32 * lcoldry
9599 if (colo3(iplon, lay) .eq. 0. ) colo3(iplon, lay) = 1.e-32 * lcoldry
9600 if (coln2o(iplon, lay) .eq. 0. ) coln2o(iplon, lay) = 1.e-32 * lcoldry
9601 if (colco(iplon, lay) .eq. 0. ) colco(iplon, lay) = 1.e-32 * lcoldry
9602 if (colch4(iplon, lay) .eq. 0. ) colch4(iplon, lay) = 1.e-32 * lcoldry
9603 colbrd(iplon, lay) = 1.e-20 * wbroadd(iplon, lay)
9609 forfac(iplon, lay) = scalefac / (1.+water)
9610 factor = (taveld(iplon, lay)-188.0 )/36.0
9611 indfor(iplon, lay) = 3
9612 forfrac(iplon, lay) = factor - 1.0
9614 ! Set up factors needed to separately include the water vapor
9615 ! self-continuum in the calculation of absorption coefficient.
9616 selffac(iplon, lay) = water * forfac(iplon, lay)
9618 ! Set up factors needed to separately include the minor gases
9619 ! in the calculation of absorption coefficient
9620 scaleminor(iplon, lay) = pavel(iplon, lay)/taveld(iplon, lay)
9621 scaleminorn2(iplon, lay) = (pavel(iplon, lay)/taveld(iplon, lay)) &
9622 * (wbroadd(iplon, lay)/(coldry(iplon, lay)+wv))
9623 factor = (taveld(iplon, lay)-180.8 )/7.2
9624 indminor(iplon, lay) = min(18, max(1, int(factor)))
9625 minorfrac(iplon, lay) = factor - float(indminor(iplon, lay))
9627 ! Setup reference ratio to be used in calculation of binary
9628 ! species parameter in upper atmosphere.
9629 rat_h2oco2(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay))
9630 rat_h2oco2_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1)
9632 rat_o3co2(iplon, lay)=chi_mlsd( 3,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay))
9633 rat_o3co2_1(iplon, lay)=chi_mlsd( 3,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1)
9635 ! Calculate needed column amounts.
9636 colh2o(iplon, lay) = 1.e-20 * colh2o(iplon, lay) * lcoldry
9637 colco2(iplon, lay) = 1.e-20 * colco2(iplon, lay) * lcoldry
9638 colo3(iplon, lay) = 1.e-20 * colo3(iplon, lay) * lcoldry
9639 coln2o(iplon, lay) = 1.e-20 * coln2o(iplon, lay) * lcoldry
9640 colco(iplon, lay) = 1.e-20 * colco(iplon, lay) * lcoldry
9641 colch4(iplon, lay) = 1.e-20 * colch4(iplon, lay) * lcoldry
9642 colo2(iplon, lay) = 1.e-20 * colo2(iplon, lay) * lcoldry
9643 if (colco2(iplon, lay) .eq. 0. ) colco2(iplon, lay) = 1.e-32 * lcoldry
9644 if (colo3(iplon, lay) .eq. 0. ) colo3(iplon, lay) = 1.e-32 * lcoldry
9645 if (coln2o(iplon, lay) .eq. 0. ) coln2o(iplon, lay) = 1.e-32 * lcoldry
9646 if (colco(iplon, lay) .eq. 0. ) colco(iplon, lay) = 1.e-32 * lcoldry
9647 if (colch4(iplon, lay) .eq. 0. ) colch4(iplon, lay) = 1.e-32 * lcoldry
9648 colbrd(iplon, lay) = 1.e-20 * wbroadd(iplon, lay)
9651 ! We have now isolated the layer ln pressure and temperature,
9652 ! between two reference pressures and two reference temperatures
9653 ! (for each reference pressure). We multiply the pressure
9654 ! fraction FP with the appropriate temperature fractions to get
9655 ! the factors that will be needed for the interpolation that yields
9656 ! the optical depths (performed in routines TAUGBn for band n).`
9659 fac10(iplon, lay) = compfp * ft
9660 fac00(iplon, lay) = compfp * (1. - ft)
9661 fac11(iplon, lay) = fp * ft1
9662 fac01(iplon, lay) = fp * (1. - ft1)
9664 ! Rescale selffac and forfac for use in taumol
9665 selffac(iplon, lay) = colh2o(iplon, lay)*selffac(iplon, lay)
9666 forfac(iplon, lay) = colh2o(iplon, lay)*forfac(iplon, lay)
9675 end subroutine setcoefg
9677 end module gpu_rrtmg_lw_setcoef
9679 module rrtmg_lw_setcoef_f
9681 ! --------------------------------------------------------------------------
9683 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
9684 ! | This software may be used, copied, or redistributed as long as it is |
9685 ! | not sold and this copyright notice is reproduced on each copy made. |
9686 ! | This model is provided as is without any express or implied warranties. |
9687 ! | (http://www.rtweb.aer.com/) |
9689 ! --------------------------------------------------------------------------
9691 ! ------- Modules -------
9693 ! use parkind, only : im => kind , rb => kind
9694 use parrrtm_f, only : nbndlw, mg, maxxsec, mxmol
9695 use rrlw_wvn_f, only: totplnk, totplk16, totplnkderiv, totplk16deriv
9702 !***************************************************************************
9704 !***************************************************************************
9708 ! These pressures are chosen such that the ln of the first pressure
9709 ! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and
9710 ! each subsequent ln(pressure) differs from the previous one by 0.2.
9713 1.05363e+03 ,8.62642e+02 ,7.06272e+02 ,5.78246e+02 ,4.73428e+02 , &
9714 3.87610e+02 ,3.17348e+02 ,2.59823e+02 ,2.12725e+02 ,1.74164e+02 , &
9715 1.42594e+02 ,1.16746e+02 ,9.55835e+01 ,7.82571e+01 ,6.40715e+01 , &
9716 5.24573e+01 ,4.29484e+01 ,3.51632e+01 ,2.87892e+01 ,2.35706e+01 , &
9717 1.92980e+01 ,1.57998e+01 ,1.29358e+01 ,1.05910e+01 ,8.67114e+00 , &
9718 7.09933e+00 ,5.81244e+00 ,4.75882e+00 ,3.89619e+00 ,3.18993e+00 , &
9719 2.61170e+00 ,2.13828e+00 ,1.75067e+00 ,1.43333e+00 ,1.17351e+00 , &
9720 9.60789e-01 ,7.86628e-01 ,6.44036e-01 ,5.27292e-01 ,4.31710e-01 , &
9721 3.53455e-01 ,2.89384e-01 ,2.36928e-01 ,1.93980e-01 ,1.58817e-01 , &
9722 1.30029e-01 ,1.06458e-01 ,8.71608e-02 ,7.13612e-02 ,5.84256e-02 , &
9723 4.78349e-02 ,3.91639e-02 ,3.20647e-02 ,2.62523e-02 ,2.14936e-02 , &
9724 1.75975e-02 ,1.44076e-02 ,1.17959e-02 ,9.65769e-03 /)
9727 6.9600e+00 , 6.7600e+00 , 6.5600e+00 , 6.3600e+00 , 6.1600e+00 , &
9728 5.9600e+00 , 5.7600e+00 , 5.5600e+00 , 5.3600e+00 , 5.1600e+00 , &
9729 4.9600e+00 , 4.7600e+00 , 4.5600e+00 , 4.3600e+00 , 4.1600e+00 , &
9730 3.9600e+00 , 3.7600e+00 , 3.5600e+00 , 3.3600e+00 , 3.1600e+00 , &
9731 2.9600e+00 , 2.7600e+00 , 2.5600e+00 , 2.3600e+00 , 2.1600e+00 , &
9732 1.9600e+00 , 1.7600e+00 , 1.5600e+00 , 1.3600e+00 , 1.1600e+00 , &
9733 9.6000e-01 , 7.6000e-01 , 5.6000e-01 , 3.6000e-01 , 1.6000e-01 , &
9734 -4.0000e-02 ,-2.4000e-01 ,-4.4000e-01 ,-6.4000e-01 ,-8.4000e-01 , &
9735 -1.0400e+00 ,-1.2400e+00 ,-1.4400e+00 ,-1.6400e+00 ,-1.8400e+00 , &
9736 -2.0400e+00 ,-2.2400e+00 ,-2.4400e+00 ,-2.6400e+00 ,-2.8400e+00 , &
9737 -3.0400e+00 ,-3.2400e+00 ,-3.4400e+00 ,-3.6400e+00 ,-3.8400e+00 , &
9738 -4.0400e+00 ,-4.2400e+00 ,-4.4400e+00 ,-4.6400e+00 /)
9740 ! These are the temperatures associated with the respective
9741 ! pressures for the mls standard atmosphere.
9744 2.9420e+02 , 2.8799e+02 , 2.7894e+02 , 2.6925e+02 , 2.5983e+02 , &
9745 2.5017e+02 , 2.4077e+02 , 2.3179e+02 , 2.2306e+02 , 2.1578e+02 , &
9746 2.1570e+02 , 2.1570e+02 , 2.1570e+02 , 2.1706e+02 , 2.1858e+02 , &
9747 2.2018e+02 , 2.2174e+02 , 2.2328e+02 , 2.2479e+02 , 2.2655e+02 , &
9748 2.2834e+02 , 2.3113e+02 , 2.3401e+02 , 2.3703e+02 , 2.4022e+02 , &
9749 2.4371e+02 , 2.4726e+02 , 2.5085e+02 , 2.5457e+02 , 2.5832e+02 , &
9750 2.6216e+02 , 2.6606e+02 , 2.6999e+02 , 2.7340e+02 , 2.7536e+02 , &
9751 2.7568e+02 , 2.7372e+02 , 2.7163e+02 , 2.6955e+02 , 2.6593e+02 , &
9752 2.6211e+02 , 2.5828e+02 , 2.5360e+02 , 2.4854e+02 , 2.4348e+02 , &
9753 2.3809e+02 , 2.3206e+02 , 2.2603e+02 , 2.2000e+02 , 2.1435e+02 , &
9754 2.0887e+02 , 2.0340e+02 , 1.9792e+02 , 1.9290e+02 , 1.8809e+02 , &
9755 1.8329e+02 , 1.7849e+02 , 1.7394e+02 , 1.7212e+02 /)
9757 chi_mls(1,1:12) = (/ &
9758 1.8760e-02 , 1.2223e-02 , 5.8909e-03 , 2.7675e-03 , 1.4065e-03 , &
9759 7.5970e-04 , 3.8876e-04 , 1.6542e-04 , 3.7190e-05 , 7.4765e-06 , &
9760 4.3082e-06 , 3.3319e-06 /)
9761 chi_mls(1,13:59) = (/ &
9762 3.2039e-06 , 3.1619e-06 , 3.2524e-06 , 3.4226e-06 , 3.6288e-06 , &
9763 3.9148e-06 , 4.1488e-06 , 4.3081e-06 , 4.4420e-06 , 4.5778e-06 , &
9764 4.7087e-06 , 4.7943e-06 , 4.8697e-06 , 4.9260e-06 , 4.9669e-06 , &
9765 4.9963e-06 , 5.0527e-06 , 5.1266e-06 , 5.2503e-06 , 5.3571e-06 , &
9766 5.4509e-06 , 5.4830e-06 , 5.5000e-06 , 5.5000e-06 , 5.4536e-06 , &
9767 5.4047e-06 , 5.3558e-06 , 5.2533e-06 , 5.1436e-06 , 5.0340e-06 , &
9768 4.8766e-06 , 4.6979e-06 , 4.5191e-06 , 4.3360e-06 , 4.1442e-06 , &
9769 3.9523e-06 , 3.7605e-06 , 3.5722e-06 , 3.3855e-06 , 3.1988e-06 , &
9770 3.0121e-06 , 2.8262e-06 , 2.6407e-06 , 2.4552e-06 , 2.2696e-06 , &
9771 4.3360e-06 , 4.1442e-06 /)
9772 chi_mls(2,1:12) = (/ &
9773 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9774 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9775 3.5500e-04 , 3.5500e-04 /)
9776 chi_mls(2,13:59) = (/ &
9777 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9778 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9779 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9780 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9781 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9782 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9783 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9784 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , &
9785 3.5500e-04 , 3.5471e-04 , 3.5427e-04 , 3.5384e-04 , 3.5340e-04 , &
9786 3.5500e-04 , 3.5500e-04 /)
9787 chi_mls(3,1:12) = (/ &
9788 3.0170e-08 , 3.4725e-08 , 4.2477e-08 , 5.2759e-08 , 6.6944e-08 , &
9789 8.7130e-08 , 1.1391e-07 , 1.5677e-07 , 2.1788e-07 , 3.2443e-07 , &
9790 4.6594e-07 , 5.6806e-07 /)
9791 chi_mls(3,13:59) = (/ &
9792 6.9607e-07 , 1.1186e-06 , 1.7618e-06 , 2.3269e-06 , 2.9577e-06 , &
9793 3.6593e-06 , 4.5950e-06 , 5.3189e-06 , 5.9618e-06 , 6.5113e-06 , &
9794 7.0635e-06 , 7.6917e-06 , 8.2577e-06 , 8.7082e-06 , 8.8325e-06 , &
9795 8.7149e-06 , 8.0943e-06 , 7.3307e-06 , 6.3101e-06 , 5.3672e-06 , &
9796 4.4829e-06 , 3.8391e-06 , 3.2827e-06 , 2.8235e-06 , 2.4906e-06 , &
9797 2.1645e-06 , 1.8385e-06 , 1.6618e-06 , 1.5052e-06 , 1.3485e-06 , &
9798 1.1972e-06 , 1.0482e-06 , 8.9926e-07 , 7.6343e-07 , 6.5381e-07 , &
9799 5.4419e-07 , 4.3456e-07 , 3.6421e-07 , 3.1194e-07 , 2.5967e-07 , &
9800 2.0740e-07 , 1.9146e-07 , 1.9364e-07 , 1.9582e-07 , 1.9800e-07 , &
9801 7.6343e-07 , 6.5381e-07 /)
9802 chi_mls(4,1:12) = (/ &
9803 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , &
9804 3.1965e-07 , 3.1532e-07 , 3.0383e-07 , 2.9422e-07 , 2.8495e-07 , &
9805 2.7671e-07 , 2.6471e-07 /)
9806 chi_mls(4,13:59) = (/ &
9807 2.4285e-07 , 2.0955e-07 , 1.7195e-07 , 1.3749e-07 , 1.1332e-07 , &
9808 1.0035e-07 , 9.1281e-08 , 8.5463e-08 , 8.0363e-08 , 7.3372e-08 , &
9809 6.5975e-08 , 5.6039e-08 , 4.7090e-08 , 3.9977e-08 , 3.2979e-08 , &
9810 2.6064e-08 , 2.1066e-08 , 1.6592e-08 , 1.3017e-08 , 1.0090e-08 , &
9811 7.6249e-09 , 6.1159e-09 , 4.6672e-09 , 3.2857e-09 , 2.8484e-09 , &
9812 2.4620e-09 , 2.0756e-09 , 1.8551e-09 , 1.6568e-09 , 1.4584e-09 , &
9813 1.3195e-09 , 1.2072e-09 , 1.0948e-09 , 9.9780e-10 , 9.3126e-10 , &
9814 8.6472e-10 , 7.9818e-10 , 7.5138e-10 , 7.1367e-10 , 6.7596e-10 , &
9815 6.3825e-10 , 6.0981e-10 , 5.8600e-10 , 5.6218e-10 , 5.3837e-10 , &
9816 9.9780e-10 , 9.3126e-10 /)
9817 chi_mls(5,1:12) = (/ &
9818 1.5000e-07 , 1.4306e-07 , 1.3474e-07 , 1.3061e-07 , 1.2793e-07 , &
9819 1.2038e-07 , 1.0798e-07 , 9.4238e-08 , 7.9488e-08 , 6.1386e-08 , &
9820 4.5563e-08 , 3.3475e-08 /)
9821 chi_mls(5,13:59) = (/ &
9822 2.5118e-08 , 1.8671e-08 , 1.4349e-08 , 1.2501e-08 , 1.2407e-08 , &
9823 1.3472e-08 , 1.4900e-08 , 1.6079e-08 , 1.7156e-08 , 1.8616e-08 , &
9824 2.0106e-08 , 2.1654e-08 , 2.3096e-08 , 2.4340e-08 , 2.5643e-08 , &
9825 2.6990e-08 , 2.8456e-08 , 2.9854e-08 , 3.0943e-08 , 3.2023e-08 , &
9826 3.3101e-08 , 3.4260e-08 , 3.5360e-08 , 3.6397e-08 , 3.7310e-08 , &
9827 3.8217e-08 , 3.9123e-08 , 4.1303e-08 , 4.3652e-08 , 4.6002e-08 , &
9828 5.0289e-08 , 5.5446e-08 , 6.0603e-08 , 6.8946e-08 , 8.3652e-08 , &
9829 9.8357e-08 , 1.1306e-07 , 1.4766e-07 , 1.9142e-07 , 2.3518e-07 , &
9830 2.7894e-07 , 3.5001e-07 , 4.3469e-07 , 5.1938e-07 , 6.0407e-07 , &
9831 6.8946e-08 , 8.3652e-08 /)
9832 chi_mls(6,1:12) = (/ &
9833 1.7000e-06 , 1.7000e-06 , 1.6999e-06 , 1.6904e-06 , 1.6671e-06 , &
9834 1.6351e-06 , 1.6098e-06 , 1.5590e-06 , 1.5120e-06 , 1.4741e-06 , &
9835 1.4385e-06 , 1.4002e-06 /)
9836 chi_mls(6,13:59) = (/ &
9837 1.3573e-06 , 1.3130e-06 , 1.2512e-06 , 1.1668e-06 , 1.0553e-06 , &
9838 9.3281e-07 , 8.1217e-07 , 7.5239e-07 , 7.0728e-07 , 6.6722e-07 , &
9839 6.2733e-07 , 5.8604e-07 , 5.4769e-07 , 5.1480e-07 , 4.8206e-07 , &
9840 4.4943e-07 , 4.1702e-07 , 3.8460e-07 , 3.5200e-07 , 3.1926e-07 , &
9841 2.8646e-07 , 2.5498e-07 , 2.2474e-07 , 1.9588e-07 , 1.8295e-07 , &
9842 1.7089e-07 , 1.5882e-07 , 1.5536e-07 , 1.5304e-07 , 1.5072e-07 , &
9843 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , &
9844 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , &
9845 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , &
9846 1.5000e-07 , 1.5000e-07 /)
9847 chi_mls(7,1:12) = (/ &
9848 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9849 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9851 chi_mls(7,13:59) = (/ &
9852 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9853 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9854 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9855 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9856 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9857 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9858 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9859 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9860 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , &
9863 end subroutine lwatmref
9865 !***************************************************************************
9866 subroutine lwavplank
9867 !***************************************************************************
9871 totplnk(1:50, 1) = (/ &
9872 0.14783e-05 ,0.15006e-05 ,0.15230e-05 ,0.15455e-05 ,0.15681e-05 , &
9873 0.15908e-05 ,0.16136e-05 ,0.16365e-05 ,0.16595e-05 ,0.16826e-05 , &
9874 0.17059e-05 ,0.17292e-05 ,0.17526e-05 ,0.17762e-05 ,0.17998e-05 , &
9875 0.18235e-05 ,0.18473e-05 ,0.18712e-05 ,0.18953e-05 ,0.19194e-05 , &
9876 0.19435e-05 ,0.19678e-05 ,0.19922e-05 ,0.20166e-05 ,0.20412e-05 , &
9877 0.20658e-05 ,0.20905e-05 ,0.21153e-05 ,0.21402e-05 ,0.21652e-05 , &
9878 0.21902e-05 ,0.22154e-05 ,0.22406e-05 ,0.22659e-05 ,0.22912e-05 , &
9879 0.23167e-05 ,0.23422e-05 ,0.23678e-05 ,0.23934e-05 ,0.24192e-05 , &
9880 0.24450e-05 ,0.24709e-05 ,0.24968e-05 ,0.25229e-05 ,0.25490e-05 , &
9881 0.25751e-05 ,0.26014e-05 ,0.26277e-05 ,0.26540e-05 ,0.26805e-05 /)
9882 totplnk(51:100, 1) = (/ &
9883 0.27070e-05 ,0.27335e-05 ,0.27602e-05 ,0.27869e-05 ,0.28136e-05 , &
9884 0.28404e-05 ,0.28673e-05 ,0.28943e-05 ,0.29213e-05 ,0.29483e-05 , &
9885 0.29754e-05 ,0.30026e-05 ,0.30298e-05 ,0.30571e-05 ,0.30845e-05 , &
9886 0.31119e-05 ,0.31393e-05 ,0.31669e-05 ,0.31944e-05 ,0.32220e-05 , &
9887 0.32497e-05 ,0.32774e-05 ,0.33052e-05 ,0.33330e-05 ,0.33609e-05 , &
9888 0.33888e-05 ,0.34168e-05 ,0.34448e-05 ,0.34729e-05 ,0.35010e-05 , &
9889 0.35292e-05 ,0.35574e-05 ,0.35857e-05 ,0.36140e-05 ,0.36424e-05 , &
9890 0.36708e-05 ,0.36992e-05 ,0.37277e-05 ,0.37563e-05 ,0.37848e-05 , &
9891 0.38135e-05 ,0.38421e-05 ,0.38708e-05 ,0.38996e-05 ,0.39284e-05 , &
9892 0.39572e-05 ,0.39861e-05 ,0.40150e-05 ,0.40440e-05 ,0.40730e-05 /)
9893 totplnk(101:150, 1) = (/ &
9894 0.41020e-05 ,0.41311e-05 ,0.41602e-05 ,0.41893e-05 ,0.42185e-05 , &
9895 0.42477e-05 ,0.42770e-05 ,0.43063e-05 ,0.43356e-05 ,0.43650e-05 , &
9896 0.43944e-05 ,0.44238e-05 ,0.44533e-05 ,0.44828e-05 ,0.45124e-05 , &
9897 0.45419e-05 ,0.45715e-05 ,0.46012e-05 ,0.46309e-05 ,0.46606e-05 , &
9898 0.46903e-05 ,0.47201e-05 ,0.47499e-05 ,0.47797e-05 ,0.48096e-05 , &
9899 0.48395e-05 ,0.48695e-05 ,0.48994e-05 ,0.49294e-05 ,0.49594e-05 , &
9900 0.49895e-05 ,0.50196e-05 ,0.50497e-05 ,0.50798e-05 ,0.51100e-05 , &
9901 0.51402e-05 ,0.51704e-05 ,0.52007e-05 ,0.52309e-05 ,0.52612e-05 , &
9902 0.52916e-05 ,0.53219e-05 ,0.53523e-05 ,0.53827e-05 ,0.54132e-05 , &
9903 0.54436e-05 ,0.54741e-05 ,0.55047e-05 ,0.55352e-05 ,0.55658e-05 /)
9904 totplnk(151:181, 1) = (/ &
9905 0.55964e-05 ,0.56270e-05 ,0.56576e-05 ,0.56883e-05 ,0.57190e-05 , &
9906 0.57497e-05 ,0.57804e-05 ,0.58112e-05 ,0.58420e-05 ,0.58728e-05 , &
9907 0.59036e-05 ,0.59345e-05 ,0.59653e-05 ,0.59962e-05 ,0.60272e-05 , &
9908 0.60581e-05 ,0.60891e-05 ,0.61201e-05 ,0.61511e-05 ,0.61821e-05 , &
9909 0.62131e-05 ,0.62442e-05 ,0.62753e-05 ,0.63064e-05 ,0.63376e-05 , &
9910 0.63687e-05 ,0.63998e-05 ,0.64310e-05 ,0.64622e-05 ,0.64935e-05 , &
9912 totplnk(1:50, 2) = (/ &
9913 0.20262e-05 ,0.20757e-05 ,0.21257e-05 ,0.21763e-05 ,0.22276e-05 , &
9914 0.22794e-05 ,0.23319e-05 ,0.23849e-05 ,0.24386e-05 ,0.24928e-05 , &
9915 0.25477e-05 ,0.26031e-05 ,0.26591e-05 ,0.27157e-05 ,0.27728e-05 , &
9916 0.28306e-05 ,0.28889e-05 ,0.29478e-05 ,0.30073e-05 ,0.30673e-05 , &
9917 0.31279e-05 ,0.31890e-05 ,0.32507e-05 ,0.33129e-05 ,0.33757e-05 , &
9918 0.34391e-05 ,0.35029e-05 ,0.35674e-05 ,0.36323e-05 ,0.36978e-05 , &
9919 0.37638e-05 ,0.38304e-05 ,0.38974e-05 ,0.39650e-05 ,0.40331e-05 , &
9920 0.41017e-05 ,0.41708e-05 ,0.42405e-05 ,0.43106e-05 ,0.43812e-05 , &
9921 0.44524e-05 ,0.45240e-05 ,0.45961e-05 ,0.46687e-05 ,0.47418e-05 , &
9922 0.48153e-05 ,0.48894e-05 ,0.49639e-05 ,0.50389e-05 ,0.51143e-05 /)
9923 totplnk(51:100, 2) = (/ &
9924 0.51902e-05 ,0.52666e-05 ,0.53434e-05 ,0.54207e-05 ,0.54985e-05 , &
9925 0.55767e-05 ,0.56553e-05 ,0.57343e-05 ,0.58139e-05 ,0.58938e-05 , &
9926 0.59742e-05 ,0.60550e-05 ,0.61362e-05 ,0.62179e-05 ,0.63000e-05 , &
9927 0.63825e-05 ,0.64654e-05 ,0.65487e-05 ,0.66324e-05 ,0.67166e-05 , &
9928 0.68011e-05 ,0.68860e-05 ,0.69714e-05 ,0.70571e-05 ,0.71432e-05 , &
9929 0.72297e-05 ,0.73166e-05 ,0.74039e-05 ,0.74915e-05 ,0.75796e-05 , &
9930 0.76680e-05 ,0.77567e-05 ,0.78459e-05 ,0.79354e-05 ,0.80252e-05 , &
9931 0.81155e-05 ,0.82061e-05 ,0.82970e-05 ,0.83883e-05 ,0.84799e-05 , &
9932 0.85719e-05 ,0.86643e-05 ,0.87569e-05 ,0.88499e-05 ,0.89433e-05 , &
9933 0.90370e-05 ,0.91310e-05 ,0.92254e-05 ,0.93200e-05 ,0.94150e-05 /)
9934 totplnk(101:150, 2) = (/ &
9935 0.95104e-05 ,0.96060e-05 ,0.97020e-05 ,0.97982e-05 ,0.98948e-05 , &
9936 0.99917e-05 ,0.10089e-04 ,0.10186e-04 ,0.10284e-04 ,0.10382e-04 , &
9937 0.10481e-04 ,0.10580e-04 ,0.10679e-04 ,0.10778e-04 ,0.10877e-04 , &
9938 0.10977e-04 ,0.11077e-04 ,0.11178e-04 ,0.11279e-04 ,0.11380e-04 , &
9939 0.11481e-04 ,0.11583e-04 ,0.11684e-04 ,0.11786e-04 ,0.11889e-04 , &
9940 0.11992e-04 ,0.12094e-04 ,0.12198e-04 ,0.12301e-04 ,0.12405e-04 , &
9941 0.12509e-04 ,0.12613e-04 ,0.12717e-04 ,0.12822e-04 ,0.12927e-04 , &
9942 0.13032e-04 ,0.13138e-04 ,0.13244e-04 ,0.13349e-04 ,0.13456e-04 , &
9943 0.13562e-04 ,0.13669e-04 ,0.13776e-04 ,0.13883e-04 ,0.13990e-04 , &
9944 0.14098e-04 ,0.14206e-04 ,0.14314e-04 ,0.14422e-04 ,0.14531e-04 /)
9945 totplnk(151:181, 2) = (/ &
9946 0.14639e-04 ,0.14748e-04 ,0.14857e-04 ,0.14967e-04 ,0.15076e-04 , &
9947 0.15186e-04 ,0.15296e-04 ,0.15407e-04 ,0.15517e-04 ,0.15628e-04 , &
9948 0.15739e-04 ,0.15850e-04 ,0.15961e-04 ,0.16072e-04 ,0.16184e-04 , &
9949 0.16296e-04 ,0.16408e-04 ,0.16521e-04 ,0.16633e-04 ,0.16746e-04 , &
9950 0.16859e-04 ,0.16972e-04 ,0.17085e-04 ,0.17198e-04 ,0.17312e-04 , &
9951 0.17426e-04 ,0.17540e-04 ,0.17654e-04 ,0.17769e-04 ,0.17883e-04 , &
9953 totplnk(1:50, 3) = (/ &
9954 1.34822e-06 ,1.39134e-06 ,1.43530e-06 ,1.48010e-06 ,1.52574e-06 , &
9955 1.57222e-06 ,1.61956e-06 ,1.66774e-06 ,1.71678e-06 ,1.76666e-06 , &
9956 1.81741e-06 ,1.86901e-06 ,1.92147e-06 ,1.97479e-06 ,2.02898e-06 , &
9957 2.08402e-06 ,2.13993e-06 ,2.19671e-06 ,2.25435e-06 ,2.31285e-06 , &
9958 2.37222e-06 ,2.43246e-06 ,2.49356e-06 ,2.55553e-06 ,2.61837e-06 , &
9959 2.68207e-06 ,2.74664e-06 ,2.81207e-06 ,2.87837e-06 ,2.94554e-06 , &
9960 3.01356e-06 ,3.08245e-06 ,3.15221e-06 ,3.22282e-06 ,3.29429e-06 , &
9961 3.36662e-06 ,3.43982e-06 ,3.51386e-06 ,3.58876e-06 ,3.66451e-06 , &
9962 3.74112e-06 ,3.81857e-06 ,3.89688e-06 ,3.97602e-06 ,4.05601e-06 , &
9963 4.13685e-06 ,4.21852e-06 ,4.30104e-06 ,4.38438e-06 ,4.46857e-06 /)
9964 totplnk(51:100, 3) = (/ &
9965 4.55358e-06 ,4.63943e-06 ,4.72610e-06 ,4.81359e-06 ,4.90191e-06 , &
9966 4.99105e-06 ,5.08100e-06 ,5.17176e-06 ,5.26335e-06 ,5.35573e-06 , &
9967 5.44892e-06 ,5.54292e-06 ,5.63772e-06 ,5.73331e-06 ,5.82970e-06 , &
9968 5.92688e-06 ,6.02485e-06 ,6.12360e-06 ,6.22314e-06 ,6.32346e-06 , &
9969 6.42455e-06 ,6.52641e-06 ,6.62906e-06 ,6.73247e-06 ,6.83664e-06 , &
9970 6.94156e-06 ,7.04725e-06 ,7.15370e-06 ,7.26089e-06 ,7.36883e-06 , &
9971 7.47752e-06 ,7.58695e-06 ,7.69712e-06 ,7.80801e-06 ,7.91965e-06 , &
9972 8.03201e-06 ,8.14510e-06 ,8.25891e-06 ,8.37343e-06 ,8.48867e-06 , &
9973 8.60463e-06 ,8.72128e-06 ,8.83865e-06 ,8.95672e-06 ,9.07548e-06 , &
9974 9.19495e-06 ,9.31510e-06 ,9.43594e-06 ,9.55745e-06 ,9.67966e-06 /)
9975 totplnk(101:150, 3) = (/ &
9976 9.80254e-06 ,9.92609e-06 ,1.00503e-05 ,1.01752e-05 ,1.03008e-05 , &
9977 1.04270e-05 ,1.05539e-05 ,1.06814e-05 ,1.08096e-05 ,1.09384e-05 , &
9978 1.10679e-05 ,1.11980e-05 ,1.13288e-05 ,1.14601e-05 ,1.15922e-05 , &
9979 1.17248e-05 ,1.18581e-05 ,1.19920e-05 ,1.21265e-05 ,1.22616e-05 , &
9980 1.23973e-05 ,1.25337e-05 ,1.26706e-05 ,1.28081e-05 ,1.29463e-05 , &
9981 1.30850e-05 ,1.32243e-05 ,1.33642e-05 ,1.35047e-05 ,1.36458e-05 , &
9982 1.37875e-05 ,1.39297e-05 ,1.40725e-05 ,1.42159e-05 ,1.43598e-05 , &
9983 1.45044e-05 ,1.46494e-05 ,1.47950e-05 ,1.49412e-05 ,1.50879e-05 , &
9984 1.52352e-05 ,1.53830e-05 ,1.55314e-05 ,1.56803e-05 ,1.58297e-05 , &
9985 1.59797e-05 ,1.61302e-05 ,1.62812e-05 ,1.64327e-05 ,1.65848e-05 /)
9986 totplnk(151:181, 3) = (/ &
9987 1.67374e-05 ,1.68904e-05 ,1.70441e-05 ,1.71982e-05 ,1.73528e-05 , &
9988 1.75079e-05 ,1.76635e-05 ,1.78197e-05 ,1.79763e-05 ,1.81334e-05 , &
9989 1.82910e-05 ,1.84491e-05 ,1.86076e-05 ,1.87667e-05 ,1.89262e-05 , &
9990 1.90862e-05 ,1.92467e-05 ,1.94076e-05 ,1.95690e-05 ,1.97309e-05 , &
9991 1.98932e-05 ,2.00560e-05 ,2.02193e-05 ,2.03830e-05 ,2.05472e-05 , &
9992 2.07118e-05 ,2.08768e-05 ,2.10423e-05 ,2.12083e-05 ,2.13747e-05 , &
9994 totplnk(1:50, 4) = (/ &
9995 8.90528e-07 ,9.24222e-07 ,9.58757e-07 ,9.94141e-07 ,1.03038e-06 , &
9996 1.06748e-06 ,1.10545e-06 ,1.14430e-06 ,1.18403e-06 ,1.22465e-06 , &
9997 1.26618e-06 ,1.30860e-06 ,1.35193e-06 ,1.39619e-06 ,1.44136e-06 , &
9998 1.48746e-06 ,1.53449e-06 ,1.58246e-06 ,1.63138e-06 ,1.68124e-06 , &
9999 1.73206e-06 ,1.78383e-06 ,1.83657e-06 ,1.89028e-06 ,1.94495e-06 , &
10000 2.00060e-06 ,2.05724e-06 ,2.11485e-06 ,2.17344e-06 ,2.23303e-06 , &
10001 2.29361e-06 ,2.35519e-06 ,2.41777e-06 ,2.48134e-06 ,2.54592e-06 , &
10002 2.61151e-06 ,2.67810e-06 ,2.74571e-06 ,2.81433e-06 ,2.88396e-06 , &
10003 2.95461e-06 ,3.02628e-06 ,3.09896e-06 ,3.17267e-06 ,3.24741e-06 , &
10004 3.32316e-06 ,3.39994e-06 ,3.47774e-06 ,3.55657e-06 ,3.63642e-06 /)
10005 totplnk(51:100, 4) = (/ &
10006 3.71731e-06 ,3.79922e-06 ,3.88216e-06 ,3.96612e-06 ,4.05112e-06 , &
10007 4.13714e-06 ,4.22419e-06 ,4.31227e-06 ,4.40137e-06 ,4.49151e-06 , &
10008 4.58266e-06 ,4.67485e-06 ,4.76806e-06 ,4.86229e-06 ,4.95754e-06 , &
10009 5.05383e-06 ,5.15113e-06 ,5.24946e-06 ,5.34879e-06 ,5.44916e-06 , &
10010 5.55053e-06 ,5.65292e-06 ,5.75632e-06 ,5.86073e-06 ,5.96616e-06 , &
10011 6.07260e-06 ,6.18003e-06 ,6.28848e-06 ,6.39794e-06 ,6.50838e-06 , &
10012 6.61983e-06 ,6.73229e-06 ,6.84573e-06 ,6.96016e-06 ,7.07559e-06 , &
10013 7.19200e-06 ,7.30940e-06 ,7.42779e-06 ,7.54715e-06 ,7.66749e-06 , &
10014 7.78882e-06 ,7.91110e-06 ,8.03436e-06 ,8.15859e-06 ,8.28379e-06 , &
10015 8.40994e-06 ,8.53706e-06 ,8.66515e-06 ,8.79418e-06 ,8.92416e-06 /)
10016 totplnk(101:150, 4) = (/ &
10017 9.05510e-06 ,9.18697e-06 ,9.31979e-06 ,9.45356e-06 ,9.58826e-06 , &
10018 9.72389e-06 ,9.86046e-06 ,9.99793e-06 ,1.01364e-05 ,1.02757e-05 , &
10019 1.04159e-05 ,1.05571e-05 ,1.06992e-05 ,1.08422e-05 ,1.09861e-05 , &
10020 1.11309e-05 ,1.12766e-05 ,1.14232e-05 ,1.15707e-05 ,1.17190e-05 , &
10021 1.18683e-05 ,1.20184e-05 ,1.21695e-05 ,1.23214e-05 ,1.24741e-05 , &
10022 1.26277e-05 ,1.27822e-05 ,1.29376e-05 ,1.30939e-05 ,1.32509e-05 , &
10023 1.34088e-05 ,1.35676e-05 ,1.37273e-05 ,1.38877e-05 ,1.40490e-05 , &
10024 1.42112e-05 ,1.43742e-05 ,1.45380e-05 ,1.47026e-05 ,1.48680e-05 , &
10025 1.50343e-05 ,1.52014e-05 ,1.53692e-05 ,1.55379e-05 ,1.57074e-05 , &
10026 1.58778e-05 ,1.60488e-05 ,1.62207e-05 ,1.63934e-05 ,1.65669e-05 /)
10027 totplnk(151:181, 4) = (/ &
10028 1.67411e-05 ,1.69162e-05 ,1.70920e-05 ,1.72685e-05 ,1.74459e-05 , &
10029 1.76240e-05 ,1.78029e-05 ,1.79825e-05 ,1.81629e-05 ,1.83440e-05 , &
10030 1.85259e-05 ,1.87086e-05 ,1.88919e-05 ,1.90760e-05 ,1.92609e-05 , &
10031 1.94465e-05 ,1.96327e-05 ,1.98199e-05 ,2.00076e-05 ,2.01961e-05 , &
10032 2.03853e-05 ,2.05752e-05 ,2.07658e-05 ,2.09571e-05 ,2.11491e-05 , &
10033 2.13418e-05 ,2.15352e-05 ,2.17294e-05 ,2.19241e-05 ,2.21196e-05 , &
10035 totplnk(1:50, 5) = (/ &
10036 5.70230e-07 ,5.94788e-07 ,6.20085e-07 ,6.46130e-07 ,6.72936e-07 , &
10037 7.00512e-07 ,7.28869e-07 ,7.58019e-07 ,7.87971e-07 ,8.18734e-07 , &
10038 8.50320e-07 ,8.82738e-07 ,9.15999e-07 ,9.50110e-07 ,9.85084e-07 , &
10039 1.02093e-06 ,1.05765e-06 ,1.09527e-06 ,1.13378e-06 ,1.17320e-06 , &
10040 1.21353e-06 ,1.25479e-06 ,1.29698e-06 ,1.34011e-06 ,1.38419e-06 , &
10041 1.42923e-06 ,1.47523e-06 ,1.52221e-06 ,1.57016e-06 ,1.61910e-06 , &
10042 1.66904e-06 ,1.71997e-06 ,1.77192e-06 ,1.82488e-06 ,1.87886e-06 , &
10043 1.93387e-06 ,1.98991e-06 ,2.04699e-06 ,2.10512e-06 ,2.16430e-06 , &
10044 2.22454e-06 ,2.28584e-06 ,2.34821e-06 ,2.41166e-06 ,2.47618e-06 , &
10045 2.54178e-06 ,2.60847e-06 ,2.67626e-06 ,2.74514e-06 ,2.81512e-06 /)
10046 totplnk(51:100, 5) = (/ &
10047 2.88621e-06 ,2.95841e-06 ,3.03172e-06 ,3.10615e-06 ,3.18170e-06 , &
10048 3.25838e-06 ,3.33618e-06 ,3.41511e-06 ,3.49518e-06 ,3.57639e-06 , &
10049 3.65873e-06 ,3.74221e-06 ,3.82684e-06 ,3.91262e-06 ,3.99955e-06 , &
10050 4.08763e-06 ,4.17686e-06 ,4.26725e-06 ,4.35880e-06 ,4.45150e-06 , &
10051 4.54537e-06 ,4.64039e-06 ,4.73659e-06 ,4.83394e-06 ,4.93246e-06 , &
10052 5.03215e-06 ,5.13301e-06 ,5.23504e-06 ,5.33823e-06 ,5.44260e-06 , &
10053 5.54814e-06 ,5.65484e-06 ,5.76272e-06 ,5.87177e-06 ,5.98199e-06 , &
10054 6.09339e-06 ,6.20596e-06 ,6.31969e-06 ,6.43460e-06 ,6.55068e-06 , &
10055 6.66793e-06 ,6.78636e-06 ,6.90595e-06 ,7.02670e-06 ,7.14863e-06 , &
10056 7.27173e-06 ,7.39599e-06 ,7.52142e-06 ,7.64802e-06 ,7.77577e-06 /)
10057 totplnk(101:150, 5) = (/ &
10058 7.90469e-06 ,8.03477e-06 ,8.16601e-06 ,8.29841e-06 ,8.43198e-06 , &
10059 8.56669e-06 ,8.70256e-06 ,8.83957e-06 ,8.97775e-06 ,9.11706e-06 , &
10060 9.25753e-06 ,9.39915e-06 ,9.54190e-06 ,9.68580e-06 ,9.83085e-06 , &
10061 9.97704e-06 ,1.01243e-05 ,1.02728e-05 ,1.04224e-05 ,1.05731e-05 , &
10062 1.07249e-05 ,1.08779e-05 ,1.10320e-05 ,1.11872e-05 ,1.13435e-05 , &
10063 1.15009e-05 ,1.16595e-05 ,1.18191e-05 ,1.19799e-05 ,1.21418e-05 , &
10064 1.23048e-05 ,1.24688e-05 ,1.26340e-05 ,1.28003e-05 ,1.29676e-05 , &
10065 1.31361e-05 ,1.33056e-05 ,1.34762e-05 ,1.36479e-05 ,1.38207e-05 , &
10066 1.39945e-05 ,1.41694e-05 ,1.43454e-05 ,1.45225e-05 ,1.47006e-05 , &
10067 1.48797e-05 ,1.50600e-05 ,1.52413e-05 ,1.54236e-05 ,1.56070e-05 /)
10068 totplnk(151:181, 5) = (/ &
10069 1.57914e-05 ,1.59768e-05 ,1.61633e-05 ,1.63509e-05 ,1.65394e-05 , &
10070 1.67290e-05 ,1.69197e-05 ,1.71113e-05 ,1.73040e-05 ,1.74976e-05 , &
10071 1.76923e-05 ,1.78880e-05 ,1.80847e-05 ,1.82824e-05 ,1.84811e-05 , &
10072 1.86808e-05 ,1.88814e-05 ,1.90831e-05 ,1.92857e-05 ,1.94894e-05 , &
10073 1.96940e-05 ,1.98996e-05 ,2.01061e-05 ,2.03136e-05 ,2.05221e-05 , &
10074 2.07316e-05 ,2.09420e-05 ,2.11533e-05 ,2.13657e-05 ,2.15789e-05 , &
10076 totplnk(1:50, 6) = (/ &
10077 2.73493e-07 ,2.87408e-07 ,3.01848e-07 ,3.16825e-07 ,3.32352e-07 , &
10078 3.48439e-07 ,3.65100e-07 ,3.82346e-07 ,4.00189e-07 ,4.18641e-07 , &
10079 4.37715e-07 ,4.57422e-07 ,4.77774e-07 ,4.98784e-07 ,5.20464e-07 , &
10080 5.42824e-07 ,5.65879e-07 ,5.89638e-07 ,6.14115e-07 ,6.39320e-07 , &
10081 6.65266e-07 ,6.91965e-07 ,7.19427e-07 ,7.47666e-07 ,7.76691e-07 , &
10082 8.06516e-07 ,8.37151e-07 ,8.68607e-07 ,9.00896e-07 ,9.34029e-07 , &
10083 9.68018e-07 ,1.00287e-06 ,1.03860e-06 ,1.07522e-06 ,1.11274e-06 , &
10084 1.15117e-06 ,1.19052e-06 ,1.23079e-06 ,1.27201e-06 ,1.31418e-06 , &
10085 1.35731e-06 ,1.40141e-06 ,1.44650e-06 ,1.49257e-06 ,1.53965e-06 , &
10086 1.58773e-06 ,1.63684e-06 ,1.68697e-06 ,1.73815e-06 ,1.79037e-06 /)
10087 totplnk(51:100, 6) = (/ &
10088 1.84365e-06 ,1.89799e-06 ,1.95341e-06 ,2.00991e-06 ,2.06750e-06 , &
10089 2.12619e-06 ,2.18599e-06 ,2.24691e-06 ,2.30895e-06 ,2.37212e-06 , &
10090 2.43643e-06 ,2.50189e-06 ,2.56851e-06 ,2.63628e-06 ,2.70523e-06 , &
10091 2.77536e-06 ,2.84666e-06 ,2.91916e-06 ,2.99286e-06 ,3.06776e-06 , &
10092 3.14387e-06 ,3.22120e-06 ,3.29975e-06 ,3.37953e-06 ,3.46054e-06 , &
10093 3.54280e-06 ,3.62630e-06 ,3.71105e-06 ,3.79707e-06 ,3.88434e-06 , &
10094 3.97288e-06 ,4.06270e-06 ,4.15380e-06 ,4.24617e-06 ,4.33984e-06 , &
10095 4.43479e-06 ,4.53104e-06 ,4.62860e-06 ,4.72746e-06 ,4.82763e-06 , &
10096 4.92911e-06 ,5.03191e-06 ,5.13603e-06 ,5.24147e-06 ,5.34824e-06 , &
10097 5.45634e-06 ,5.56578e-06 ,5.67656e-06 ,5.78867e-06 ,5.90213e-06 /)
10098 totplnk(101:150, 6) = (/ &
10099 6.01694e-06 ,6.13309e-06 ,6.25060e-06 ,6.36947e-06 ,6.48968e-06 , &
10100 6.61126e-06 ,6.73420e-06 ,6.85850e-06 ,6.98417e-06 ,7.11120e-06 , &
10101 7.23961e-06 ,7.36938e-06 ,7.50053e-06 ,7.63305e-06 ,7.76694e-06 , &
10102 7.90221e-06 ,8.03887e-06 ,8.17690e-06 ,8.31632e-06 ,8.45710e-06 , &
10103 8.59928e-06 ,8.74282e-06 ,8.88776e-06 ,9.03409e-06 ,9.18179e-06 , &
10104 9.33088e-06 ,9.48136e-06 ,9.63323e-06 ,9.78648e-06 ,9.94111e-06 , &
10105 1.00971e-05 ,1.02545e-05 ,1.04133e-05 ,1.05735e-05 ,1.07351e-05 , &
10106 1.08980e-05 ,1.10624e-05 ,1.12281e-05 ,1.13952e-05 ,1.15637e-05 , &
10107 1.17335e-05 ,1.19048e-05 ,1.20774e-05 ,1.22514e-05 ,1.24268e-05 , &
10108 1.26036e-05 ,1.27817e-05 ,1.29612e-05 ,1.31421e-05 ,1.33244e-05 /)
10109 totplnk(151:181, 6) = (/ &
10110 1.35080e-05 ,1.36930e-05 ,1.38794e-05 ,1.40672e-05 ,1.42563e-05 , &
10111 1.44468e-05 ,1.46386e-05 ,1.48318e-05 ,1.50264e-05 ,1.52223e-05 , &
10112 1.54196e-05 ,1.56182e-05 ,1.58182e-05 ,1.60196e-05 ,1.62223e-05 , &
10113 1.64263e-05 ,1.66317e-05 ,1.68384e-05 ,1.70465e-05 ,1.72559e-05 , &
10114 1.74666e-05 ,1.76787e-05 ,1.78921e-05 ,1.81069e-05 ,1.83230e-05 , &
10115 1.85404e-05 ,1.87591e-05 ,1.89791e-05 ,1.92005e-05 ,1.94232e-05 , &
10117 totplnk(1:50, 7) = (/ &
10118 1.25349e-07 ,1.32735e-07 ,1.40458e-07 ,1.48527e-07 ,1.56954e-07 , &
10119 1.65748e-07 ,1.74920e-07 ,1.84481e-07 ,1.94443e-07 ,2.04814e-07 , &
10120 2.15608e-07 ,2.26835e-07 ,2.38507e-07 ,2.50634e-07 ,2.63229e-07 , &
10121 2.76301e-07 ,2.89864e-07 ,3.03930e-07 ,3.18508e-07 ,3.33612e-07 , &
10122 3.49253e-07 ,3.65443e-07 ,3.82195e-07 ,3.99519e-07 ,4.17428e-07 , &
10123 4.35934e-07 ,4.55050e-07 ,4.74785e-07 ,4.95155e-07 ,5.16170e-07 , &
10124 5.37844e-07 ,5.60186e-07 ,5.83211e-07 ,6.06929e-07 ,6.31355e-07 , &
10125 6.56498e-07 ,6.82373e-07 ,7.08990e-07 ,7.36362e-07 ,7.64501e-07 , &
10126 7.93420e-07 ,8.23130e-07 ,8.53643e-07 ,8.84971e-07 ,9.17128e-07 , &
10127 9.50123e-07 ,9.83969e-07 ,1.01868e-06 ,1.05426e-06 ,1.09073e-06 /)
10128 totplnk(51:100, 7) = (/ &
10129 1.12810e-06 ,1.16638e-06 ,1.20558e-06 ,1.24572e-06 ,1.28680e-06 , &
10130 1.32883e-06 ,1.37183e-06 ,1.41581e-06 ,1.46078e-06 ,1.50675e-06 , &
10131 1.55374e-06 ,1.60174e-06 ,1.65078e-06 ,1.70087e-06 ,1.75200e-06 , &
10132 1.80421e-06 ,1.85749e-06 ,1.91186e-06 ,1.96732e-06 ,2.02389e-06 , &
10133 2.08159e-06 ,2.14040e-06 ,2.20035e-06 ,2.26146e-06 ,2.32372e-06 , &
10134 2.38714e-06 ,2.45174e-06 ,2.51753e-06 ,2.58451e-06 ,2.65270e-06 , &
10135 2.72210e-06 ,2.79272e-06 ,2.86457e-06 ,2.93767e-06 ,3.01201e-06 , &
10136 3.08761e-06 ,3.16448e-06 ,3.24261e-06 ,3.32204e-06 ,3.40275e-06 , &
10137 3.48476e-06 ,3.56808e-06 ,3.65271e-06 ,3.73866e-06 ,3.82595e-06 , &
10138 3.91456e-06 ,4.00453e-06 ,4.09584e-06 ,4.18851e-06 ,4.28254e-06 /)
10139 totplnk(101:150, 7) = (/ &
10140 4.37796e-06 ,4.47475e-06 ,4.57293e-06 ,4.67249e-06 ,4.77346e-06 , &
10141 4.87583e-06 ,4.97961e-06 ,5.08481e-06 ,5.19143e-06 ,5.29948e-06 , &
10142 5.40896e-06 ,5.51989e-06 ,5.63226e-06 ,5.74608e-06 ,5.86136e-06 , &
10143 5.97810e-06 ,6.09631e-06 ,6.21597e-06 ,6.33713e-06 ,6.45976e-06 , &
10144 6.58388e-06 ,6.70950e-06 ,6.83661e-06 ,6.96521e-06 ,7.09531e-06 , &
10145 7.22692e-06 ,7.36005e-06 ,7.49468e-06 ,7.63084e-06 ,7.76851e-06 , &
10146 7.90773e-06 ,8.04846e-06 ,8.19072e-06 ,8.33452e-06 ,8.47985e-06 , &
10147 8.62674e-06 ,8.77517e-06 ,8.92514e-06 ,9.07666e-06 ,9.22975e-06 , &
10148 9.38437e-06 ,9.54057e-06 ,9.69832e-06 ,9.85762e-06 ,1.00185e-05 , &
10149 1.01810e-05 ,1.03450e-05 ,1.05106e-05 ,1.06777e-05 ,1.08465e-05 /)
10150 totplnk(151:181, 7) = (/ &
10151 1.10168e-05 ,1.11887e-05 ,1.13621e-05 ,1.15372e-05 ,1.17138e-05 , &
10152 1.18920e-05 ,1.20718e-05 ,1.22532e-05 ,1.24362e-05 ,1.26207e-05 , &
10153 1.28069e-05 ,1.29946e-05 ,1.31839e-05 ,1.33749e-05 ,1.35674e-05 , &
10154 1.37615e-05 ,1.39572e-05 ,1.41544e-05 ,1.43533e-05 ,1.45538e-05 , &
10155 1.47558e-05 ,1.49595e-05 ,1.51647e-05 ,1.53716e-05 ,1.55800e-05 , &
10156 1.57900e-05 ,1.60017e-05 ,1.62149e-05 ,1.64296e-05 ,1.66460e-05 , &
10158 totplnk(1:50, 8) = (/ &
10159 6.74445e-08 ,7.18176e-08 ,7.64153e-08 ,8.12456e-08 ,8.63170e-08 , &
10160 9.16378e-08 ,9.72168e-08 ,1.03063e-07 ,1.09184e-07 ,1.15591e-07 , &
10161 1.22292e-07 ,1.29296e-07 ,1.36613e-07 ,1.44253e-07 ,1.52226e-07 , &
10162 1.60540e-07 ,1.69207e-07 ,1.78236e-07 ,1.87637e-07 ,1.97421e-07 , &
10163 2.07599e-07 ,2.18181e-07 ,2.29177e-07 ,2.40598e-07 ,2.52456e-07 , &
10164 2.64761e-07 ,2.77523e-07 ,2.90755e-07 ,3.04468e-07 ,3.18673e-07 , &
10165 3.33381e-07 ,3.48603e-07 ,3.64352e-07 ,3.80638e-07 ,3.97474e-07 , &
10166 4.14871e-07 ,4.32841e-07 ,4.51395e-07 ,4.70547e-07 ,4.90306e-07 , &
10167 5.10687e-07 ,5.31699e-07 ,5.53357e-07 ,5.75670e-07 ,5.98652e-07 , &
10168 6.22315e-07 ,6.46672e-07 ,6.71731e-07 ,6.97511e-07 ,7.24018e-07 /)
10169 totplnk(51:100, 8) = (/ &
10170 7.51266e-07 ,7.79269e-07 ,8.08038e-07 ,8.37584e-07 ,8.67922e-07 , &
10171 8.99061e-07 ,9.31016e-07 ,9.63797e-07 ,9.97417e-07 ,1.03189e-06 , &
10172 1.06722e-06 ,1.10343e-06 ,1.14053e-06 ,1.17853e-06 ,1.21743e-06 , &
10173 1.25726e-06 ,1.29803e-06 ,1.33974e-06 ,1.38241e-06 ,1.42606e-06 , &
10174 1.47068e-06 ,1.51630e-06 ,1.56293e-06 ,1.61056e-06 ,1.65924e-06 , &
10175 1.70894e-06 ,1.75971e-06 ,1.81153e-06 ,1.86443e-06 ,1.91841e-06 , &
10176 1.97350e-06 ,2.02968e-06 ,2.08699e-06 ,2.14543e-06 ,2.20500e-06 , &
10177 2.26573e-06 ,2.32762e-06 ,2.39068e-06 ,2.45492e-06 ,2.52036e-06 , &
10178 2.58700e-06 ,2.65485e-06 ,2.72393e-06 ,2.79424e-06 ,2.86580e-06 , &
10179 2.93861e-06 ,3.01269e-06 ,3.08803e-06 ,3.16467e-06 ,3.24259e-06 /)
10180 totplnk(101:150, 8) = (/ &
10181 3.32181e-06 ,3.40235e-06 ,3.48420e-06 ,3.56739e-06 ,3.65192e-06 , &
10182 3.73779e-06 ,3.82502e-06 ,3.91362e-06 ,4.00359e-06 ,4.09494e-06 , &
10183 4.18768e-06 ,4.28182e-06 ,4.37737e-06 ,4.47434e-06 ,4.57273e-06 , &
10184 4.67254e-06 ,4.77380e-06 ,4.87651e-06 ,4.98067e-06 ,5.08630e-06 , &
10185 5.19339e-06 ,5.30196e-06 ,5.41201e-06 ,5.52356e-06 ,5.63660e-06 , &
10186 5.75116e-06 ,5.86722e-06 ,5.98479e-06 ,6.10390e-06 ,6.22453e-06 , &
10187 6.34669e-06 ,6.47042e-06 ,6.59569e-06 ,6.72252e-06 ,6.85090e-06 , &
10188 6.98085e-06 ,7.11238e-06 ,7.24549e-06 ,7.38019e-06 ,7.51646e-06 , &
10189 7.65434e-06 ,7.79382e-06 ,7.93490e-06 ,8.07760e-06 ,8.22192e-06 , &
10190 8.36784e-06 ,8.51540e-06 ,8.66459e-06 ,8.81542e-06 ,8.96786e-06 /)
10191 totplnk(151:181, 8) = (/ &
10192 9.12197e-06 ,9.27772e-06 ,9.43513e-06 ,9.59419e-06 ,9.75490e-06 , &
10193 9.91728e-06 ,1.00813e-05 ,1.02471e-05 ,1.04144e-05 ,1.05835e-05 , &
10194 1.07543e-05 ,1.09267e-05 ,1.11008e-05 ,1.12766e-05 ,1.14541e-05 , &
10195 1.16333e-05 ,1.18142e-05 ,1.19969e-05 ,1.21812e-05 ,1.23672e-05 , &
10196 1.25549e-05 ,1.27443e-05 ,1.29355e-05 ,1.31284e-05 ,1.33229e-05 , &
10197 1.35193e-05 ,1.37173e-05 ,1.39170e-05 ,1.41185e-05 ,1.43217e-05 , &
10199 totplnk(1:50, 9) = (/ &
10200 2.61522e-08 ,2.80613e-08 ,3.00838e-08 ,3.22250e-08 ,3.44899e-08 , &
10201 3.68841e-08 ,3.94129e-08 ,4.20820e-08 ,4.48973e-08 ,4.78646e-08 , &
10202 5.09901e-08 ,5.42799e-08 ,5.77405e-08 ,6.13784e-08 ,6.52001e-08 , &
10203 6.92126e-08 ,7.34227e-08 ,7.78375e-08 ,8.24643e-08 ,8.73103e-08 , &
10204 9.23832e-08 ,9.76905e-08 ,1.03240e-07 ,1.09039e-07 ,1.15097e-07 , &
10205 1.21421e-07 ,1.28020e-07 ,1.34902e-07 ,1.42075e-07 ,1.49548e-07 , &
10206 1.57331e-07 ,1.65432e-07 ,1.73860e-07 ,1.82624e-07 ,1.91734e-07 , &
10207 2.01198e-07 ,2.11028e-07 ,2.21231e-07 ,2.31818e-07 ,2.42799e-07 , &
10208 2.54184e-07 ,2.65983e-07 ,2.78205e-07 ,2.90862e-07 ,3.03963e-07 , &
10209 3.17519e-07 ,3.31541e-07 ,3.46039e-07 ,3.61024e-07 ,3.76507e-07 /)
10210 totplnk(51:100, 9) = (/ &
10211 3.92498e-07 ,4.09008e-07 ,4.26050e-07 ,4.43633e-07 ,4.61769e-07 , &
10212 4.80469e-07 ,4.99744e-07 ,5.19606e-07 ,5.40067e-07 ,5.61136e-07 , &
10213 5.82828e-07 ,6.05152e-07 ,6.28120e-07 ,6.51745e-07 ,6.76038e-07 , &
10214 7.01010e-07 ,7.26674e-07 ,7.53041e-07 ,7.80124e-07 ,8.07933e-07 , &
10215 8.36482e-07 ,8.65781e-07 ,8.95845e-07 ,9.26683e-07 ,9.58308e-07 , &
10216 9.90732e-07 ,1.02397e-06 ,1.05803e-06 ,1.09292e-06 ,1.12866e-06 , &
10217 1.16526e-06 ,1.20274e-06 ,1.24109e-06 ,1.28034e-06 ,1.32050e-06 , &
10218 1.36158e-06 ,1.40359e-06 ,1.44655e-06 ,1.49046e-06 ,1.53534e-06 , &
10219 1.58120e-06 ,1.62805e-06 ,1.67591e-06 ,1.72478e-06 ,1.77468e-06 , &
10220 1.82561e-06 ,1.87760e-06 ,1.93066e-06 ,1.98479e-06 ,2.04000e-06 /)
10221 totplnk(101:150, 9) = (/ &
10222 2.09631e-06 ,2.15373e-06 ,2.21228e-06 ,2.27196e-06 ,2.33278e-06 , &
10223 2.39475e-06 ,2.45790e-06 ,2.52222e-06 ,2.58773e-06 ,2.65445e-06 , &
10224 2.72238e-06 ,2.79152e-06 ,2.86191e-06 ,2.93354e-06 ,3.00643e-06 , &
10225 3.08058e-06 ,3.15601e-06 ,3.23273e-06 ,3.31075e-06 ,3.39009e-06 , &
10226 3.47074e-06 ,3.55272e-06 ,3.63605e-06 ,3.72072e-06 ,3.80676e-06 , &
10227 3.89417e-06 ,3.98297e-06 ,4.07315e-06 ,4.16474e-06 ,4.25774e-06 , &
10228 4.35217e-06 ,4.44802e-06 ,4.54532e-06 ,4.64406e-06 ,4.74428e-06 , &
10229 4.84595e-06 ,4.94911e-06 ,5.05376e-06 ,5.15990e-06 ,5.26755e-06 , &
10230 5.37671e-06 ,5.48741e-06 ,5.59963e-06 ,5.71340e-06 ,5.82871e-06 , &
10231 5.94559e-06 ,6.06403e-06 ,6.18404e-06 ,6.30565e-06 ,6.42885e-06 /)
10232 totplnk(151:181, 9) = (/ &
10233 6.55364e-06 ,6.68004e-06 ,6.80806e-06 ,6.93771e-06 ,7.06898e-06 , &
10234 7.20190e-06 ,7.33646e-06 ,7.47267e-06 ,7.61056e-06 ,7.75010e-06 , &
10235 7.89133e-06 ,8.03423e-06 ,8.17884e-06 ,8.32514e-06 ,8.47314e-06 , &
10236 8.62284e-06 ,8.77427e-06 ,8.92743e-06 ,9.08231e-06 ,9.23893e-06 , &
10237 9.39729e-06 ,9.55741e-06 ,9.71927e-06 ,9.88291e-06 ,1.00483e-05 , &
10238 1.02155e-05 ,1.03844e-05 ,1.05552e-05 ,1.07277e-05 ,1.09020e-05 , &
10240 totplnk(1:50,10) = (/ &
10241 8.89300e-09 ,9.63263e-09 ,1.04235e-08 ,1.12685e-08 ,1.21703e-08 , &
10242 1.31321e-08 ,1.41570e-08 ,1.52482e-08 ,1.64090e-08 ,1.76428e-08 , &
10243 1.89533e-08 ,2.03441e-08 ,2.18190e-08 ,2.33820e-08 ,2.50370e-08 , &
10244 2.67884e-08 ,2.86402e-08 ,3.05969e-08 ,3.26632e-08 ,3.48436e-08 , &
10245 3.71429e-08 ,3.95660e-08 ,4.21179e-08 ,4.48040e-08 ,4.76294e-08 , &
10246 5.05996e-08 ,5.37201e-08 ,5.69966e-08 ,6.04349e-08 ,6.40411e-08 , &
10247 6.78211e-08 ,7.17812e-08 ,7.59276e-08 ,8.02670e-08 ,8.48059e-08 , &
10248 8.95508e-08 ,9.45090e-08 ,9.96873e-08 ,1.05093e-07 ,1.10733e-07 , &
10249 1.16614e-07 ,1.22745e-07 ,1.29133e-07 ,1.35786e-07 ,1.42711e-07 , &
10250 1.49916e-07 ,1.57410e-07 ,1.65202e-07 ,1.73298e-07 ,1.81709e-07 /)
10251 totplnk(51:100,10) = (/ &
10252 1.90441e-07 ,1.99505e-07 ,2.08908e-07 ,2.18660e-07 ,2.28770e-07 , &
10253 2.39247e-07 ,2.50101e-07 ,2.61340e-07 ,2.72974e-07 ,2.85013e-07 , &
10254 2.97467e-07 ,3.10345e-07 ,3.23657e-07 ,3.37413e-07 ,3.51623e-07 , &
10255 3.66298e-07 ,3.81448e-07 ,3.97082e-07 ,4.13212e-07 ,4.29848e-07 , &
10256 4.47000e-07 ,4.64680e-07 ,4.82898e-07 ,5.01664e-07 ,5.20991e-07 , &
10257 5.40888e-07 ,5.61369e-07 ,5.82440e-07 ,6.04118e-07 ,6.26410e-07 , &
10258 6.49329e-07 ,6.72887e-07 ,6.97095e-07 ,7.21964e-07 ,7.47506e-07 , &
10259 7.73732e-07 ,8.00655e-07 ,8.28287e-07 ,8.56635e-07 ,8.85717e-07 , &
10260 9.15542e-07 ,9.46122e-07 ,9.77469e-07 ,1.00960e-06 ,1.04251e-06 , &
10261 1.07623e-06 ,1.11077e-06 ,1.14613e-06 ,1.18233e-06 ,1.21939e-06 /)
10262 totplnk(101:150,10) = (/ &
10263 1.25730e-06 ,1.29610e-06 ,1.33578e-06 ,1.37636e-06 ,1.41785e-06 , &
10264 1.46027e-06 ,1.50362e-06 ,1.54792e-06 ,1.59319e-06 ,1.63942e-06 , &
10265 1.68665e-06 ,1.73487e-06 ,1.78410e-06 ,1.83435e-06 ,1.88564e-06 , &
10266 1.93797e-06 ,1.99136e-06 ,2.04582e-06 ,2.10137e-06 ,2.15801e-06 , &
10267 2.21576e-06 ,2.27463e-06 ,2.33462e-06 ,2.39577e-06 ,2.45806e-06 , &
10268 2.52153e-06 ,2.58617e-06 ,2.65201e-06 ,2.71905e-06 ,2.78730e-06 , &
10269 2.85678e-06 ,2.92749e-06 ,2.99946e-06 ,3.07269e-06 ,3.14720e-06 , &
10270 3.22299e-06 ,3.30007e-06 ,3.37847e-06 ,3.45818e-06 ,3.53923e-06 , &
10271 3.62161e-06 ,3.70535e-06 ,3.79046e-06 ,3.87695e-06 ,3.96481e-06 , &
10272 4.05409e-06 ,4.14477e-06 ,4.23687e-06 ,4.33040e-06 ,4.42538e-06 /)
10273 totplnk(151:181,10) = (/ &
10274 4.52180e-06 ,4.61969e-06 ,4.71905e-06 ,4.81991e-06 ,4.92226e-06 , &
10275 5.02611e-06 ,5.13148e-06 ,5.23839e-06 ,5.34681e-06 ,5.45681e-06 , &
10276 5.56835e-06 ,5.68146e-06 ,5.79614e-06 ,5.91242e-06 ,6.03030e-06 , &
10277 6.14978e-06 ,6.27088e-06 ,6.39360e-06 ,6.51798e-06 ,6.64398e-06 , &
10278 6.77165e-06 ,6.90099e-06 ,7.03198e-06 ,7.16468e-06 ,7.29906e-06 , &
10279 7.43514e-06 ,7.57294e-06 ,7.71244e-06 ,7.85369e-06 ,7.99666e-06 , &
10281 totplnk(1:50,11) = (/ &
10282 2.53767e-09 ,2.77242e-09 ,3.02564e-09 ,3.29851e-09 ,3.59228e-09 , &
10283 3.90825e-09 ,4.24777e-09 ,4.61227e-09 ,5.00322e-09 ,5.42219e-09 , &
10284 5.87080e-09 ,6.35072e-09 ,6.86370e-09 ,7.41159e-09 ,7.99628e-09 , &
10285 8.61974e-09 ,9.28404e-09 ,9.99130e-09 ,1.07437e-08 ,1.15436e-08 , &
10286 1.23933e-08 ,1.32953e-08 ,1.42522e-08 ,1.52665e-08 ,1.63410e-08 , &
10287 1.74786e-08 ,1.86820e-08 ,1.99542e-08 ,2.12985e-08 ,2.27179e-08 , &
10288 2.42158e-08 ,2.57954e-08 ,2.74604e-08 ,2.92141e-08 ,3.10604e-08 , &
10289 3.30029e-08 ,3.50457e-08 ,3.71925e-08 ,3.94476e-08 ,4.18149e-08 , &
10290 4.42991e-08 ,4.69043e-08 ,4.96352e-08 ,5.24961e-08 ,5.54921e-08 , &
10291 5.86277e-08 ,6.19081e-08 ,6.53381e-08 ,6.89231e-08 ,7.26681e-08 /)
10292 totplnk(51:100,11) = (/ &
10293 7.65788e-08 ,8.06604e-08 ,8.49187e-08 ,8.93591e-08 ,9.39879e-08 , &
10294 9.88106e-08 ,1.03834e-07 ,1.09063e-07 ,1.14504e-07 ,1.20165e-07 , &
10295 1.26051e-07 ,1.32169e-07 ,1.38525e-07 ,1.45128e-07 ,1.51982e-07 , &
10296 1.59096e-07 ,1.66477e-07 ,1.74132e-07 ,1.82068e-07 ,1.90292e-07 , &
10297 1.98813e-07 ,2.07638e-07 ,2.16775e-07 ,2.26231e-07 ,2.36015e-07 , &
10298 2.46135e-07 ,2.56599e-07 ,2.67415e-07 ,2.78592e-07 ,2.90137e-07 , &
10299 3.02061e-07 ,3.14371e-07 ,3.27077e-07 ,3.40186e-07 ,3.53710e-07 , &
10300 3.67655e-07 ,3.82031e-07 ,3.96848e-07 ,4.12116e-07 ,4.27842e-07 , &
10301 4.44039e-07 ,4.60713e-07 ,4.77876e-07 ,4.95537e-07 ,5.13706e-07 , &
10302 5.32392e-07 ,5.51608e-07 ,5.71360e-07 ,5.91662e-07 ,6.12521e-07 /)
10303 totplnk(101:150,11) = (/ &
10304 6.33950e-07 ,6.55958e-07 ,6.78556e-07 ,7.01753e-07 ,7.25562e-07 , &
10305 7.49992e-07 ,7.75055e-07 ,8.00760e-07 ,8.27120e-07 ,8.54145e-07 , &
10306 8.81845e-07 ,9.10233e-07 ,9.39318e-07 ,9.69113e-07 ,9.99627e-07 , &
10307 1.03087e-06 ,1.06286e-06 ,1.09561e-06 ,1.12912e-06 ,1.16340e-06 , &
10308 1.19848e-06 ,1.23435e-06 ,1.27104e-06 ,1.30855e-06 ,1.34690e-06 , &
10309 1.38609e-06 ,1.42614e-06 ,1.46706e-06 ,1.50886e-06 ,1.55155e-06 , &
10310 1.59515e-06 ,1.63967e-06 ,1.68512e-06 ,1.73150e-06 ,1.77884e-06 , &
10311 1.82715e-06 ,1.87643e-06 ,1.92670e-06 ,1.97797e-06 ,2.03026e-06 , &
10312 2.08356e-06 ,2.13791e-06 ,2.19330e-06 ,2.24975e-06 ,2.30728e-06 , &
10313 2.36589e-06 ,2.42560e-06 ,2.48641e-06 ,2.54835e-06 ,2.61142e-06 /)
10314 totplnk(151:181,11) = (/ &
10315 2.67563e-06 ,2.74100e-06 ,2.80754e-06 ,2.87526e-06 ,2.94417e-06 , &
10316 3.01429e-06 ,3.08562e-06 ,3.15819e-06 ,3.23199e-06 ,3.30704e-06 , &
10317 3.38336e-06 ,3.46096e-06 ,3.53984e-06 ,3.62002e-06 ,3.70151e-06 , &
10318 3.78433e-06 ,3.86848e-06 ,3.95399e-06 ,4.04084e-06 ,4.12907e-06 , &
10319 4.21868e-06 ,4.30968e-06 ,4.40209e-06 ,4.49592e-06 ,4.59117e-06 , &
10320 4.68786e-06 ,4.78600e-06 ,4.88561e-06 ,4.98669e-06 ,5.08926e-06 , &
10322 totplnk(1:50,12) = (/ &
10323 2.73921e-10 ,3.04500e-10 ,3.38056e-10 ,3.74835e-10 ,4.15099e-10 , &
10324 4.59126e-10 ,5.07214e-10 ,5.59679e-10 ,6.16857e-10 ,6.79103e-10 , &
10325 7.46796e-10 ,8.20335e-10 ,9.00144e-10 ,9.86671e-10 ,1.08039e-09 , &
10326 1.18180e-09 ,1.29142e-09 ,1.40982e-09 ,1.53757e-09 ,1.67529e-09 , &
10327 1.82363e-09 ,1.98327e-09 ,2.15492e-09 ,2.33932e-09 ,2.53726e-09 , &
10328 2.74957e-09 ,2.97710e-09 ,3.22075e-09 ,3.48145e-09 ,3.76020e-09 , &
10329 4.05801e-09 ,4.37595e-09 ,4.71513e-09 ,5.07672e-09 ,5.46193e-09 , &
10330 5.87201e-09 ,6.30827e-09 ,6.77205e-09 ,7.26480e-09 ,7.78794e-09 , &
10331 8.34304e-09 ,8.93163e-09 ,9.55537e-09 ,1.02159e-08 ,1.09151e-08 , &
10332 1.16547e-08 ,1.24365e-08 ,1.32625e-08 ,1.41348e-08 ,1.50554e-08 /)
10333 totplnk(51:100,12) = (/ &
10334 1.60264e-08 ,1.70500e-08 ,1.81285e-08 ,1.92642e-08 ,2.04596e-08 , &
10335 2.17171e-08 ,2.30394e-08 ,2.44289e-08 ,2.58885e-08 ,2.74209e-08 , &
10336 2.90290e-08 ,3.07157e-08 ,3.24841e-08 ,3.43371e-08 ,3.62782e-08 , &
10337 3.83103e-08 ,4.04371e-08 ,4.26617e-08 ,4.49878e-08 ,4.74190e-08 , &
10338 4.99589e-08 ,5.26113e-08 ,5.53801e-08 ,5.82692e-08 ,6.12826e-08 , &
10339 6.44245e-08 ,6.76991e-08 ,7.11105e-08 ,7.46634e-08 ,7.83621e-08 , &
10340 8.22112e-08 ,8.62154e-08 ,9.03795e-08 ,9.47081e-08 ,9.92066e-08 , &
10341 1.03879e-07 ,1.08732e-07 ,1.13770e-07 ,1.18998e-07 ,1.24422e-07 , &
10342 1.30048e-07 ,1.35880e-07 ,1.41924e-07 ,1.48187e-07 ,1.54675e-07 , &
10343 1.61392e-07 ,1.68346e-07 ,1.75543e-07 ,1.82988e-07 ,1.90688e-07 /)
10344 totplnk(101:150,12) = (/ &
10345 1.98650e-07 ,2.06880e-07 ,2.15385e-07 ,2.24172e-07 ,2.33247e-07 , &
10346 2.42617e-07 ,2.52289e-07 ,2.62272e-07 ,2.72571e-07 ,2.83193e-07 , &
10347 2.94147e-07 ,3.05440e-07 ,3.17080e-07 ,3.29074e-07 ,3.41430e-07 , &
10348 3.54155e-07 ,3.67259e-07 ,3.80747e-07 ,3.94631e-07 ,4.08916e-07 , &
10349 4.23611e-07 ,4.38725e-07 ,4.54267e-07 ,4.70245e-07 ,4.86666e-07 , &
10350 5.03541e-07 ,5.20879e-07 ,5.38687e-07 ,5.56975e-07 ,5.75751e-07 , &
10351 5.95026e-07 ,6.14808e-07 ,6.35107e-07 ,6.55932e-07 ,6.77293e-07 , &
10352 6.99197e-07 ,7.21656e-07 ,7.44681e-07 ,7.68278e-07 ,7.92460e-07 , &
10353 8.17235e-07 ,8.42614e-07 ,8.68606e-07 ,8.95223e-07 ,9.22473e-07 , &
10354 9.50366e-07 ,9.78915e-07 ,1.00813e-06 ,1.03802e-06 ,1.06859e-06 /)
10355 totplnk(151:181,12) = (/ &
10356 1.09986e-06 ,1.13184e-06 ,1.16453e-06 ,1.19796e-06 ,1.23212e-06 , &
10357 1.26703e-06 ,1.30270e-06 ,1.33915e-06 ,1.37637e-06 ,1.41440e-06 , &
10358 1.45322e-06 ,1.49286e-06 ,1.53333e-06 ,1.57464e-06 ,1.61679e-06 , &
10359 1.65981e-06 ,1.70370e-06 ,1.74847e-06 ,1.79414e-06 ,1.84071e-06 , &
10360 1.88821e-06 ,1.93663e-06 ,1.98599e-06 ,2.03631e-06 ,2.08759e-06 , &
10361 2.13985e-06 ,2.19310e-06 ,2.24734e-06 ,2.30260e-06 ,2.35888e-06 , &
10363 totplnk(1:50,13) = (/ &
10364 4.53634e-11 ,5.11435e-11 ,5.75754e-11 ,6.47222e-11 ,7.26531e-11 , &
10365 8.14420e-11 ,9.11690e-11 ,1.01921e-10 ,1.13790e-10 ,1.26877e-10 , &
10366 1.41288e-10 ,1.57140e-10 ,1.74555e-10 ,1.93665e-10 ,2.14613e-10 , &
10367 2.37548e-10 ,2.62633e-10 ,2.90039e-10 ,3.19948e-10 ,3.52558e-10 , &
10368 3.88073e-10 ,4.26716e-10 ,4.68719e-10 ,5.14331e-10 ,5.63815e-10 , &
10369 6.17448e-10 ,6.75526e-10 ,7.38358e-10 ,8.06277e-10 ,8.79625e-10 , &
10370 9.58770e-10 ,1.04410e-09 ,1.13602e-09 ,1.23495e-09 ,1.34135e-09 , &
10371 1.45568e-09 ,1.57845e-09 ,1.71017e-09 ,1.85139e-09 ,2.00268e-09 , &
10372 2.16464e-09 ,2.33789e-09 ,2.52309e-09 ,2.72093e-09 ,2.93212e-09 , &
10373 3.15740e-09 ,3.39757e-09 ,3.65341e-09 ,3.92579e-09 ,4.21559e-09 /)
10374 totplnk(51:100,13) = (/ &
10375 4.52372e-09 ,4.85115e-09 ,5.19886e-09 ,5.56788e-09 ,5.95928e-09 , &
10376 6.37419e-09 ,6.81375e-09 ,7.27917e-09 ,7.77168e-09 ,8.29256e-09 , &
10377 8.84317e-09 ,9.42487e-09 ,1.00391e-08 ,1.06873e-08 ,1.13710e-08 , &
10378 1.20919e-08 ,1.28515e-08 ,1.36514e-08 ,1.44935e-08 ,1.53796e-08 , &
10379 1.63114e-08 ,1.72909e-08 ,1.83201e-08 ,1.94008e-08 ,2.05354e-08 , &
10380 2.17258e-08 ,2.29742e-08 ,2.42830e-08 ,2.56545e-08 ,2.70910e-08 , &
10381 2.85950e-08 ,3.01689e-08 ,3.18155e-08 ,3.35373e-08 ,3.53372e-08 , &
10382 3.72177e-08 ,3.91818e-08 ,4.12325e-08 ,4.33727e-08 ,4.56056e-08 , &
10383 4.79342e-08 ,5.03617e-08 ,5.28915e-08 ,5.55270e-08 ,5.82715e-08 , &
10384 6.11286e-08 ,6.41019e-08 ,6.71951e-08 ,7.04119e-08 ,7.37560e-08 /)
10385 totplnk(101:150,13) = (/ &
10386 7.72315e-08 ,8.08424e-08 ,8.45927e-08 ,8.84866e-08 ,9.25281e-08 , &
10387 9.67218e-08 ,1.01072e-07 ,1.05583e-07 ,1.10260e-07 ,1.15107e-07 , &
10388 1.20128e-07 ,1.25330e-07 ,1.30716e-07 ,1.36291e-07 ,1.42061e-07 , &
10389 1.48031e-07 ,1.54206e-07 ,1.60592e-07 ,1.67192e-07 ,1.74015e-07 , &
10390 1.81064e-07 ,1.88345e-07 ,1.95865e-07 ,2.03628e-07 ,2.11643e-07 , &
10391 2.19912e-07 ,2.28443e-07 ,2.37244e-07 ,2.46318e-07 ,2.55673e-07 , &
10392 2.65316e-07 ,2.75252e-07 ,2.85489e-07 ,2.96033e-07 ,3.06891e-07 , &
10393 3.18070e-07 ,3.29576e-07 ,3.41417e-07 ,3.53600e-07 ,3.66133e-07 , &
10394 3.79021e-07 ,3.92274e-07 ,4.05897e-07 ,4.19899e-07 ,4.34288e-07 , &
10395 4.49071e-07 ,4.64255e-07 ,4.79850e-07 ,4.95863e-07 ,5.12300e-07 /)
10396 totplnk(151:181,13) = (/ &
10397 5.29172e-07 ,5.46486e-07 ,5.64250e-07 ,5.82473e-07 ,6.01164e-07 , &
10398 6.20329e-07 ,6.39979e-07 ,6.60122e-07 ,6.80767e-07 ,7.01922e-07 , &
10399 7.23596e-07 ,7.45800e-07 ,7.68539e-07 ,7.91826e-07 ,8.15669e-07 , &
10400 8.40076e-07 ,8.65058e-07 ,8.90623e-07 ,9.16783e-07 ,9.43544e-07 , &
10401 9.70917e-07 ,9.98912e-07 ,1.02754e-06 ,1.05681e-06 ,1.08673e-06 , &
10402 1.11731e-06 ,1.14856e-06 ,1.18050e-06 ,1.21312e-06 ,1.24645e-06 , &
10404 totplnk(1:50,14) = (/ &
10405 1.40113e-11 ,1.59358e-11 ,1.80960e-11 ,2.05171e-11 ,2.32266e-11 , &
10406 2.62546e-11 ,2.96335e-11 ,3.33990e-11 ,3.75896e-11 ,4.22469e-11 , &
10407 4.74164e-11 ,5.31466e-11 ,5.94905e-11 ,6.65054e-11 ,7.42522e-11 , &
10408 8.27975e-11 ,9.22122e-11 ,1.02573e-10 ,1.13961e-10 ,1.26466e-10 , &
10409 1.40181e-10 ,1.55206e-10 ,1.71651e-10 ,1.89630e-10 ,2.09265e-10 , &
10410 2.30689e-10 ,2.54040e-10 ,2.79467e-10 ,3.07128e-10 ,3.37190e-10 , &
10411 3.69833e-10 ,4.05243e-10 ,4.43623e-10 ,4.85183e-10 ,5.30149e-10 , &
10412 5.78755e-10 ,6.31255e-10 ,6.87910e-10 ,7.49002e-10 ,8.14824e-10 , &
10413 8.85687e-10 ,9.61914e-10 ,1.04385e-09 ,1.13186e-09 ,1.22631e-09 , &
10414 1.32761e-09 ,1.43617e-09 ,1.55243e-09 ,1.67686e-09 ,1.80992e-09 /)
10415 totplnk(51:100,14) = (/ &
10416 1.95212e-09 ,2.10399e-09 ,2.26607e-09 ,2.43895e-09 ,2.62321e-09 , &
10417 2.81949e-09 ,3.02844e-09 ,3.25073e-09 ,3.48707e-09 ,3.73820e-09 , &
10418 4.00490e-09 ,4.28794e-09 ,4.58819e-09 ,4.90647e-09 ,5.24371e-09 , &
10419 5.60081e-09 ,5.97875e-09 ,6.37854e-09 ,6.80120e-09 ,7.24782e-09 , &
10420 7.71950e-09 ,8.21740e-09 ,8.74271e-09 ,9.29666e-09 ,9.88054e-09 , &
10421 1.04956e-08 ,1.11434e-08 ,1.18251e-08 ,1.25422e-08 ,1.32964e-08 , &
10422 1.40890e-08 ,1.49217e-08 ,1.57961e-08 ,1.67140e-08 ,1.76771e-08 , &
10423 1.86870e-08 ,1.97458e-08 ,2.08553e-08 ,2.20175e-08 ,2.32342e-08 , &
10424 2.45077e-08 ,2.58401e-08 ,2.72334e-08 ,2.86900e-08 ,3.02122e-08 , &
10425 3.18021e-08 ,3.34624e-08 ,3.51954e-08 ,3.70037e-08 ,3.88899e-08 /)
10426 totplnk(101:150,14) = (/ &
10427 4.08568e-08 ,4.29068e-08 ,4.50429e-08 ,4.72678e-08 ,4.95847e-08 , &
10428 5.19963e-08 ,5.45058e-08 ,5.71161e-08 ,5.98309e-08 ,6.26529e-08 , &
10429 6.55857e-08 ,6.86327e-08 ,7.17971e-08 ,7.50829e-08 ,7.84933e-08 , &
10430 8.20323e-08 ,8.57035e-08 ,8.95105e-08 ,9.34579e-08 ,9.75488e-08 , &
10431 1.01788e-07 ,1.06179e-07 ,1.10727e-07 ,1.15434e-07 ,1.20307e-07 , &
10432 1.25350e-07 ,1.30566e-07 ,1.35961e-07 ,1.41539e-07 ,1.47304e-07 , &
10433 1.53263e-07 ,1.59419e-07 ,1.65778e-07 ,1.72345e-07 ,1.79124e-07 , &
10434 1.86122e-07 ,1.93343e-07 ,2.00792e-07 ,2.08476e-07 ,2.16400e-07 , &
10435 2.24568e-07 ,2.32988e-07 ,2.41666e-07 ,2.50605e-07 ,2.59813e-07 , &
10436 2.69297e-07 ,2.79060e-07 ,2.89111e-07 ,2.99455e-07 ,3.10099e-07 /)
10437 totplnk(151:181,14) = (/ &
10438 3.21049e-07 ,3.32311e-07 ,3.43893e-07 ,3.55801e-07 ,3.68041e-07 , &
10439 3.80621e-07 ,3.93547e-07 ,4.06826e-07 ,4.20465e-07 ,4.34473e-07 , &
10440 4.48856e-07 ,4.63620e-07 ,4.78774e-07 ,4.94325e-07 ,5.10280e-07 , &
10441 5.26648e-07 ,5.43436e-07 ,5.60652e-07 ,5.78302e-07 ,5.96397e-07 , &
10442 6.14943e-07 ,6.33949e-07 ,6.53421e-07 ,6.73370e-07 ,6.93803e-07 , &
10443 7.14731e-07 ,7.36157e-07 ,7.58095e-07 ,7.80549e-07 ,8.03533e-07 , &
10445 totplnk(1:50,15) = (/ &
10446 3.90483e-12 ,4.47999e-12 ,5.13122e-12 ,5.86739e-12 ,6.69829e-12 , &
10447 7.63467e-12 ,8.68833e-12 ,9.87221e-12 ,1.12005e-11 ,1.26885e-11 , &
10448 1.43534e-11 ,1.62134e-11 ,1.82888e-11 ,2.06012e-11 ,2.31745e-11 , &
10449 2.60343e-11 ,2.92087e-11 ,3.27277e-11 ,3.66242e-11 ,4.09334e-11 , &
10450 4.56935e-11 ,5.09455e-11 ,5.67338e-11 ,6.31057e-11 ,7.01127e-11 , &
10451 7.78096e-11 ,8.62554e-11 ,9.55130e-11 ,1.05651e-10 ,1.16740e-10 , &
10452 1.28858e-10 ,1.42089e-10 ,1.56519e-10 ,1.72243e-10 ,1.89361e-10 , &
10453 2.07978e-10 ,2.28209e-10 ,2.50173e-10 ,2.73999e-10 ,2.99820e-10 , &
10454 3.27782e-10 ,3.58034e-10 ,3.90739e-10 ,4.26067e-10 ,4.64196e-10 , &
10455 5.05317e-10 ,5.49631e-10 ,5.97347e-10 ,6.48689e-10 ,7.03891e-10 /)
10456 totplnk(51:100,15) = (/ &
10457 7.63201e-10 ,8.26876e-10 ,8.95192e-10 ,9.68430e-10 ,1.04690e-09 , &
10458 1.13091e-09 ,1.22079e-09 ,1.31689e-09 ,1.41957e-09 ,1.52922e-09 , &
10459 1.64623e-09 ,1.77101e-09 ,1.90401e-09 ,2.04567e-09 ,2.19647e-09 , &
10460 2.35690e-09 ,2.52749e-09 ,2.70875e-09 ,2.90127e-09 ,3.10560e-09 , &
10461 3.32238e-09 ,3.55222e-09 ,3.79578e-09 ,4.05375e-09 ,4.32682e-09 , &
10462 4.61574e-09 ,4.92128e-09 ,5.24420e-09 ,5.58536e-09 ,5.94558e-09 , &
10463 6.32575e-09 ,6.72678e-09 ,7.14964e-09 ,7.59526e-09 ,8.06470e-09 , &
10464 8.55897e-09 ,9.07916e-09 ,9.62638e-09 ,1.02018e-08 ,1.08066e-08 , &
10465 1.14420e-08 ,1.21092e-08 ,1.28097e-08 ,1.35446e-08 ,1.43155e-08 , &
10466 1.51237e-08 ,1.59708e-08 ,1.68581e-08 ,1.77873e-08 ,1.87599e-08 /)
10467 totplnk(101:150,15) = (/ &
10468 1.97777e-08 ,2.08423e-08 ,2.19555e-08 ,2.31190e-08 ,2.43348e-08 , &
10469 2.56045e-08 ,2.69302e-08 ,2.83140e-08 ,2.97578e-08 ,3.12636e-08 , &
10470 3.28337e-08 ,3.44702e-08 ,3.61755e-08 ,3.79516e-08 ,3.98012e-08 , &
10471 4.17265e-08 ,4.37300e-08 ,4.58143e-08 ,4.79819e-08 ,5.02355e-08 , &
10472 5.25777e-08 ,5.50114e-08 ,5.75393e-08 ,6.01644e-08 ,6.28896e-08 , &
10473 6.57177e-08 ,6.86521e-08 ,7.16959e-08 ,7.48520e-08 ,7.81239e-08 , &
10474 8.15148e-08 ,8.50282e-08 ,8.86675e-08 ,9.24362e-08 ,9.63380e-08 , &
10475 1.00376e-07 ,1.04555e-07 ,1.08878e-07 ,1.13349e-07 ,1.17972e-07 , &
10476 1.22751e-07 ,1.27690e-07 ,1.32793e-07 ,1.38064e-07 ,1.43508e-07 , &
10477 1.49129e-07 ,1.54931e-07 ,1.60920e-07 ,1.67099e-07 ,1.73473e-07 /)
10478 totplnk(151:181,15) = (/ &
10479 1.80046e-07 ,1.86825e-07 ,1.93812e-07 ,2.01014e-07 ,2.08436e-07 , &
10480 2.16082e-07 ,2.23957e-07 ,2.32067e-07 ,2.40418e-07 ,2.49013e-07 , &
10481 2.57860e-07 ,2.66963e-07 ,2.76328e-07 ,2.85961e-07 ,2.95868e-07 , &
10482 3.06053e-07 ,3.16524e-07 ,3.27286e-07 ,3.38345e-07 ,3.49707e-07 , &
10483 3.61379e-07 ,3.73367e-07 ,3.85676e-07 ,3.98315e-07 ,4.11287e-07 , &
10484 4.24602e-07 ,4.38265e-07 ,4.52283e-07 ,4.66662e-07 ,4.81410e-07 , &
10486 totplnk(1:50,16) = (/ &
10487 0.28639e-12 ,0.33349e-12 ,0.38764e-12 ,0.44977e-12 ,0.52093e-12 , &
10488 0.60231e-12 ,0.69522e-12 ,0.80111e-12 ,0.92163e-12 ,0.10586e-11 , &
10489 0.12139e-11 ,0.13899e-11 ,0.15890e-11 ,0.18138e-11 ,0.20674e-11 , &
10490 0.23531e-11 ,0.26744e-11 ,0.30352e-11 ,0.34401e-11 ,0.38936e-11 , &
10491 0.44011e-11 ,0.49681e-11 ,0.56010e-11 ,0.63065e-11 ,0.70919e-11 , &
10492 0.79654e-11 ,0.89357e-11 ,0.10012e-10 ,0.11205e-10 ,0.12526e-10 , &
10493 0.13986e-10 ,0.15600e-10 ,0.17380e-10 ,0.19342e-10 ,0.21503e-10 , &
10494 0.23881e-10 ,0.26494e-10 ,0.29362e-10 ,0.32509e-10 ,0.35958e-10 , &
10495 0.39733e-10 ,0.43863e-10 ,0.48376e-10 ,0.53303e-10 ,0.58679e-10 , &
10496 0.64539e-10 ,0.70920e-10 ,0.77864e-10 ,0.85413e-10 ,0.93615e-10 /)
10497 totplnk(51:100,16) = (/ &
10498 0.10252e-09 ,0.11217e-09 ,0.12264e-09 ,0.13397e-09 ,0.14624e-09 , &
10499 0.15950e-09 ,0.17383e-09 ,0.18930e-09 ,0.20599e-09 ,0.22399e-09 , &
10500 0.24339e-09 ,0.26427e-09 ,0.28674e-09 ,0.31090e-09 ,0.33686e-09 , &
10501 0.36474e-09 ,0.39466e-09 ,0.42676e-09 ,0.46115e-09 ,0.49800e-09 , &
10502 0.53744e-09 ,0.57964e-09 ,0.62476e-09 ,0.67298e-09 ,0.72448e-09 , &
10503 0.77945e-09 ,0.83809e-09 ,0.90062e-09 ,0.96725e-09 ,0.10382e-08 , &
10504 0.11138e-08 ,0.11941e-08 ,0.12796e-08 ,0.13704e-08 ,0.14669e-08 , &
10505 0.15694e-08 ,0.16781e-08 ,0.17934e-08 ,0.19157e-08 ,0.20453e-08 , &
10506 0.21825e-08 ,0.23278e-08 ,0.24815e-08 ,0.26442e-08 ,0.28161e-08 , &
10507 0.29978e-08 ,0.31898e-08 ,0.33925e-08 ,0.36064e-08 ,0.38321e-08 /)
10508 totplnk(101:150,16) = (/ &
10509 0.40700e-08 ,0.43209e-08 ,0.45852e-08 ,0.48636e-08 ,0.51567e-08 , &
10510 0.54652e-08 ,0.57897e-08 ,0.61310e-08 ,0.64897e-08 ,0.68667e-08 , &
10511 0.72626e-08 ,0.76784e-08 ,0.81148e-08 ,0.85727e-08 ,0.90530e-08 , &
10512 0.95566e-08 ,0.10084e-07 ,0.10638e-07 ,0.11217e-07 ,0.11824e-07 , &
10513 0.12458e-07 ,0.13123e-07 ,0.13818e-07 ,0.14545e-07 ,0.15305e-07 , &
10514 0.16099e-07 ,0.16928e-07 ,0.17795e-07 ,0.18699e-07 ,0.19643e-07 , &
10515 0.20629e-07 ,0.21656e-07 ,0.22728e-07 ,0.23845e-07 ,0.25010e-07 , &
10516 0.26223e-07 ,0.27487e-07 ,0.28804e-07 ,0.30174e-07 ,0.31600e-07 , &
10517 0.33084e-07 ,0.34628e-07 ,0.36233e-07 ,0.37902e-07 ,0.39637e-07 , &
10518 0.41440e-07 ,0.43313e-07 ,0.45259e-07 ,0.47279e-07 ,0.49376e-07 /)
10519 totplnk(151:181,16) = (/ &
10520 0.51552e-07 ,0.53810e-07 ,0.56153e-07 ,0.58583e-07 ,0.61102e-07 , &
10521 0.63713e-07 ,0.66420e-07 ,0.69224e-07 ,0.72129e-07 ,0.75138e-07 , &
10522 0.78254e-07 ,0.81479e-07 ,0.84818e-07 ,0.88272e-07 ,0.91846e-07 , &
10523 0.95543e-07 ,0.99366e-07 ,0.10332e-06 ,0.10740e-06 ,0.11163e-06 , &
10524 0.11599e-06 ,0.12050e-06 ,0.12515e-06 ,0.12996e-06 ,0.13493e-06 , &
10525 0.14005e-06 ,0.14534e-06 ,0.15080e-06 ,0.15643e-06 ,0.16224e-06 , &
10527 totplk16(1:50) = (/ &
10528 0.28481e-12 ,0.33159e-12 ,0.38535e-12 ,0.44701e-12 ,0.51763e-12 , &
10529 0.59836e-12 ,0.69049e-12 ,0.79549e-12 ,0.91493e-12 ,0.10506e-11 , &
10530 0.12045e-11 ,0.13788e-11 ,0.15758e-11 ,0.17984e-11 ,0.20493e-11 , &
10531 0.23317e-11 ,0.26494e-11 ,0.30060e-11 ,0.34060e-11 ,0.38539e-11 , &
10532 0.43548e-11 ,0.49144e-11 ,0.55387e-11 ,0.62344e-11 ,0.70086e-11 , &
10533 0.78692e-11 ,0.88248e-11 ,0.98846e-11 ,0.11059e-10 ,0.12358e-10 , &
10534 0.13794e-10 ,0.15379e-10 ,0.17128e-10 ,0.19055e-10 ,0.21176e-10 , &
10535 0.23508e-10 ,0.26070e-10 ,0.28881e-10 ,0.31963e-10 ,0.35339e-10 , &
10536 0.39034e-10 ,0.43073e-10 ,0.47484e-10 ,0.52299e-10 ,0.57548e-10 , &
10537 0.63267e-10 ,0.69491e-10 ,0.76261e-10 ,0.83616e-10 ,0.91603e-10 /)
10538 totplk16(51:100) = (/ &
10539 0.10027e-09 ,0.10966e-09 ,0.11983e-09 ,0.13084e-09 ,0.14275e-09 , &
10540 0.15562e-09 ,0.16951e-09 ,0.18451e-09 ,0.20068e-09 ,0.21810e-09 , &
10541 0.23686e-09 ,0.25704e-09 ,0.27875e-09 ,0.30207e-09 ,0.32712e-09 , &
10542 0.35400e-09 ,0.38282e-09 ,0.41372e-09 ,0.44681e-09 ,0.48223e-09 , &
10543 0.52013e-09 ,0.56064e-09 ,0.60392e-09 ,0.65015e-09 ,0.69948e-09 , &
10544 0.75209e-09 ,0.80818e-09 ,0.86794e-09 ,0.93157e-09 ,0.99929e-09 , &
10545 0.10713e-08 ,0.11479e-08 ,0.12293e-08 ,0.13157e-08 ,0.14074e-08 , &
10546 0.15047e-08 ,0.16079e-08 ,0.17172e-08 ,0.18330e-08 ,0.19557e-08 , &
10547 0.20855e-08 ,0.22228e-08 ,0.23680e-08 ,0.25214e-08 ,0.26835e-08 , &
10548 0.28546e-08 ,0.30352e-08 ,0.32257e-08 ,0.34266e-08 ,0.36384e-08 /)
10549 totplk16(101:150) = (/ &
10550 0.38615e-08 ,0.40965e-08 ,0.43438e-08 ,0.46041e-08 ,0.48779e-08 , &
10551 0.51658e-08 ,0.54683e-08 ,0.57862e-08 ,0.61200e-08 ,0.64705e-08 , &
10552 0.68382e-08 ,0.72240e-08 ,0.76285e-08 ,0.80526e-08 ,0.84969e-08 , &
10553 0.89624e-08 ,0.94498e-08 ,0.99599e-08 ,0.10494e-07 ,0.11052e-07 , &
10554 0.11636e-07 ,0.12246e-07 ,0.12884e-07 ,0.13551e-07 ,0.14246e-07 , &
10555 0.14973e-07 ,0.15731e-07 ,0.16522e-07 ,0.17347e-07 ,0.18207e-07 , &
10556 0.19103e-07 ,0.20037e-07 ,0.21011e-07 ,0.22024e-07 ,0.23079e-07 , &
10557 0.24177e-07 ,0.25320e-07 ,0.26508e-07 ,0.27744e-07 ,0.29029e-07 , &
10558 0.30365e-07 ,0.31753e-07 ,0.33194e-07 ,0.34691e-07 ,0.36246e-07 , &
10559 0.37859e-07 ,0.39533e-07 ,0.41270e-07 ,0.43071e-07 ,0.44939e-07 /)
10560 totplk16(151:181) = (/ &
10561 0.46875e-07 ,0.48882e-07 ,0.50961e-07 ,0.53115e-07 ,0.55345e-07 , &
10562 0.57655e-07 ,0.60046e-07 ,0.62520e-07 ,0.65080e-07 ,0.67728e-07 , &
10563 0.70466e-07 ,0.73298e-07 ,0.76225e-07 ,0.79251e-07 ,0.82377e-07 , &
10564 0.85606e-07 ,0.88942e-07 ,0.92386e-07 ,0.95942e-07 ,0.99612e-07 , &
10565 0.10340e-06 ,0.10731e-06 ,0.11134e-06 ,0.11550e-06 ,0.11979e-06 , &
10566 0.12421e-06 ,0.12876e-06 ,0.13346e-06 ,0.13830e-06 ,0.14328e-06 , &
10569 end subroutine lwavplank
10571 !***************************************************************************
10572 subroutine lwavplankderiv
10573 !***************************************************************************
10577 totplnkderiv(1:50, 1) = (/ &
10578 2.22125e-08 ,2.23245e-08 ,2.24355e-08 ,2.25435e-08 ,2.26560e-08 , &
10579 2.27620e-08 ,2.28690e-08 ,2.29760e-08 ,2.30775e-08 ,2.31800e-08 , &
10580 2.32825e-08 ,2.33825e-08 ,2.34820e-08 ,2.35795e-08 ,2.36760e-08 , &
10581 2.37710e-08 ,2.38655e-08 ,2.39595e-08 ,2.40530e-08 ,2.41485e-08 , &
10582 2.42395e-08 ,2.43300e-08 ,2.44155e-08 ,2.45085e-08 ,2.45905e-08 , &
10583 2.46735e-08 ,2.47565e-08 ,2.48465e-08 ,2.49315e-08 ,2.50100e-08 , &
10584 2.50905e-08 ,2.51705e-08 ,2.52490e-08 ,2.53260e-08 ,2.54075e-08 , &
10585 2.54785e-08 ,2.55555e-08 ,2.56340e-08 ,2.57050e-08 ,2.57820e-08 , &
10586 2.58525e-08 ,2.59205e-08 ,2.59945e-08 ,2.60680e-08 ,2.61375e-08 , &
10587 2.61980e-08 ,2.62745e-08 ,2.63335e-08 ,2.63995e-08 ,2.64710e-08 /)
10588 totplnkderiv(51:100, 1) = (/ &
10589 2.65300e-08 ,2.66005e-08 ,2.66685e-08 ,2.67310e-08 ,2.67915e-08 , &
10590 2.68540e-08 ,2.69065e-08 ,2.69730e-08 ,2.70270e-08 ,2.70690e-08 , &
10591 2.71420e-08 ,2.71985e-08 ,2.72560e-08 ,2.73180e-08 ,2.73760e-08 , &
10592 2.74285e-08 ,2.74840e-08 ,2.75290e-08 ,2.75950e-08 ,2.76360e-08 , &
10593 2.76975e-08 ,2.77475e-08 ,2.78080e-08 ,2.78375e-08 ,2.79120e-08 , &
10594 2.79510e-08 ,2.79955e-08 ,2.80625e-08 ,2.80920e-08 ,2.81570e-08 , &
10595 2.81990e-08 ,2.82330e-08 ,2.82830e-08 ,2.83365e-08 ,2.83740e-08 , &
10596 2.84295e-08 ,2.84910e-08 ,2.85275e-08 ,2.85525e-08 ,2.86085e-08 , &
10597 2.86535e-08 ,2.86945e-08 ,2.87355e-08 ,2.87695e-08 ,2.88105e-08 , &
10598 2.88585e-08 ,2.88945e-08 ,2.89425e-08 ,2.89580e-08 ,2.90265e-08 /)
10599 totplnkderiv(101:150, 1) = (/ &
10600 2.90445e-08 ,2.90905e-08 ,2.91425e-08 ,2.91560e-08 ,2.91970e-08 , &
10601 2.91905e-08 ,2.92880e-08 ,2.92950e-08 ,2.93630e-08 ,2.93995e-08 , &
10602 2.94425e-08 ,2.94635e-08 ,2.94770e-08 ,2.95290e-08 ,2.95585e-08 , &
10603 2.95815e-08 ,2.95995e-08 ,2.96745e-08 ,2.96725e-08 ,2.97040e-08 , &
10604 2.97750e-08 ,2.97905e-08 ,2.98175e-08 ,2.98355e-08 ,2.98705e-08 , &
10605 2.99040e-08 ,2.99680e-08 ,2.99860e-08 ,3.00270e-08 ,3.00200e-08 , &
10606 3.00770e-08 ,3.00795e-08 ,3.01065e-08 ,3.01795e-08 ,3.01815e-08 , &
10607 3.02025e-08 ,3.02360e-08 ,3.02360e-08 ,3.03090e-08 ,3.03155e-08 , &
10608 3.03725e-08 ,3.03635e-08 ,3.04270e-08 ,3.04610e-08 ,3.04635e-08 , &
10609 3.04610e-08 ,3.05180e-08 ,3.05430e-08 ,3.05290e-08 ,3.05885e-08 /)
10610 totplnkderiv(151:181, 1) = (/ &
10611 3.05750e-08 ,3.05775e-08 ,3.06795e-08 ,3.07025e-08 ,3.07365e-08 , &
10612 3.07435e-08 ,3.07525e-08 ,3.07680e-08 ,3.08115e-08 ,3.07930e-08 , &
10613 3.08155e-08 ,3.08660e-08 ,3.08865e-08 ,3.08390e-08 ,3.09340e-08 , &
10614 3.09685e-08 ,3.09340e-08 ,3.09820e-08 ,3.10365e-08 ,3.10705e-08 , &
10615 3.10750e-08 ,3.10475e-08 ,3.11685e-08 ,3.11455e-08 ,3.11500e-08 , &
10616 3.11775e-08 ,3.11890e-08 ,3.12045e-08 ,3.12185e-08 ,3.12415e-08 , &
10618 totplnkderiv(1:50, 2) = (/ &
10619 4.91150e-08 ,4.97290e-08 ,5.03415e-08 ,5.09460e-08 ,5.15550e-08 , &
10620 5.21540e-08 ,5.27575e-08 ,5.33500e-08 ,5.39500e-08 ,5.45445e-08 , &
10621 5.51290e-08 ,5.57235e-08 ,5.62955e-08 ,5.68800e-08 ,5.74620e-08 , &
10622 5.80425e-08 ,5.86145e-08 ,5.91810e-08 ,5.97435e-08 ,6.03075e-08 , &
10623 6.08625e-08 ,6.14135e-08 ,6.19775e-08 ,6.25185e-08 ,6.30675e-08 , &
10624 6.36145e-08 ,6.41535e-08 ,6.46920e-08 ,6.52265e-08 ,6.57470e-08 , &
10625 6.62815e-08 ,6.68000e-08 ,6.73320e-08 ,6.78550e-08 ,6.83530e-08 , &
10626 6.88760e-08 ,6.93735e-08 ,6.98790e-08 ,7.03950e-08 ,7.08810e-08 , &
10627 7.13815e-08 ,7.18795e-08 ,7.23415e-08 ,7.28505e-08 ,7.33285e-08 , &
10628 7.38075e-08 ,7.42675e-08 ,7.47605e-08 ,7.52380e-08 ,7.57020e-08 /)
10629 totplnkderiv(51:100, 2) = (/ &
10630 7.61495e-08 ,7.65955e-08 ,7.70565e-08 ,7.75185e-08 ,7.79735e-08 , &
10631 7.83915e-08 ,7.88625e-08 ,7.93215e-08 ,7.97425e-08 ,8.02195e-08 , &
10632 8.05905e-08 ,8.10335e-08 ,8.14770e-08 ,8.19025e-08 ,8.22955e-08 , &
10633 8.27115e-08 ,8.31165e-08 ,8.35645e-08 ,8.39440e-08 ,8.43785e-08 , &
10634 8.47380e-08 ,8.51495e-08 ,8.55405e-08 ,8.59720e-08 ,8.63135e-08 , &
10635 8.67065e-08 ,8.70930e-08 ,8.74545e-08 ,8.78780e-08 ,8.82160e-08 , &
10636 8.85625e-08 ,8.89850e-08 ,8.93395e-08 ,8.97080e-08 ,9.00675e-08 , &
10637 9.04085e-08 ,9.07360e-08 ,9.11315e-08 ,9.13815e-08 ,9.18320e-08 , &
10638 9.21500e-08 ,9.24725e-08 ,9.28640e-08 ,9.31955e-08 ,9.35185e-08 , &
10639 9.38645e-08 ,9.41780e-08 ,9.45465e-08 ,9.48470e-08 ,9.51375e-08 /)
10640 totplnkderiv(101:150, 2) = (/ &
10641 9.55245e-08 ,9.57925e-08 ,9.61195e-08 ,9.64750e-08 ,9.68110e-08 , &
10642 9.71715e-08 ,9.74150e-08 ,9.77250e-08 ,9.79600e-08 ,9.82600e-08 , &
10643 9.85300e-08 ,9.88400e-08 ,9.91600e-08 ,9.95350e-08 ,9.97500e-08 , &
10644 1.00090e-07 ,1.00370e-07 ,1.00555e-07 ,1.00935e-07 ,1.01275e-07 , &
10645 1.01400e-07 ,1.01790e-07 ,1.01945e-07 ,1.02225e-07 ,1.02585e-07 , &
10646 1.02895e-07 ,1.03010e-07 ,1.03285e-07 ,1.03540e-07 ,1.03890e-07 , &
10647 1.04015e-07 ,1.04420e-07 ,1.04640e-07 ,1.04810e-07 ,1.05090e-07 , &
10648 1.05385e-07 ,1.05600e-07 ,1.05965e-07 ,1.06050e-07 ,1.06385e-07 , &
10649 1.06390e-07 ,1.06795e-07 ,1.06975e-07 ,1.07240e-07 ,1.07435e-07 , &
10650 1.07815e-07 ,1.07960e-07 ,1.08010e-07 ,1.08535e-07 ,1.08670e-07 /)
10651 totplnkderiv(151:181, 2) = (/ &
10652 1.08855e-07 ,1.09210e-07 ,1.09195e-07 ,1.09510e-07 ,1.09665e-07 , &
10653 1.09885e-07 ,1.10130e-07 ,1.10440e-07 ,1.10640e-07 ,1.10760e-07 , &
10654 1.11125e-07 ,1.11195e-07 ,1.11345e-07 ,1.11710e-07 ,1.11765e-07 , &
10655 1.11960e-07 ,1.12225e-07 ,1.12460e-07 ,1.12595e-07 ,1.12730e-07 , &
10656 1.12880e-07 ,1.13295e-07 ,1.13215e-07 ,1.13505e-07 ,1.13665e-07 , &
10657 1.13870e-07 ,1.14025e-07 ,1.14325e-07 ,1.14495e-07 ,1.14605e-07 , &
10659 totplnkderiv(1:50, 3) = (/ &
10660 4.27040e-08 ,4.35430e-08 ,4.43810e-08 ,4.52210e-08 ,4.60630e-08 , &
10661 4.69135e-08 ,4.77585e-08 ,4.86135e-08 ,4.94585e-08 ,5.03230e-08 , &
10662 5.11740e-08 ,5.20250e-08 ,5.28940e-08 ,5.37465e-08 ,5.46175e-08 , &
10663 5.54700e-08 ,5.63430e-08 ,5.72085e-08 ,5.80735e-08 ,5.89430e-08 , &
10664 5.98015e-08 ,6.06680e-08 ,6.15380e-08 ,6.24130e-08 ,6.32755e-08 , &
10665 6.41340e-08 ,6.50060e-08 ,6.58690e-08 ,6.67315e-08 ,6.76025e-08 , &
10666 6.84585e-08 ,6.93205e-08 ,7.01845e-08 ,7.10485e-08 ,7.19160e-08 , &
10667 7.27695e-08 ,7.36145e-08 ,7.44840e-08 ,7.53405e-08 ,7.61770e-08 , &
10668 7.70295e-08 ,7.78745e-08 ,7.87350e-08 ,7.95740e-08 ,8.04150e-08 , &
10669 8.12565e-08 ,8.20885e-08 ,8.29455e-08 ,8.37830e-08 ,8.46035e-08 /)
10670 totplnkderiv(51:100, 3) = (/ &
10671 8.54315e-08 ,8.62770e-08 ,8.70975e-08 ,8.79140e-08 ,8.87190e-08 , &
10672 8.95625e-08 ,9.03625e-08 ,9.11795e-08 ,9.19930e-08 ,9.27685e-08 , &
10673 9.36095e-08 ,9.43785e-08 ,9.52375e-08 ,9.59905e-08 ,9.67680e-08 , &
10674 9.75840e-08 ,9.83755e-08 ,9.91710e-08 ,9.99445e-08 ,1.00706e-07 , &
10675 1.01477e-07 ,1.02255e-07 ,1.03021e-07 ,1.03776e-07 ,1.04544e-07 , &
10676 1.05338e-07 ,1.06082e-07 ,1.06843e-07 ,1.07543e-07 ,1.08298e-07 , &
10677 1.09103e-07 ,1.09812e-07 ,1.10536e-07 ,1.11268e-07 ,1.12027e-07 , &
10678 1.12727e-07 ,1.13464e-07 ,1.14183e-07 ,1.15037e-07 ,1.15615e-07 , &
10679 1.16329e-07 ,1.17057e-07 ,1.17734e-07 ,1.18448e-07 ,1.19149e-07 , &
10680 1.19835e-07 ,1.20512e-07 ,1.21127e-07 ,1.21895e-07 ,1.22581e-07 /)
10681 totplnkderiv(101:150, 3) = (/ &
10682 1.23227e-07 ,1.23928e-07 ,1.24560e-07 ,1.25220e-07 ,1.25895e-07 , &
10683 1.26565e-07 ,1.27125e-07 ,1.27855e-07 ,1.28490e-07 ,1.29195e-07 , &
10684 1.29790e-07 ,1.30470e-07 ,1.31070e-07 ,1.31690e-07 ,1.32375e-07 , &
10685 1.32960e-07 ,1.33570e-07 ,1.34230e-07 ,1.34840e-07 ,1.35315e-07 , &
10686 1.35990e-07 ,1.36555e-07 ,1.37265e-07 ,1.37945e-07 ,1.38425e-07 , &
10687 1.38950e-07 ,1.39640e-07 ,1.40220e-07 ,1.40775e-07 ,1.41400e-07 , &
10688 1.42020e-07 ,1.42500e-07 ,1.43085e-07 ,1.43680e-07 ,1.44255e-07 , &
10689 1.44855e-07 ,1.45385e-07 ,1.45890e-07 ,1.46430e-07 ,1.46920e-07 , &
10690 1.47715e-07 ,1.48090e-07 ,1.48695e-07 ,1.49165e-07 ,1.49715e-07 , &
10691 1.50130e-07 ,1.50720e-07 ,1.51330e-07 ,1.51725e-07 ,1.52350e-07 /)
10692 totplnkderiv(151:181, 3) = (/ &
10693 1.52965e-07 ,1.53305e-07 ,1.53915e-07 ,1.54280e-07 ,1.54950e-07 , &
10694 1.55370e-07 ,1.55850e-07 ,1.56260e-07 ,1.56825e-07 ,1.57470e-07 , &
10695 1.57760e-07 ,1.58295e-07 ,1.58780e-07 ,1.59470e-07 ,1.59940e-07 , &
10696 1.60325e-07 ,1.60825e-07 ,1.61100e-07 ,1.61605e-07 ,1.62045e-07 , &
10697 1.62670e-07 ,1.63020e-07 ,1.63625e-07 ,1.63900e-07 ,1.64420e-07 , &
10698 1.64705e-07 ,1.65430e-07 ,1.65610e-07 ,1.66220e-07 ,1.66585e-07 , &
10700 totplnkderiv(1:50, 4) = (/ &
10701 3.32829e-08 ,3.41160e-08 ,3.49626e-08 ,3.58068e-08 ,3.66765e-08 , &
10702 3.75320e-08 ,3.84095e-08 ,3.92920e-08 ,4.01830e-08 ,4.10715e-08 , &
10703 4.19735e-08 ,4.28835e-08 ,4.37915e-08 ,4.47205e-08 ,4.56410e-08 , &
10704 4.65770e-08 ,4.75090e-08 ,4.84530e-08 ,4.93975e-08 ,5.03470e-08 , &
10705 5.13000e-08 ,5.22560e-08 ,5.32310e-08 ,5.41865e-08 ,5.51655e-08 , &
10706 5.61590e-08 ,5.71120e-08 ,5.81075e-08 ,5.91060e-08 ,6.00895e-08 , &
10707 6.10750e-08 ,6.20740e-08 ,6.30790e-08 ,6.40765e-08 ,6.50940e-08 , &
10708 6.60895e-08 ,6.71230e-08 ,6.81200e-08 ,6.91260e-08 ,7.01485e-08 , &
10709 7.11625e-08 ,7.21870e-08 ,7.32010e-08 ,7.42080e-08 ,7.52285e-08 , &
10710 7.62930e-08 ,7.73040e-08 ,7.83185e-08 ,7.93410e-08 ,8.03560e-08 /)
10711 totplnkderiv(51:100, 4) = (/ &
10712 8.14115e-08 ,8.24200e-08 ,8.34555e-08 ,8.45100e-08 ,8.55265e-08 , &
10713 8.65205e-08 ,8.75615e-08 ,8.85870e-08 ,8.96175e-08 ,9.07015e-08 , &
10714 9.16475e-08 ,9.27525e-08 ,9.37055e-08 ,9.47375e-08 ,9.57995e-08 , &
10715 9.67635e-08 ,9.77980e-08 ,9.87735e-08 ,9.98485e-08 ,1.00904e-07 , &
10716 1.01900e-07 ,1.02876e-07 ,1.03905e-07 ,1.04964e-07 ,1.05956e-07 , &
10717 1.06870e-07 ,1.07952e-07 ,1.08944e-07 ,1.10003e-07 ,1.10965e-07 , &
10718 1.11952e-07 ,1.12927e-07 ,1.13951e-07 ,1.14942e-07 ,1.15920e-07 , &
10719 1.16968e-07 ,1.17877e-07 ,1.18930e-07 ,1.19862e-07 ,1.20817e-07 , &
10720 1.21817e-07 ,1.22791e-07 ,1.23727e-07 ,1.24751e-07 ,1.25697e-07 , &
10721 1.26634e-07 ,1.27593e-07 ,1.28585e-07 ,1.29484e-07 ,1.30485e-07 /)
10722 totplnkderiv(101:150, 4) = (/ &
10723 1.31363e-07 ,1.32391e-07 ,1.33228e-07 ,1.34155e-07 ,1.35160e-07 , &
10724 1.36092e-07 ,1.37070e-07 ,1.37966e-07 ,1.38865e-07 ,1.39740e-07 , &
10725 1.40770e-07 ,1.41620e-07 ,1.42605e-07 ,1.43465e-07 ,1.44240e-07 , &
10726 1.45305e-07 ,1.46220e-07 ,1.47070e-07 ,1.47935e-07 ,1.48890e-07 , &
10727 1.49905e-07 ,1.50640e-07 ,1.51435e-07 ,1.52335e-07 ,1.53235e-07 , &
10728 1.54045e-07 ,1.54895e-07 ,1.55785e-07 ,1.56870e-07 ,1.57360e-07 , &
10729 1.58395e-07 ,1.59185e-07 ,1.60060e-07 ,1.60955e-07 ,1.61770e-07 , &
10730 1.62445e-07 ,1.63415e-07 ,1.64170e-07 ,1.65125e-07 ,1.65995e-07 , &
10731 1.66545e-07 ,1.67580e-07 ,1.68295e-07 ,1.69130e-07 ,1.69935e-07 , &
10732 1.70800e-07 ,1.71610e-07 ,1.72365e-07 ,1.73215e-07 ,1.73770e-07 /)
10733 totplnkderiv(151:181, 4) = (/ &
10734 1.74590e-07 ,1.75525e-07 ,1.76095e-07 ,1.77125e-07 ,1.77745e-07 , &
10735 1.78580e-07 ,1.79315e-07 ,1.80045e-07 ,1.80695e-07 ,1.81580e-07 , &
10736 1.82360e-07 ,1.83205e-07 ,1.84055e-07 ,1.84315e-07 ,1.85225e-07 , &
10737 1.85865e-07 ,1.86660e-07 ,1.87445e-07 ,1.88350e-07 ,1.88930e-07 , &
10738 1.89420e-07 ,1.90275e-07 ,1.90630e-07 ,1.91650e-07 ,1.92485e-07 , &
10739 1.93285e-07 ,1.93695e-07 ,1.94595e-07 ,1.94895e-07 ,1.95960e-07 , &
10741 totplnkderiv(1:50, 5) = (/ &
10742 2.41948e-08 ,2.49273e-08 ,2.56705e-08 ,2.64263e-08 ,2.71899e-08 , &
10743 2.79687e-08 ,2.87531e-08 ,2.95520e-08 ,3.03567e-08 ,3.11763e-08 , &
10744 3.20014e-08 ,3.28390e-08 ,3.36865e-08 ,3.45395e-08 ,3.54083e-08 , &
10745 3.62810e-08 ,3.71705e-08 ,3.80585e-08 ,3.89650e-08 ,3.98750e-08 , &
10746 4.07955e-08 ,4.17255e-08 ,4.26635e-08 ,4.36095e-08 ,4.45605e-08 , &
10747 4.55190e-08 ,4.64910e-08 ,4.74670e-08 ,4.84480e-08 ,4.94430e-08 , &
10748 5.04460e-08 ,5.14440e-08 ,5.24500e-08 ,5.34835e-08 ,5.44965e-08 , &
10749 5.55325e-08 ,5.65650e-08 ,5.76050e-08 ,5.86615e-08 ,5.97175e-08 , &
10750 6.07750e-08 ,6.18400e-08 ,6.29095e-08 ,6.39950e-08 ,6.50665e-08 , &
10751 6.61405e-08 ,6.72290e-08 ,6.82800e-08 ,6.94445e-08 ,7.05460e-08 /)
10752 totplnkderiv(51:100, 5) = (/ &
10753 7.16400e-08 ,7.27475e-08 ,7.38790e-08 ,7.49845e-08 ,7.61270e-08 , &
10754 7.72375e-08 ,7.83770e-08 ,7.95045e-08 ,8.06315e-08 ,8.17715e-08 , &
10755 8.29275e-08 ,8.40555e-08 ,8.52110e-08 ,8.63565e-08 ,8.75045e-08 , &
10756 8.86735e-08 ,8.98150e-08 ,9.09970e-08 ,9.21295e-08 ,9.32730e-08 , &
10757 9.44605e-08 ,9.56170e-08 ,9.67885e-08 ,9.79275e-08 ,9.91190e-08 , &
10758 1.00278e-07 ,1.01436e-07 ,1.02625e-07 ,1.03792e-07 ,1.04989e-07 , &
10759 1.06111e-07 ,1.07320e-07 ,1.08505e-07 ,1.09626e-07 ,1.10812e-07 , &
10760 1.11948e-07 ,1.13162e-07 ,1.14289e-07 ,1.15474e-07 ,1.16661e-07 , &
10761 1.17827e-07 ,1.19023e-07 ,1.20167e-07 ,1.21356e-07 ,1.22499e-07 , &
10762 1.23653e-07 ,1.24876e-07 ,1.25983e-07 ,1.27175e-07 ,1.28325e-07 /)
10763 totplnkderiv(101:150, 5) = (/ &
10764 1.29517e-07 ,1.30685e-07 ,1.31840e-07 ,1.33013e-07 ,1.34160e-07 , &
10765 1.35297e-07 ,1.36461e-07 ,1.37630e-07 ,1.38771e-07 ,1.39913e-07 , &
10766 1.41053e-07 ,1.42218e-07 ,1.43345e-07 ,1.44460e-07 ,1.45692e-07 , &
10767 1.46697e-07 ,1.47905e-07 ,1.49010e-07 ,1.50210e-07 ,1.51285e-07 , &
10768 1.52380e-07 ,1.53555e-07 ,1.54655e-07 ,1.55805e-07 ,1.56850e-07 , &
10769 1.58055e-07 ,1.59115e-07 ,1.60185e-07 ,1.61255e-07 ,1.62465e-07 , &
10770 1.63575e-07 ,1.64675e-07 ,1.65760e-07 ,1.66765e-07 ,1.67945e-07 , &
10771 1.69070e-07 ,1.70045e-07 ,1.71145e-07 ,1.72260e-07 ,1.73290e-07 , &
10772 1.74470e-07 ,1.75490e-07 ,1.76515e-07 ,1.77555e-07 ,1.78660e-07 , &
10773 1.79670e-07 ,1.80705e-07 ,1.81895e-07 ,1.82745e-07 ,1.83950e-07 /)
10774 totplnkderiv(151:181, 5) = (/ &
10775 1.84955e-07 ,1.85940e-07 ,1.87080e-07 ,1.88010e-07 ,1.89145e-07 , &
10776 1.90130e-07 ,1.91110e-07 ,1.92130e-07 ,1.93205e-07 ,1.94230e-07 , &
10777 1.95045e-07 ,1.96070e-07 ,1.97155e-07 ,1.98210e-07 ,1.99080e-07 , &
10778 2.00280e-07 ,2.01135e-07 ,2.02150e-07 ,2.03110e-07 ,2.04135e-07 , &
10779 2.05110e-07 ,2.06055e-07 ,2.07120e-07 ,2.08075e-07 ,2.08975e-07 , &
10780 2.09950e-07 ,2.10870e-07 ,2.11830e-07 ,2.12960e-07 ,2.13725e-07 , &
10782 totplnkderiv(1:50, 6) = (/ &
10783 1.36567e-08 ,1.41766e-08 ,1.47079e-08 ,1.52499e-08 ,1.58075e-08 , &
10784 1.63727e-08 ,1.69528e-08 ,1.75429e-08 ,1.81477e-08 ,1.87631e-08 , &
10785 1.93907e-08 ,2.00297e-08 ,2.06808e-08 ,2.13432e-08 ,2.20183e-08 , &
10786 2.27076e-08 ,2.34064e-08 ,2.41181e-08 ,2.48400e-08 ,2.55750e-08 , &
10787 2.63231e-08 ,2.70790e-08 ,2.78502e-08 ,2.86326e-08 ,2.94259e-08 , &
10788 3.02287e-08 ,3.10451e-08 ,3.18752e-08 ,3.27108e-08 ,3.35612e-08 , &
10789 3.44198e-08 ,3.52930e-08 ,3.61785e-08 ,3.70690e-08 ,3.79725e-08 , &
10790 3.88845e-08 ,3.98120e-08 ,4.07505e-08 ,4.16965e-08 ,4.26515e-08 , &
10791 4.36190e-08 ,4.45925e-08 ,4.55760e-08 ,4.65735e-08 ,4.75835e-08 , &
10792 4.85970e-08 ,4.96255e-08 ,5.06975e-08 ,5.16950e-08 ,5.27530e-08 /)
10793 totplnkderiv(51:100, 6) = (/ &
10794 5.38130e-08 ,5.48860e-08 ,5.59715e-08 ,5.70465e-08 ,5.81385e-08 , &
10795 5.92525e-08 ,6.03565e-08 ,6.14815e-08 ,6.26175e-08 ,6.37475e-08 , &
10796 6.48855e-08 ,6.60340e-08 ,6.71980e-08 ,6.83645e-08 ,6.95430e-08 , &
10797 7.07145e-08 ,7.19015e-08 ,7.30995e-08 ,7.43140e-08 ,7.55095e-08 , &
10798 7.67115e-08 ,7.79485e-08 ,7.91735e-08 ,8.03925e-08 ,8.16385e-08 , &
10799 8.28775e-08 ,8.41235e-08 ,8.53775e-08 ,8.66405e-08 ,8.78940e-08 , &
10800 8.91805e-08 ,9.04515e-08 ,9.17290e-08 ,9.30230e-08 ,9.43145e-08 , &
10801 9.56200e-08 ,9.69160e-08 ,9.82140e-08 ,9.95285e-08 ,1.00829e-07 , &
10802 1.02145e-07 ,1.03478e-07 ,1.04787e-07 ,1.06095e-07 ,1.07439e-07 , &
10803 1.08785e-07 ,1.10078e-07 ,1.11466e-07 ,1.12795e-07 ,1.14133e-07 /)
10804 totplnkderiv(101:150, 6) = (/ &
10805 1.15479e-07 ,1.16825e-07 ,1.18191e-07 ,1.19540e-07 ,1.20908e-07 , &
10806 1.22257e-07 ,1.23634e-07 ,1.24992e-07 ,1.26345e-07 ,1.27740e-07 , &
10807 1.29098e-07 ,1.30447e-07 ,1.31831e-07 ,1.33250e-07 ,1.34591e-07 , &
10808 1.36011e-07 ,1.37315e-07 ,1.38721e-07 ,1.40103e-07 ,1.41504e-07 , &
10809 1.42882e-07 ,1.44259e-07 ,1.45674e-07 ,1.46997e-07 ,1.48412e-07 , &
10810 1.49794e-07 ,1.51167e-07 ,1.52577e-07 ,1.53941e-07 ,1.55369e-07 , &
10811 1.56725e-07 ,1.58125e-07 ,1.59460e-07 ,1.60895e-07 ,1.62260e-07 , &
10812 1.63610e-07 ,1.65085e-07 ,1.66410e-07 ,1.67805e-07 ,1.69185e-07 , &
10813 1.70570e-07 ,1.71915e-07 ,1.73375e-07 ,1.74775e-07 ,1.76090e-07 , &
10814 1.77485e-07 ,1.78905e-07 ,1.80190e-07 ,1.81610e-07 ,1.82960e-07 /)
10815 totplnkderiv(151:181, 6) = (/ &
10816 1.84330e-07 ,1.85750e-07 ,1.87060e-07 ,1.88470e-07 ,1.89835e-07 , &
10817 1.91250e-07 ,1.92565e-07 ,1.93925e-07 ,1.95220e-07 ,1.96620e-07 , &
10818 1.98095e-07 ,1.99330e-07 ,2.00680e-07 ,2.02090e-07 ,2.03360e-07 , &
10819 2.04775e-07 ,2.06080e-07 ,2.07440e-07 ,2.08820e-07 ,2.10095e-07 , &
10820 2.11445e-07 ,2.12785e-07 ,2.14050e-07 ,2.15375e-07 ,2.16825e-07 , &
10821 2.18080e-07 ,2.19345e-07 ,2.20710e-07 ,2.21980e-07 ,2.23425e-07 , &
10823 totplnkderiv(1:50, 7) = (/ &
10824 7.22270e-09 ,7.55350e-09 ,7.89480e-09 ,8.24725e-09 ,8.60780e-09 , &
10825 8.98215e-09 ,9.36430e-09 ,9.76035e-09 ,1.01652e-08 ,1.05816e-08 , &
10826 1.10081e-08 ,1.14480e-08 ,1.18981e-08 ,1.23600e-08 ,1.28337e-08 , &
10827 1.33172e-08 ,1.38139e-08 ,1.43208e-08 ,1.48413e-08 ,1.53702e-08 , &
10828 1.59142e-08 ,1.64704e-08 ,1.70354e-08 ,1.76178e-08 ,1.82065e-08 , &
10829 1.88083e-08 ,1.94237e-08 ,2.00528e-08 ,2.06913e-08 ,2.13413e-08 , &
10830 2.20058e-08 ,2.26814e-08 ,2.33686e-08 ,2.40729e-08 ,2.47812e-08 , &
10831 2.55099e-08 ,2.62449e-08 ,2.69966e-08 ,2.77569e-08 ,2.85269e-08 , &
10832 2.93144e-08 ,3.01108e-08 ,3.09243e-08 ,3.17433e-08 ,3.25756e-08 , &
10833 3.34262e-08 ,3.42738e-08 ,3.51480e-08 ,3.60285e-08 ,3.69160e-08 /)
10834 totplnkderiv(51:100, 7) = (/ &
10835 3.78235e-08 ,3.87390e-08 ,3.96635e-08 ,4.06095e-08 ,4.15600e-08 , &
10836 4.25180e-08 ,4.34895e-08 ,4.44800e-08 ,4.54715e-08 ,4.64750e-08 , &
10837 4.74905e-08 ,4.85210e-08 ,4.95685e-08 ,5.06135e-08 ,5.16725e-08 , &
10838 5.27480e-08 ,5.38265e-08 ,5.49170e-08 ,5.60120e-08 ,5.71275e-08 , &
10839 5.82610e-08 ,5.93775e-08 ,6.05245e-08 ,6.17025e-08 ,6.28355e-08 , &
10840 6.40135e-08 ,6.52015e-08 ,6.63865e-08 ,6.75790e-08 ,6.88120e-08 , &
10841 7.00070e-08 ,7.12335e-08 ,7.24720e-08 ,7.37340e-08 ,7.49775e-08 , &
10842 7.62415e-08 ,7.75185e-08 ,7.87915e-08 ,8.00875e-08 ,8.13630e-08 , &
10843 8.26710e-08 ,8.39645e-08 ,8.53060e-08 ,8.66305e-08 ,8.79915e-08 , &
10844 8.93080e-08 ,9.06560e-08 ,9.19860e-08 ,9.33550e-08 ,9.47305e-08 /)
10845 totplnkderiv(101:150, 7) = (/ &
10846 9.61180e-08 ,9.74500e-08 ,9.88850e-08 ,1.00263e-07 ,1.01688e-07 , &
10847 1.03105e-07 ,1.04489e-07 ,1.05906e-07 ,1.07345e-07 ,1.08771e-07 , &
10848 1.10220e-07 ,1.11713e-07 ,1.13098e-07 ,1.14515e-07 ,1.16019e-07 , &
10849 1.17479e-07 ,1.18969e-07 ,1.20412e-07 ,1.21852e-07 ,1.23387e-07 , &
10850 1.24851e-07 ,1.26319e-07 ,1.27811e-07 ,1.29396e-07 ,1.30901e-07 , &
10851 1.32358e-07 ,1.33900e-07 ,1.35405e-07 ,1.36931e-07 ,1.38443e-07 , &
10852 1.39985e-07 ,1.41481e-07 ,1.43072e-07 ,1.44587e-07 ,1.46133e-07 , &
10853 1.47698e-07 ,1.49203e-07 ,1.50712e-07 ,1.52363e-07 ,1.53795e-07 , &
10854 1.55383e-07 ,1.56961e-07 ,1.58498e-07 ,1.60117e-07 ,1.61745e-07 , &
10855 1.63190e-07 ,1.64790e-07 ,1.66370e-07 ,1.67975e-07 ,1.69555e-07 /)
10856 totplnkderiv(151:181, 7) = (/ &
10857 1.71060e-07 ,1.72635e-07 ,1.74345e-07 ,1.75925e-07 ,1.77395e-07 , &
10858 1.78960e-07 ,1.80620e-07 ,1.82180e-07 ,1.83840e-07 ,1.85340e-07 , &
10859 1.86940e-07 ,1.88550e-07 ,1.90095e-07 ,1.91670e-07 ,1.93385e-07 , &
10860 1.94895e-07 ,1.96500e-07 ,1.98090e-07 ,1.99585e-07 ,2.01280e-07 , &
10861 2.02950e-07 ,2.04455e-07 ,2.06075e-07 ,2.07635e-07 ,2.09095e-07 , &
10862 2.10865e-07 ,2.12575e-07 ,2.14050e-07 ,2.15630e-07 ,2.17060e-07 , &
10864 totplnkderiv(1:50, 8) = (/ &
10865 4.26397e-09 ,4.48470e-09 ,4.71299e-09 ,4.94968e-09 ,5.19542e-09 , &
10866 5.44847e-09 ,5.71195e-09 ,5.98305e-09 ,6.26215e-09 ,6.55290e-09 , &
10867 6.85190e-09 ,7.15950e-09 ,7.47745e-09 ,7.80525e-09 ,8.14190e-09 , &
10868 8.48915e-09 ,8.84680e-09 ,9.21305e-09 ,9.59105e-09 ,9.98130e-09 , &
10869 1.03781e-08 ,1.07863e-08 ,1.12094e-08 ,1.16371e-08 ,1.20802e-08 , &
10870 1.25327e-08 ,1.29958e-08 ,1.34709e-08 ,1.39592e-08 ,1.44568e-08 , &
10871 1.49662e-08 ,1.54828e-08 ,1.60186e-08 ,1.65612e-08 ,1.71181e-08 , &
10872 1.76822e-08 ,1.82591e-08 ,1.88487e-08 ,1.94520e-08 ,2.00691e-08 , &
10873 2.06955e-08 ,2.13353e-08 ,2.19819e-08 ,2.26479e-08 ,2.33234e-08 , &
10874 2.40058e-08 ,2.47135e-08 ,2.54203e-08 ,2.61414e-08 ,2.68778e-08 /)
10875 totplnkderiv(51:100, 8) = (/ &
10876 2.76265e-08 ,2.83825e-08 ,2.91632e-08 ,2.99398e-08 ,3.07389e-08 , &
10877 3.15444e-08 ,3.23686e-08 ,3.31994e-08 ,3.40487e-08 ,3.49020e-08 , &
10878 3.57715e-08 ,3.66515e-08 ,3.75465e-08 ,3.84520e-08 ,3.93675e-08 , &
10879 4.02985e-08 ,4.12415e-08 ,4.21965e-08 ,4.31630e-08 ,4.41360e-08 , &
10880 4.51220e-08 ,4.61235e-08 ,4.71440e-08 ,4.81515e-08 ,4.91905e-08 , &
10881 5.02395e-08 ,5.12885e-08 ,5.23735e-08 ,5.34460e-08 ,5.45245e-08 , &
10882 5.56375e-08 ,5.67540e-08 ,5.78780e-08 ,5.90065e-08 ,6.01520e-08 , &
10883 6.13000e-08 ,6.24720e-08 ,6.36530e-08 ,6.48500e-08 ,6.60500e-08 , &
10884 6.72435e-08 ,6.84735e-08 ,6.97025e-08 ,7.09530e-08 ,7.21695e-08 , &
10885 7.34270e-08 ,7.47295e-08 ,7.59915e-08 ,7.72685e-08 ,7.85925e-08 /)
10886 totplnkderiv(101:150, 8) = (/ &
10887 7.98855e-08 ,8.12205e-08 ,8.25120e-08 ,8.38565e-08 ,8.52005e-08 , &
10888 8.65570e-08 ,8.79075e-08 ,8.92920e-08 ,9.06535e-08 ,9.20455e-08 , &
10889 9.34230e-08 ,9.48355e-08 ,9.62720e-08 ,9.76890e-08 ,9.90755e-08 , &
10890 1.00528e-07 ,1.01982e-07 ,1.03436e-07 ,1.04919e-07 ,1.06368e-07 , &
10891 1.07811e-07 ,1.09326e-07 ,1.10836e-07 ,1.12286e-07 ,1.13803e-07 , &
10892 1.15326e-07 ,1.16809e-07 ,1.18348e-07 ,1.19876e-07 ,1.21413e-07 , &
10893 1.22922e-07 ,1.24524e-07 ,1.26049e-07 ,1.27573e-07 ,1.29155e-07 , &
10894 1.30708e-07 ,1.32327e-07 ,1.33958e-07 ,1.35480e-07 ,1.37081e-07 , &
10895 1.38716e-07 ,1.40326e-07 ,1.41872e-07 ,1.43468e-07 ,1.45092e-07 , &
10896 1.46806e-07 ,1.48329e-07 ,1.49922e-07 ,1.51668e-07 ,1.53241e-07 /)
10897 totplnkderiv(151:181, 8) = (/ &
10898 1.54996e-07 ,1.56561e-07 ,1.58197e-07 ,1.59884e-07 ,1.61576e-07 , &
10899 1.63200e-07 ,1.64885e-07 ,1.66630e-07 ,1.68275e-07 ,1.69935e-07 , &
10900 1.71650e-07 ,1.73245e-07 ,1.75045e-07 ,1.76710e-07 ,1.78330e-07 , &
10901 1.79995e-07 ,1.81735e-07 ,1.83470e-07 ,1.85200e-07 ,1.86890e-07 , &
10902 1.88595e-07 ,1.90300e-07 ,1.91995e-07 ,1.93715e-07 ,1.95495e-07 , &
10903 1.97130e-07 ,1.98795e-07 ,2.00680e-07 ,2.02365e-07 ,2.04090e-07 , &
10905 totplnkderiv(1:50, 9) = (/ &
10906 1.85410e-09 ,1.96515e-09 ,2.08117e-09 ,2.20227e-09 ,2.32861e-09 , &
10907 2.46066e-09 ,2.59812e-09 ,2.74153e-09 ,2.89058e-09 ,3.04567e-09 , &
10908 3.20674e-09 ,3.37442e-09 ,3.54854e-09 ,3.72892e-09 ,3.91630e-09 , &
10909 4.11013e-09 ,4.31150e-09 ,4.52011e-09 ,4.73541e-09 ,4.95870e-09 , &
10910 5.18913e-09 ,5.42752e-09 ,5.67340e-09 ,5.92810e-09 ,6.18995e-09 , &
10911 6.46055e-09 ,6.73905e-09 ,7.02620e-09 ,7.32260e-09 ,7.62700e-09 , &
10912 7.94050e-09 ,8.26370e-09 ,8.59515e-09 ,8.93570e-09 ,9.28535e-09 , &
10913 9.64575e-09 ,1.00154e-08 ,1.03944e-08 ,1.07839e-08 ,1.11832e-08 , &
10914 1.15909e-08 ,1.20085e-08 ,1.24399e-08 ,1.28792e-08 ,1.33280e-08 , &
10915 1.37892e-08 ,1.42573e-08 ,1.47408e-08 ,1.52345e-08 ,1.57371e-08 /)
10916 totplnkderiv(51:100, 9) = (/ &
10917 1.62496e-08 ,1.67756e-08 ,1.73101e-08 ,1.78596e-08 ,1.84161e-08 , &
10918 1.89869e-08 ,1.95681e-08 ,2.01632e-08 ,2.07626e-08 ,2.13800e-08 , &
10919 2.20064e-08 ,2.26453e-08 ,2.32970e-08 ,2.39595e-08 ,2.46340e-08 , &
10920 2.53152e-08 ,2.60158e-08 ,2.67235e-08 ,2.74471e-08 ,2.81776e-08 , &
10921 2.89233e-08 ,2.96822e-08 ,3.04488e-08 ,3.12298e-08 ,3.20273e-08 , &
10922 3.28304e-08 ,3.36455e-08 ,3.44765e-08 ,3.53195e-08 ,3.61705e-08 , &
10923 3.70385e-08 ,3.79155e-08 ,3.88065e-08 ,3.97055e-08 ,4.06210e-08 , &
10924 4.15490e-08 ,4.24825e-08 ,4.34355e-08 ,4.43920e-08 ,4.53705e-08 , &
10925 4.63560e-08 ,4.73565e-08 ,4.83655e-08 ,4.93815e-08 ,5.04180e-08 , &
10926 5.14655e-08 ,5.25175e-08 ,5.35865e-08 ,5.46720e-08 ,5.57670e-08 /)
10927 totplnkderiv(101:150, 9) = (/ &
10928 5.68640e-08 ,5.79825e-08 ,5.91140e-08 ,6.02515e-08 ,6.13985e-08 , &
10929 6.25525e-08 ,6.37420e-08 ,6.49220e-08 ,6.61145e-08 ,6.73185e-08 , &
10930 6.85520e-08 ,6.97760e-08 ,7.10050e-08 ,7.22650e-08 ,7.35315e-08 , &
10931 7.48035e-08 ,7.60745e-08 ,7.73740e-08 ,7.86870e-08 ,7.99845e-08 , &
10932 8.13325e-08 ,8.26615e-08 ,8.40010e-08 ,8.53640e-08 ,8.67235e-08 , &
10933 8.80960e-08 ,8.95055e-08 ,9.08945e-08 ,9.23045e-08 ,9.37100e-08 , &
10934 9.51555e-08 ,9.65630e-08 ,9.80235e-08 ,9.94920e-08 ,1.00966e-07 , &
10935 1.02434e-07 ,1.03898e-07 ,1.05386e-07 ,1.06905e-07 ,1.08418e-07 , &
10936 1.09926e-07 ,1.11454e-07 ,1.13010e-07 ,1.14546e-07 ,1.16106e-07 , &
10937 1.17652e-07 ,1.19264e-07 ,1.20817e-07 ,1.22395e-07 ,1.24024e-07 /)
10938 totplnkderiv(151:181, 9) = (/ &
10939 1.25585e-07 ,1.27213e-07 ,1.28817e-07 ,1.30472e-07 ,1.32088e-07 , &
10940 1.33752e-07 ,1.35367e-07 ,1.37018e-07 ,1.38698e-07 ,1.40394e-07 , &
10941 1.42026e-07 ,1.43796e-07 ,1.45438e-07 ,1.47175e-07 ,1.48866e-07 , &
10942 1.50576e-07 ,1.52281e-07 ,1.54018e-07 ,1.55796e-07 ,1.57515e-07 , &
10943 1.59225e-07 ,1.60989e-07 ,1.62754e-07 ,1.64532e-07 ,1.66285e-07 , &
10944 1.68070e-07 ,1.69870e-07 ,1.71625e-07 ,1.73440e-07 ,1.75275e-07 , &
10946 totplnkderiv(1:50,10) = (/ &
10947 7.14917e-10 ,7.64833e-10 ,8.17460e-10 ,8.72980e-10 ,9.31380e-10 , &
10948 9.92940e-10 ,1.05746e-09 ,1.12555e-09 ,1.19684e-09 ,1.27162e-09 , &
10949 1.35001e-09 ,1.43229e-09 ,1.51815e-09 ,1.60831e-09 ,1.70271e-09 , &
10950 1.80088e-09 ,1.90365e-09 ,2.01075e-09 ,2.12261e-09 ,2.23924e-09 , &
10951 2.36057e-09 ,2.48681e-09 ,2.61814e-09 ,2.75506e-09 ,2.89692e-09 , &
10952 3.04423e-09 ,3.19758e-09 ,3.35681e-09 ,3.52113e-09 ,3.69280e-09 , &
10953 3.86919e-09 ,4.05205e-09 ,4.24184e-09 ,4.43877e-09 ,4.64134e-09 , &
10954 4.85088e-09 ,5.06670e-09 ,5.29143e-09 ,5.52205e-09 ,5.75980e-09 , &
10955 6.00550e-09 ,6.25840e-09 ,6.51855e-09 ,6.78800e-09 ,7.06435e-09 , &
10956 7.34935e-09 ,7.64220e-09 ,7.94470e-09 ,8.25340e-09 ,8.57030e-09 /)
10957 totplnkderiv(51:100,10) = (/ &
10958 8.89680e-09 ,9.23255e-09 ,9.57770e-09 ,9.93045e-09 ,1.02932e-08 , &
10959 1.06649e-08 ,1.10443e-08 ,1.14348e-08 ,1.18350e-08 ,1.22463e-08 , &
10960 1.26679e-08 ,1.30949e-08 ,1.35358e-08 ,1.39824e-08 ,1.44425e-08 , &
10961 1.49126e-08 ,1.53884e-08 ,1.58826e-08 ,1.63808e-08 ,1.68974e-08 , &
10962 1.74159e-08 ,1.79447e-08 ,1.84886e-08 ,1.90456e-08 ,1.96124e-08 , &
10963 2.01863e-08 ,2.07737e-08 ,2.13720e-08 ,2.19837e-08 ,2.26044e-08 , &
10964 2.32396e-08 ,2.38856e-08 ,2.45344e-08 ,2.52055e-08 ,2.58791e-08 , &
10965 2.65706e-08 ,2.72758e-08 ,2.79852e-08 ,2.87201e-08 ,2.94518e-08 , &
10966 3.02063e-08 ,3.09651e-08 ,3.17357e-08 ,3.25235e-08 ,3.33215e-08 , &
10967 3.41285e-08 ,3.49485e-08 ,3.57925e-08 ,3.66330e-08 ,3.74765e-08 /)
10968 totplnkderiv(101:150,10) = (/ &
10969 3.83675e-08 ,3.92390e-08 ,4.01330e-08 ,4.10340e-08 ,4.19585e-08 , &
10970 4.28815e-08 ,4.38210e-08 ,4.47770e-08 ,4.57575e-08 ,4.67325e-08 , &
10971 4.77170e-08 ,4.87205e-08 ,4.97410e-08 ,5.07620e-08 ,5.18180e-08 , &
10972 5.28540e-08 ,5.39260e-08 ,5.50035e-08 ,5.60885e-08 ,5.71900e-08 , &
10973 5.82940e-08 ,5.94380e-08 ,6.05690e-08 ,6.17185e-08 ,6.28860e-08 , &
10974 6.40670e-08 ,6.52300e-08 ,6.64225e-08 ,6.76485e-08 ,6.88715e-08 , &
10975 7.00750e-08 ,7.13760e-08 ,7.25910e-08 ,7.38860e-08 ,7.51290e-08 , &
10976 7.64420e-08 ,7.77550e-08 ,7.90725e-08 ,8.03825e-08 ,8.17330e-08 , &
10977 8.30810e-08 ,8.44330e-08 ,8.57720e-08 ,8.72115e-08 ,8.85800e-08 , &
10978 8.99945e-08 ,9.13905e-08 ,9.28345e-08 ,9.42665e-08 ,9.56765e-08 /)
10979 totplnkderiv(151:181,10) = (/ &
10980 9.72000e-08 ,9.86780e-08 ,1.00105e-07 ,1.01616e-07 ,1.03078e-07 , &
10981 1.04610e-07 ,1.06154e-07 ,1.07639e-07 ,1.09242e-07 ,1.10804e-07 , &
10982 1.12384e-07 ,1.13871e-07 ,1.15478e-07 ,1.17066e-07 ,1.18703e-07 , &
10983 1.20294e-07 ,1.21930e-07 ,1.23543e-07 ,1.25169e-07 ,1.26806e-07 , &
10984 1.28503e-07 ,1.30233e-07 ,1.31834e-07 ,1.33596e-07 ,1.35283e-07 , &
10985 1.36947e-07 ,1.38594e-07 ,1.40362e-07 ,1.42131e-07 ,1.43823e-07 , &
10987 totplnkderiv(1:50,11) = (/ &
10988 2.25919e-10 ,2.43810e-10 ,2.62866e-10 ,2.83125e-10 ,3.04676e-10 , &
10989 3.27536e-10 ,3.51796e-10 ,3.77498e-10 ,4.04714e-10 ,4.33528e-10 , &
10990 4.64000e-10 ,4.96185e-10 ,5.30165e-10 ,5.65999e-10 ,6.03749e-10 , &
10991 6.43579e-10 ,6.85479e-10 ,7.29517e-10 ,7.75810e-10 ,8.24440e-10 , &
10992 8.75520e-10 ,9.29065e-10 ,9.85175e-10 ,1.04405e-09 ,1.10562e-09 , &
10993 1.17005e-09 ,1.23742e-09 ,1.30780e-09 ,1.38141e-09 ,1.45809e-09 , &
10994 1.53825e-09 ,1.62177e-09 ,1.70884e-09 ,1.79942e-09 ,1.89390e-09 , &
10995 1.99205e-09 ,2.09429e-09 ,2.20030e-09 ,2.31077e-09 ,2.42510e-09 , &
10996 2.54410e-09 ,2.66754e-09 ,2.79529e-09 ,2.92777e-09 ,3.06498e-09 , &
10997 3.20691e-09 ,3.35450e-09 ,3.50653e-09 ,3.66427e-09 ,3.82723e-09 /)
10998 totplnkderiv(51:100,11) = (/ &
10999 3.99549e-09 ,4.16911e-09 ,4.34892e-09 ,4.53415e-09 ,4.72504e-09 , &
11000 4.92197e-09 ,5.12525e-09 ,5.33485e-09 ,5.55085e-09 ,5.77275e-09 , &
11001 6.00105e-09 ,6.23650e-09 ,6.47855e-09 ,6.72735e-09 ,6.98325e-09 , &
11002 7.24695e-09 ,7.51730e-09 ,7.79480e-09 ,8.07975e-09 ,8.37170e-09 , &
11003 8.67195e-09 ,8.98050e-09 ,9.29575e-09 ,9.61950e-09 ,9.95150e-09 , &
11004 1.02912e-08 ,1.06397e-08 ,1.09964e-08 ,1.13611e-08 ,1.17348e-08 , &
11005 1.21158e-08 ,1.25072e-08 ,1.29079e-08 ,1.33159e-08 ,1.37342e-08 , &
11006 1.41599e-08 ,1.45966e-08 ,1.50438e-08 ,1.54964e-08 ,1.59605e-08 , &
11007 1.64337e-08 ,1.69189e-08 ,1.74134e-08 ,1.79136e-08 ,1.84272e-08 , &
11008 1.89502e-08 ,1.94845e-08 ,2.00248e-08 ,2.05788e-08 ,2.11455e-08 /)
11009 totplnkderiv(101:150,11) = (/ &
11010 2.17159e-08 ,2.23036e-08 ,2.28983e-08 ,2.35033e-08 ,2.41204e-08 , &
11011 2.47485e-08 ,2.53860e-08 ,2.60331e-08 ,2.66891e-08 ,2.73644e-08 , &
11012 2.80440e-08 ,2.87361e-08 ,2.94412e-08 ,3.01560e-08 ,3.08805e-08 , &
11013 3.16195e-08 ,3.23690e-08 ,3.31285e-08 ,3.39015e-08 ,3.46820e-08 , &
11014 3.54770e-08 ,3.62805e-08 ,3.70960e-08 ,3.79295e-08 ,3.87715e-08 , &
11015 3.96185e-08 ,4.04860e-08 ,4.13600e-08 ,4.22500e-08 ,4.31490e-08 , &
11016 4.40610e-08 ,4.49810e-08 ,4.59205e-08 ,4.68650e-08 ,4.78260e-08 , &
11017 4.87970e-08 ,4.97790e-08 ,5.07645e-08 ,5.17730e-08 ,5.27960e-08 , &
11018 5.38285e-08 ,5.48650e-08 ,5.59205e-08 ,5.69960e-08 ,5.80690e-08 , &
11019 5.91570e-08 ,6.02640e-08 ,6.13750e-08 ,6.25015e-08 ,6.36475e-08 /)
11020 totplnkderiv(151:181,11) = (/ &
11021 6.47950e-08 ,6.59510e-08 ,6.71345e-08 ,6.83175e-08 ,6.95250e-08 , &
11022 7.07325e-08 ,7.19490e-08 ,7.31880e-08 ,7.44315e-08 ,7.56880e-08 , &
11023 7.69500e-08 ,7.82495e-08 ,7.95330e-08 ,8.08450e-08 ,8.21535e-08 , &
11024 8.34860e-08 ,8.48330e-08 ,8.61795e-08 ,8.75480e-08 ,8.89235e-08 , &
11025 9.03060e-08 ,9.17045e-08 ,9.31140e-08 ,9.45240e-08 ,9.59720e-08 , &
11026 9.74140e-08 ,9.88825e-08 ,1.00347e-07 ,1.01825e-07 ,1.03305e-07 , &
11028 totplnkderiv(1:50,12) = (/ &
11029 2.91689e-11 ,3.20300e-11 ,3.51272e-11 ,3.84803e-11 ,4.21014e-11 , &
11030 4.60107e-11 ,5.02265e-11 ,5.47685e-11 ,5.96564e-11 ,6.49111e-11 , &
11031 7.05522e-11 ,7.66060e-11 ,8.30974e-11 ,9.00441e-11 ,9.74820e-11 , &
11032 1.05435e-10 ,1.13925e-10 ,1.22981e-10 ,1.32640e-10 ,1.42933e-10 , &
11033 1.53882e-10 ,1.65527e-10 ,1.77903e-10 ,1.91054e-10 ,2.05001e-10 , &
11034 2.19779e-10 ,2.35448e-10 ,2.52042e-10 ,2.69565e-10 ,2.88128e-10 , &
11035 3.07714e-10 ,3.28370e-10 ,3.50238e-10 ,3.73235e-10 ,3.97433e-10 , &
11036 4.22964e-10 ,4.49822e-10 ,4.78042e-10 ,5.07721e-10 ,5.38915e-10 , &
11037 5.71610e-10 ,6.05916e-10 ,6.41896e-10 ,6.79600e-10 ,7.19110e-10 , &
11038 7.60455e-10 ,8.03625e-10 ,8.48870e-10 ,8.96080e-10 ,9.45490e-10 /)
11039 totplnkderiv(51:100,12) = (/ &
11040 9.96930e-10 ,1.05071e-09 ,1.10679e-09 ,1.16521e-09 ,1.22617e-09 , &
11041 1.28945e-09 ,1.35554e-09 ,1.42427e-09 ,1.49574e-09 ,1.56984e-09 , &
11042 1.64695e-09 ,1.72715e-09 ,1.81034e-09 ,1.89656e-09 ,1.98613e-09 , &
11043 2.07898e-09 ,2.17515e-09 ,2.27498e-09 ,2.37826e-09 ,2.48517e-09 , &
11044 2.59566e-09 ,2.71004e-09 ,2.82834e-09 ,2.95078e-09 ,3.07686e-09 , &
11045 3.20739e-09 ,3.34232e-09 ,3.48162e-09 ,3.62515e-09 ,3.77337e-09 , &
11046 3.92614e-09 ,4.08317e-09 ,4.24567e-09 ,4.41272e-09 ,4.58524e-09 , &
11047 4.76245e-09 ,4.94450e-09 ,5.13235e-09 ,5.32535e-09 ,5.52415e-09 , &
11048 5.72770e-09 ,5.93815e-09 ,6.15315e-09 ,6.37525e-09 ,6.60175e-09 , &
11049 6.83485e-09 ,7.07490e-09 ,7.32060e-09 ,7.57225e-09 ,7.83035e-09 /)
11050 totplnkderiv(101:150,12) = (/ &
11051 8.09580e-09 ,8.36620e-09 ,8.64410e-09 ,8.93110e-09 ,9.22170e-09 , &
11052 9.52055e-09 ,9.82595e-09 ,1.01399e-08 ,1.04613e-08 ,1.07878e-08 , &
11053 1.11223e-08 ,1.14667e-08 ,1.18152e-08 ,1.21748e-08 ,1.25410e-08 , &
11054 1.29147e-08 ,1.32948e-08 ,1.36858e-08 ,1.40827e-08 ,1.44908e-08 , &
11055 1.49040e-08 ,1.53284e-08 ,1.57610e-08 ,1.61995e-08 ,1.66483e-08 , &
11056 1.71068e-08 ,1.75714e-08 ,1.80464e-08 ,1.85337e-08 ,1.90249e-08 , &
11057 1.95309e-08 ,2.00407e-08 ,2.05333e-08 ,2.10929e-08 ,2.16346e-08 , &
11058 2.21829e-08 ,2.27402e-08 ,2.33112e-08 ,2.38922e-08 ,2.44802e-08 , &
11059 2.50762e-08 ,2.56896e-08 ,2.63057e-08 ,2.69318e-08 ,2.75705e-08 , &
11060 2.82216e-08 ,2.88787e-08 ,2.95505e-08 ,3.02335e-08 ,3.09215e-08 /)
11061 totplnkderiv(151:181,12) = (/ &
11062 3.16235e-08 ,3.23350e-08 ,3.30590e-08 ,3.37960e-08 ,3.45395e-08 , &
11063 3.52955e-08 ,3.60615e-08 ,3.68350e-08 ,3.76265e-08 ,3.84255e-08 , &
11064 3.92400e-08 ,4.00485e-08 ,4.08940e-08 ,4.17310e-08 ,4.25860e-08 , &
11065 4.34585e-08 ,4.43270e-08 ,4.52220e-08 ,4.61225e-08 ,4.70345e-08 , &
11066 4.79560e-08 ,4.89000e-08 ,4.98445e-08 ,5.07985e-08 ,5.17705e-08 , &
11067 5.27575e-08 ,5.37420e-08 ,5.47495e-08 ,5.57725e-08 ,5.68105e-08 , &
11069 totplnkderiv(1:50,13) = (/ &
11070 5.47482e-12 ,6.09637e-12 ,6.77874e-12 ,7.52703e-12 ,8.34784e-12 , &
11071 9.24486e-12 ,1.02246e-11 ,1.12956e-11 ,1.24615e-11 ,1.37321e-11 , &
11072 1.51131e-11 ,1.66129e-11 ,1.82416e-11 ,2.00072e-11 ,2.19187e-11 , &
11073 2.39828e-11 ,2.62171e-11 ,2.86290e-11 ,3.12283e-11 ,3.40276e-11 , &
11074 3.70433e-11 ,4.02847e-11 ,4.37738e-11 ,4.75070e-11 ,5.15119e-11 , &
11075 5.58120e-11 ,6.04059e-11 ,6.53208e-11 ,7.05774e-11 ,7.61935e-11 , &
11076 8.21832e-11 ,8.85570e-11 ,9.53575e-11 ,1.02592e-10 ,1.10298e-10 , &
11077 1.18470e-10 ,1.27161e-10 ,1.36381e-10 ,1.46161e-10 ,1.56529e-10 , &
11078 1.67521e-10 ,1.79142e-10 ,1.91423e-10 ,2.04405e-10 ,2.18123e-10 , &
11079 2.32608e-10 ,2.47889e-10 ,2.63994e-10 ,2.80978e-10 ,2.98843e-10 /)
11080 totplnkderiv(51:100,13) = (/ &
11081 3.17659e-10 ,3.37423e-10 ,3.58206e-10 ,3.80090e-10 ,4.02996e-10 , &
11082 4.27065e-10 ,4.52298e-10 ,4.78781e-10 ,5.06493e-10 ,5.35576e-10 , &
11083 5.65942e-10 ,5.97761e-10 ,6.31007e-10 ,6.65740e-10 ,7.02095e-10 , &
11084 7.39945e-10 ,7.79575e-10 ,8.20845e-10 ,8.63870e-10 ,9.08680e-10 , &
11085 9.55385e-10 ,1.00416e-09 ,1.05464e-09 ,1.10737e-09 ,1.16225e-09 , &
11086 1.21918e-09 ,1.27827e-09 ,1.33988e-09 ,1.40370e-09 ,1.46994e-09 , &
11087 1.53850e-09 ,1.60993e-09 ,1.68382e-09 ,1.76039e-09 ,1.83997e-09 , &
11088 1.92182e-09 ,2.00686e-09 ,2.09511e-09 ,2.18620e-09 ,2.28034e-09 , &
11089 2.37753e-09 ,2.47805e-09 ,2.58193e-09 ,2.68935e-09 ,2.80064e-09 , &
11090 2.91493e-09 ,3.03271e-09 ,3.15474e-09 ,3.27987e-09 ,3.40936e-09 /)
11091 totplnkderiv(101:150,13) = (/ &
11092 3.54277e-09 ,3.68019e-09 ,3.82173e-09 ,3.96703e-09 ,4.11746e-09 , &
11093 4.27104e-09 ,4.43020e-09 ,4.59395e-09 ,4.76060e-09 ,4.93430e-09 , &
11094 5.11085e-09 ,5.29280e-09 ,5.48055e-09 ,5.67300e-09 ,5.86950e-09 , &
11095 6.07160e-09 ,6.28015e-09 ,6.49295e-09 ,6.71195e-09 ,6.93455e-09 , &
11096 7.16470e-09 ,7.39985e-09 ,7.64120e-09 ,7.88885e-09 ,8.13910e-09 , &
11097 8.39930e-09 ,8.66535e-09 ,8.93600e-09 ,9.21445e-09 ,9.49865e-09 , &
11098 9.78845e-09 ,1.00856e-08 ,1.04361e-08 ,1.07018e-08 ,1.10164e-08 , &
11099 1.13438e-08 ,1.16748e-08 ,1.20133e-08 ,1.23575e-08 ,1.27117e-08 , &
11100 1.30708e-08 ,1.34383e-08 ,1.38138e-08 ,1.41985e-08 ,1.45859e-08 , &
11101 1.49846e-08 ,1.53879e-08 ,1.58042e-08 ,1.62239e-08 ,1.66529e-08 /)
11102 totplnkderiv(151:181,13) = (/ &
11103 1.70954e-08 ,1.75422e-08 ,1.79943e-08 ,1.84537e-08 ,1.89280e-08 , &
11104 1.94078e-08 ,1.98997e-08 ,2.03948e-08 ,2.08956e-08 ,2.14169e-08 , &
11105 2.19330e-08 ,2.24773e-08 ,2.30085e-08 ,2.35676e-08 ,2.41237e-08 , &
11106 2.46919e-08 ,2.52720e-08 ,2.58575e-08 ,2.64578e-08 ,2.70675e-08 , &
11107 2.76878e-08 ,2.83034e-08 ,2.89430e-08 ,2.95980e-08 ,3.02480e-08 , &
11108 3.09105e-08 ,3.15980e-08 ,3.22865e-08 ,3.29755e-08 ,3.36775e-08 , &
11110 totplnkderiv(1:50,14) = (/ &
11111 1.81489e-12 ,2.03846e-12 ,2.28659e-12 ,2.56071e-12 ,2.86352e-12 , &
11112 3.19789e-12 ,3.56668e-12 ,3.97211e-12 ,4.41711e-12 ,4.90616e-12 , &
11113 5.44153e-12 ,6.02790e-12 ,6.67001e-12 ,7.37018e-12 ,8.13433e-12 , &
11114 8.96872e-12 ,9.87526e-12 ,1.08601e-11 ,1.19328e-11 ,1.30938e-11 , &
11115 1.43548e-11 ,1.57182e-11 ,1.71916e-11 ,1.87875e-11 ,2.05091e-11 , &
11116 2.23652e-11 ,2.43627e-11 ,2.65190e-11 ,2.88354e-11 ,3.13224e-11 , &
11117 3.39926e-11 ,3.68664e-11 ,3.99372e-11 ,4.32309e-11 ,4.67496e-11 , &
11118 5.05182e-11 ,5.45350e-11 ,5.88268e-11 ,6.34126e-11 ,6.82878e-11 , &
11119 7.34973e-11 ,7.90201e-11 ,8.49075e-11 ,9.11725e-11 ,9.78235e-11 , &
11120 1.04856e-10 ,1.12342e-10 ,1.20278e-10 ,1.28680e-10 ,1.37560e-10 /)
11121 totplnkderiv(51:100,14) = (/ &
11122 1.46953e-10 ,1.56900e-10 ,1.67401e-10 ,1.78498e-10 ,1.90161e-10 , &
11123 2.02523e-10 ,2.15535e-10 ,2.29239e-10 ,2.43665e-10 ,2.58799e-10 , &
11124 2.74767e-10 ,2.91522e-10 ,3.09141e-10 ,3.27625e-10 ,3.47011e-10 , &
11125 3.67419e-10 ,3.88720e-10 ,4.11066e-10 ,4.34522e-10 ,4.59002e-10 , &
11126 4.84657e-10 ,5.11391e-10 ,5.39524e-10 ,5.68709e-10 ,5.99240e-10 , &
11127 6.31295e-10 ,6.64520e-10 ,6.99200e-10 ,7.35525e-10 ,7.73135e-10 , &
11128 8.12440e-10 ,8.53275e-10 ,8.95930e-10 ,9.40165e-10 ,9.86260e-10 , &
11129 1.03423e-09 ,1.08385e-09 ,1.13567e-09 ,1.18916e-09 ,1.24469e-09 , &
11130 1.30262e-09 ,1.36268e-09 ,1.42479e-09 ,1.48904e-09 ,1.55557e-09 , &
11131 1.62478e-09 ,1.69642e-09 ,1.77023e-09 ,1.84696e-09 ,1.92646e-09 /)
11132 totplnkderiv(101:150,14) = (/ &
11133 2.00831e-09 ,2.09299e-09 ,2.18007e-09 ,2.27093e-09 ,2.36398e-09 , &
11134 2.46020e-09 ,2.55985e-09 ,2.66230e-09 ,2.76795e-09 ,2.87667e-09 , &
11135 2.98971e-09 ,3.10539e-09 ,3.22462e-09 ,3.34779e-09 ,3.47403e-09 , &
11136 3.60419e-09 ,3.73905e-09 ,3.87658e-09 ,4.01844e-09 ,4.16535e-09 , &
11137 4.31470e-09 ,4.46880e-09 ,4.62765e-09 ,4.78970e-09 ,4.95735e-09 , &
11138 5.12890e-09 ,5.30430e-09 ,5.48595e-09 ,5.67010e-09 ,5.86145e-09 , &
11139 6.05740e-09 ,6.25725e-09 ,6.46205e-09 ,6.67130e-09 ,6.88885e-09 , &
11140 7.10845e-09 ,7.33450e-09 ,7.56700e-09 ,7.80440e-09 ,8.04465e-09 , &
11141 8.29340e-09 ,8.54820e-09 ,8.80790e-09 ,9.07195e-09 ,9.34605e-09 , &
11142 9.62005e-09 ,9.90685e-09 ,1.01939e-08 ,1.04938e-08 ,1.07957e-08 /)
11143 totplnkderiv(151:181,14) = (/ &
11144 1.11059e-08 ,1.14208e-08 ,1.17447e-08 ,1.20717e-08 ,1.24088e-08 , &
11145 1.27490e-08 ,1.31020e-08 ,1.34601e-08 ,1.38231e-08 ,1.41966e-08 , &
11146 1.45767e-08 ,1.49570e-08 ,1.53503e-08 ,1.57496e-08 ,1.61663e-08 , &
11147 1.65784e-08 ,1.70027e-08 ,1.74290e-08 ,1.78730e-08 ,1.83235e-08 , &
11148 1.87810e-08 ,1.92418e-08 ,1.97121e-08 ,2.01899e-08 ,2.05787e-08 , &
11149 2.11784e-08 ,2.16824e-08 ,2.21931e-08 ,2.27235e-08 ,2.32526e-08 , &
11151 totplnkderiv(1:50,15) = (/ &
11152 5.39905e-13 ,6.11835e-13 ,6.92224e-13 ,7.81886e-13 ,8.81851e-13 , &
11153 9.93072e-13 ,1.11659e-12 ,1.25364e-12 ,1.40562e-12 ,1.57359e-12 , &
11154 1.75937e-12 ,1.96449e-12 ,2.19026e-12 ,2.43892e-12 ,2.71249e-12 , &
11155 3.01233e-12 ,3.34163e-12 ,3.70251e-12 ,4.09728e-12 ,4.52885e-12 , &
11156 4.99939e-12 ,5.51242e-12 ,6.07256e-12 ,6.68167e-12 ,7.34274e-12 , &
11157 8.06178e-12 ,8.84185e-12 ,9.68684e-12 ,1.06020e-11 ,1.15909e-11 , &
11158 1.26610e-11 ,1.38158e-11 ,1.50620e-11 ,1.64047e-11 ,1.78508e-11 , &
11159 1.94055e-11 ,2.10805e-11 ,2.28753e-11 ,2.48000e-11 ,2.68699e-11 , &
11160 2.90824e-11 ,3.14526e-11 ,3.39882e-11 ,3.67020e-11 ,3.95914e-11 , &
11161 4.26870e-11 ,4.59824e-11 ,4.94926e-11 ,5.32302e-11 ,5.72117e-11 /)
11162 totplnkderiv(51:100,15) = (/ &
11163 6.14475e-11 ,6.59483e-11 ,7.07393e-11 ,7.57999e-11 ,8.11980e-11 , &
11164 8.68920e-11 ,9.29390e-11 ,9.93335e-11 ,1.06101e-10 ,1.13263e-10 , &
11165 1.20827e-10 ,1.28819e-10 ,1.37255e-10 ,1.46163e-10 ,1.55547e-10 , &
11166 1.65428e-10 ,1.75837e-10 ,1.86816e-10 ,1.98337e-10 ,2.10476e-10 , &
11167 2.23218e-10 ,2.36600e-10 ,2.50651e-10 ,2.65425e-10 ,2.80895e-10 , &
11168 2.97102e-10 ,3.14100e-10 ,3.31919e-10 ,3.50568e-10 ,3.70064e-10 , &
11169 3.90464e-10 ,4.11813e-10 ,4.34111e-10 ,4.57421e-10 ,4.81717e-10 , &
11170 5.07039e-10 ,5.33569e-10 ,5.61137e-10 ,5.89975e-10 ,6.19980e-10 , &
11171 6.51170e-10 ,6.83650e-10 ,7.17520e-10 ,7.52735e-10 ,7.89390e-10 , &
11172 8.27355e-10 ,8.66945e-10 ,9.08020e-10 ,9.50665e-10 ,9.95055e-10 /)
11173 totplnkderiv(101:150,15) = (/ &
11174 1.04101e-09 ,1.08864e-09 ,1.13823e-09 ,1.18923e-09 ,1.24257e-09 , &
11175 1.29741e-09 ,1.35442e-09 ,1.41347e-09 ,1.47447e-09 ,1.53767e-09 , &
11176 1.60322e-09 ,1.67063e-09 ,1.74033e-09 ,1.81256e-09 ,1.88704e-09 , &
11177 1.96404e-09 ,2.04329e-09 ,2.12531e-09 ,2.21032e-09 ,2.29757e-09 , &
11178 2.38739e-09 ,2.48075e-09 ,2.57628e-09 ,2.67481e-09 ,2.77627e-09 , &
11179 2.88100e-09 ,2.98862e-09 ,3.09946e-09 ,3.21390e-09 ,3.33105e-09 , &
11180 3.45185e-09 ,3.57599e-09 ,3.70370e-09 ,3.83512e-09 ,3.96909e-09 , &
11181 4.10872e-09 ,4.25070e-09 ,4.39605e-09 ,4.54670e-09 ,4.70015e-09 , &
11182 4.85850e-09 ,5.02050e-09 ,5.18655e-09 ,5.35815e-09 ,5.53180e-09 , &
11183 5.71225e-09 ,5.89495e-09 ,6.08260e-09 ,6.27485e-09 ,6.47345e-09 /)
11184 totplnkderiv(151:181,15) = (/ &
11185 6.67520e-09 ,6.88310e-09 ,7.09400e-09 ,7.31140e-09 ,7.53350e-09 , &
11186 7.76040e-09 ,7.99215e-09 ,8.22850e-09 ,8.47235e-09 ,8.71975e-09 , &
11187 8.97360e-09 ,9.23365e-09 ,9.49950e-09 ,9.76965e-09 ,1.00441e-08 , &
11188 1.03270e-08 ,1.06158e-08 ,1.09112e-08 ,1.12111e-08 ,1.15172e-08 , &
11189 1.18263e-08 ,1.21475e-08 ,1.24735e-08 ,1.28027e-08 ,1.32023e-08 , &
11190 1.34877e-08 ,1.38399e-08 ,1.42000e-08 ,1.45625e-08 ,1.49339e-08 , &
11192 totplnkderiv(1:50,16) = (/ &
11193 4.38799e-14 ,5.04835e-14 ,5.79773e-14 ,6.64627e-14 ,7.60706e-14 , &
11194 8.69213e-14 ,9.91554e-14 ,1.12932e-13 ,1.28419e-13 ,1.45809e-13 , &
11195 1.65298e-13 ,1.87109e-13 ,2.11503e-13 ,2.38724e-13 ,2.69058e-13 , &
11196 3.02878e-13 ,3.40423e-13 ,3.82128e-13 ,4.28390e-13 ,4.79625e-13 , &
11197 5.36292e-13 ,5.98933e-13 ,6.68066e-13 ,7.44216e-13 ,8.28159e-13 , &
11198 9.20431e-13 ,1.02180e-12 ,1.13307e-12 ,1.25504e-12 ,1.38863e-12 , &
11199 1.53481e-12 ,1.69447e-12 ,1.86896e-12 ,2.05903e-12 ,2.26637e-12 , &
11200 2.49193e-12 ,2.73736e-12 ,3.00416e-12 ,3.29393e-12 ,3.60781e-12 , &
11201 3.94805e-12 ,4.31675e-12 ,4.71543e-12 ,5.14627e-12 ,5.61226e-12 , &
11202 6.11456e-12 ,6.65585e-12 ,7.23969e-12 ,7.86811e-12 ,8.54456e-12 /)
11203 totplnkderiv(51:100,16) = (/ &
11204 9.27075e-12 ,1.00516e-11 ,1.08898e-11 ,1.17884e-11 ,1.27514e-11 , &
11205 1.37839e-11 ,1.48893e-11 ,1.60716e-11 ,1.73333e-11 ,1.86849e-11 , &
11206 2.01237e-11 ,2.16610e-11 ,2.33001e-11 ,2.50440e-11 ,2.69035e-11 , &
11207 2.88827e-11 ,3.09881e-11 ,3.32234e-11 ,3.55981e-11 ,3.81193e-11 , &
11208 4.07946e-11 ,4.36376e-11 ,4.66485e-11 ,4.98318e-11 ,5.32080e-11 , &
11209 5.67754e-11 ,6.05524e-11 ,6.45450e-11 ,6.87639e-11 ,7.32160e-11 , &
11210 7.79170e-11 ,8.28780e-11 ,8.81045e-11 ,9.36200e-11 ,9.94280e-11 , &
11211 1.05545e-10 ,1.11982e-10 ,1.18752e-10 ,1.25866e-10 ,1.33350e-10 , &
11212 1.41210e-10 ,1.49469e-10 ,1.58143e-10 ,1.67233e-10 ,1.76760e-10 , &
11213 1.86758e-10 ,1.97236e-10 ,2.08227e-10 ,2.19723e-10 ,2.31737e-10 /)
11214 totplnkderiv(101:150,16) = (/ &
11215 2.44329e-10 ,2.57503e-10 ,2.71267e-10 ,2.85647e-10 ,3.00706e-10 , &
11216 3.16391e-10 ,3.32807e-10 ,3.49887e-10 ,3.67748e-10 ,3.86369e-10 , &
11217 4.05746e-10 ,4.25984e-10 ,4.47060e-10 ,4.68993e-10 ,4.91860e-10 , &
11218 5.15601e-10 ,5.40365e-10 ,5.66085e-10 ,5.92855e-10 ,6.20640e-10 , &
11219 6.49605e-10 ,6.79585e-10 ,7.10710e-10 ,7.43145e-10 ,7.76805e-10 , &
11220 8.11625e-10 ,8.47800e-10 ,8.85300e-10 ,9.24220e-10 ,9.64550e-10 , &
11221 1.00623e-09 ,1.04957e-09 ,1.09429e-09 ,1.14079e-09 ,1.18882e-09 , &
11222 1.23848e-09 ,1.28986e-09 ,1.34301e-09 ,1.39796e-09 ,1.45493e-09 , &
11223 1.51372e-09 ,1.57440e-09 ,1.63702e-09 ,1.70173e-09 ,1.76874e-09 , &
11224 1.83753e-09 ,1.90898e-09 ,1.98250e-09 ,2.05836e-09 ,2.13646e-09 /)
11225 totplnkderiv(151:181,16) = (/ &
11226 2.21710e-09 ,2.30027e-09 ,2.38591e-09 ,2.47432e-09 ,2.56503e-09 , &
11227 2.65878e-09 ,2.75516e-09 ,2.85432e-09 ,2.95688e-09 ,3.06201e-09 , &
11228 3.17023e-09 ,3.28153e-09 ,3.39604e-09 ,3.51391e-09 ,3.63517e-09 , &
11229 3.75955e-09 ,3.88756e-09 ,4.01880e-09 ,4.15405e-09 ,4.29255e-09 , &
11230 4.43535e-09 ,4.58145e-09 ,4.73165e-09 ,4.88560e-09 ,5.04390e-09 , &
11231 5.20630e-09 ,5.37255e-09 ,5.54355e-09 ,5.71915e-09 ,5.89855e-09 , &
11233 totplk16deriv(1:50) = (/ &
11234 4.35811e-14 ,5.01270e-14 ,5.75531e-14 ,6.59588e-14 ,7.54735e-14 , &
11235 8.62147e-14 ,9.83225e-14 ,1.11951e-13 ,1.27266e-13 ,1.44456e-13 , &
11236 1.63715e-13 ,1.85257e-13 ,2.09343e-13 ,2.36209e-13 ,2.66136e-13 , &
11237 2.99486e-13 ,3.36493e-13 ,3.77582e-13 ,4.23146e-13 ,4.73578e-13 , &
11238 5.29332e-13 ,5.90936e-13 ,6.58891e-13 ,7.33710e-13 ,8.16135e-13 , &
11239 9.06705e-13 ,1.00614e-12 ,1.11524e-12 ,1.23477e-12 ,1.36561e-12 , &
11240 1.50871e-12 ,1.66488e-12 ,1.83552e-12 ,2.02123e-12 ,2.22375e-12 , &
11241 2.44389e-12 ,2.68329e-12 ,2.94338e-12 ,3.22570e-12 ,3.53129e-12 , &
11242 3.86236e-12 ,4.22086e-12 ,4.60827e-12 ,5.02666e-12 ,5.47890e-12 , &
11243 5.96595e-12 ,6.49057e-12 ,7.05592e-12 ,7.66401e-12 ,8.31821e-12 /)
11244 totplk16deriv(51:100) = (/ &
11245 9.01998e-12 ,9.77390e-12 ,1.05826e-11 ,1.14491e-11 ,1.23769e-11 , &
11246 1.33709e-11 ,1.44341e-11 ,1.55706e-11 ,1.67821e-11 ,1.80793e-11 , &
11247 1.94586e-11 ,2.09316e-11 ,2.25007e-11 ,2.41685e-11 ,2.59454e-11 , &
11248 2.78356e-11 ,2.98440e-11 ,3.19744e-11 ,3.42355e-11 ,3.66340e-11 , &
11249 3.91772e-11 ,4.18773e-11 ,4.47339e-11 ,4.77509e-11 ,5.09490e-11 , &
11250 5.43240e-11 ,5.78943e-11 ,6.16648e-11 ,6.56445e-11 ,6.98412e-11 , &
11251 7.42680e-11 ,7.89335e-11 ,8.38450e-11 ,8.90220e-11 ,9.44695e-11 , &
11252 1.00197e-10 ,1.06221e-10 ,1.12550e-10 ,1.19193e-10 ,1.26175e-10 , &
11253 1.33498e-10 ,1.41188e-10 ,1.49251e-10 ,1.57693e-10 ,1.66530e-10 , &
11254 1.75798e-10 ,1.85495e-10 ,1.95661e-10 ,2.06275e-10 ,2.17357e-10 /)
11255 totplk16deriv(101:150) = (/ &
11256 2.28959e-10 ,2.41085e-10 ,2.53739e-10 ,2.66944e-10 ,2.80755e-10 , &
11257 2.95121e-10 ,3.10141e-10 ,3.25748e-10 ,3.42057e-10 ,3.59026e-10 , &
11258 3.76668e-10 ,3.95066e-10 ,4.14211e-10 ,4.34111e-10 ,4.54818e-10 , &
11259 4.76295e-10 ,4.98681e-10 ,5.21884e-10 ,5.46000e-10 ,5.71015e-10 , &
11260 5.97065e-10 ,6.23965e-10 ,6.51865e-10 ,6.80905e-10 ,7.11005e-10 , &
11261 7.42100e-10 ,7.74350e-10 ,8.07745e-10 ,8.42355e-10 ,8.78185e-10 , &
11262 9.15130e-10 ,9.53520e-10 ,9.93075e-10 ,1.03415e-09 ,1.07649e-09 , &
11263 1.12021e-09 ,1.16539e-09 ,1.21207e-09 ,1.26025e-09 ,1.31014e-09 , &
11264 1.36156e-09 ,1.41453e-09 ,1.46909e-09 ,1.52540e-09 ,1.58368e-09 , &
11265 1.64334e-09 ,1.70527e-09 ,1.76888e-09 ,1.83442e-09 ,1.90182e-09 /)
11266 totplk16deriv(151:181) = (/ &
11267 1.97128e-09 ,2.04281e-09 ,2.11635e-09 ,2.19219e-09 ,2.26979e-09 , &
11268 2.34989e-09 ,2.43219e-09 ,2.51660e-09 ,2.60396e-09 ,2.69317e-09 , &
11269 2.78501e-09 ,2.87927e-09 ,2.97600e-09 ,3.07548e-09 ,3.17772e-09 , &
11270 3.28235e-09 ,3.38982e-09 ,3.49985e-09 ,3.61307e-09 ,3.72883e-09 , &
11271 3.84805e-09 ,3.96975e-09 ,4.09465e-09 ,4.22240e-09 ,4.35370e-09 , &
11272 4.48800e-09 ,4.62535e-09 ,4.76640e-09 ,4.91110e-09 ,5.05850e-09 , &
11275 end subroutine lwavplankderiv
11277 end module rrtmg_lw_setcoef_f
11279 module rrtmg_lw_init_f
11281 ! --------------------------------------------------------------------------
11283 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
11284 ! | This software may be used, copied, or redistributed as long as it is |
11285 ! | not sold and this copyright notice is reproduced on each copy made. |
11286 ! | This model is provided as is without any express or implied warranties. |
11287 ! | (http://www.rtweb.aer.com/) |
11289 ! --------------------------------------------------------------------------
11291 ! ------- Modules -------
11292 ! use parkind, only : im => kind , rb => kind
11294 use rrtmg_lw_setcoef_f, only: lwatmref, lwavplank, lwavplankderiv
11300 ! **************************************************************************
11301 subroutine rrtmg_lw_ini(cpdair)
11302 ! **************************************************************************
11304 ! Original version: Michael J. Iacono; July, 1998
11305 ! First revision for GCMs: September, 1998
11306 ! Second revision for RRTM_V3.0: September, 2002
11308 ! This subroutine performs calculations necessary for the initialization
11309 ! of the longwave model. Lookup tables are computed for use in the LW
11310 ! radiative transfer, and input absorption coefficient data for each
11311 ! spectral band are reduced from 256 g-point intervals to 140.
11312 ! **************************************************************************
11314 use parrrtm_f, only : mg, nbndlw, ngptlw
11315 use rrlw_tbl_f, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl
11316 use rrlw_vsn_f, only: hvrini, hnamini
11318 real , intent(in) :: cpdair ! Specific heat capacity of dry air
11319 ! at constant pressure at 273 K
11322 ! ------- Local -------
11324 integer :: itr, ibnd, igc, ig, ind, ipr
11325 integer :: igcsm, iprsm
11327 real :: wtsum, wtsm(mg) !
11330 real , parameter :: expeps = 1.e-20 ! Smallest value for exponential table
11332 ! ------- Definitions -------
11333 ! Arrays for 10000-point look-up tables:
11334 ! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer)
11335 ! EXP_TBL Exponential lookup table for ransmittance
11336 ! TFN_TBL Tau transition function; i.e. the transition of the Planck
11337 ! function from that for the mean layer temperature to that for
11338 ! the layer boundary temperature as a function of optical depth.
11339 ! The "linear in tau" method is used to make the table.
11340 ! PADE Pade approximation constant (= 0.278)
11341 ! BPADE Inverse of the Pade approximation constant
11344 hvrini = '$Revision: 1.1.1.2 $'
11346 ! Initialize model data
11347 call lwdatinit(cpdair)
11348 call lwcmbdat ! g-point interval reduction data
11349 call lwcldpr ! cloud optical properties
11350 call lwatmref ! reference MLS profile
11351 call lwavplank ! Planck function
11352 call lwavplankderiv ! Planck function derivative wrt temp
11353 ! Moved to module_ra_rrtmg_lw for WRF
11354 ! call lw_kgb01 ! molecular absorption coefficients
11371 ! Compute lookup tables for transmittance, tau transition function,
11372 ! and clear sky tau (for the cloudy sky radiative transfer). Tau is
11373 ! computed as a function of the tau transition function, transmittance
11374 ! is calculated as a function of tau, and the tau transition function
11375 ! is calculated using the linear in tau formulation at values of tau
11376 ! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables
11377 ! are computed at intervals of 0.001. The inverse of the constant used
11378 ! in the Pade approximation to the tau transition function is set to b.
11381 tau_tbl(ntbl) = 1.e10
11383 exp_tbl(ntbl) = expeps
11385 tfn_tbl(ntbl) = 1.0
11388 tfn = float(itr) / float(ntbl)
11389 tau_tbl(itr) = bpade * tfn / (1. - tfn)
11390 exp_tbl(itr) = exp(-tau_tbl(itr))
11391 if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps
11392 if (tau_tbl(itr) .lt. 0.06 ) then
11393 tfn_tbl(itr) = tau_tbl(itr)/6.
11395 tfn_tbl(itr) = 1. -2. *((1. /tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr))))
11399 ! Perform g-point reduction from 16 per band (256 total points) to
11400 ! a band dependant number (140 total points) for all absorption
11401 ! coefficient input data and Planck fraction input data.
11402 ! Compute relative weighting for new g-point combinations.
11407 if (ngc(ibnd).lt.mg) then
11408 do igc = 1,ngc(ibnd)
11411 do ipr = 1, ngn(igcsm)
11413 wtsum = wtsum + wt(iprsm)
11417 do ig = 1, ng(ibnd)
11418 ind = (ibnd-1)*mg + ig
11419 rwgt(ind) = wt(ig)/wtsm(ngm(ind))
11422 do ig = 1, ng(ibnd)
11424 ind = (ibnd-1)*mg + ig
11430 ! Reduce g-points for absorption coefficient data in each LW spectral band.
11449 end subroutine rrtmg_lw_ini
11451 !***************************************************************************
11452 subroutine lwdatinit(cpdair)
11453 !***************************************************************************
11455 ! --------- Modules ----------
11457 use parrrtm_f, only : maxxsec, maxinpx
11458 use rrlw_con_f, only: heatfac, grav, planck, boltz, &
11459 clight, avogad, alosmt, gascon, radcn1, radcn2, &
11465 real , intent(in) :: cpdair ! Specific heat capacity of dry air
11466 ! at constant pressure at 273 K
11469 ! Longwave spectral band limits (wavenumbers)
11470 wavenum1(:) = (/ 10. , 350. , 500. , 630. , 700. , 820. , &
11471 980. ,1080. ,1180. ,1390. ,1480. ,1800. , &
11472 2080. ,2250. ,2380. ,2600. /)
11473 wavenum2(:) = (/350. , 500. , 630. , 700. , 820. , 980. , &
11474 1080. ,1180. ,1390. ,1480. ,1800. ,2080. , &
11475 2250. ,2380. ,2600. ,3250. /)
11476 delwave(:) = (/340. , 150. , 130. , 70. , 120. , 160. , &
11477 100. , 100. , 210. , 90. , 320. , 280. , &
11478 170. , 130. , 220. , 650. /)
11480 ! Spectral band information
11481 ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/)
11482 nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/)
11483 nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/)
11485 ! nxmol - number of cross-sections input by user
11486 ! ixindx(i) - index of cross-section molecule corresponding to Ith
11487 ! cross-section specified by user
11488 ! = 0 -- not allowed in rrtm
11498 ixindx(5:maxinpx) = 0
11500 ! Fundamental physical constants from NIST 2002
11502 grav = 9.8066 ! Acceleration of gravity
11504 planck = 6.62606876e-27 ! Planck constant
11505 ! (ergs s; g cm2 s-1)
11506 boltz = 1.3806503e-16 ! Boltzmann constant
11507 ! (ergs K-1; g cm2 s-2 K-1)
11508 clight = 2.99792458e+10 ! Speed of light in a vacuum
11510 avogad = 6.02214199e+23 ! Avogadro constant
11512 alosmt = 2.6867775e+19 ! Loschmidt constant
11514 gascon = 8.31447200e+07 ! Molar gas constant
11516 radcn1 = 1.191042722e-12 ! First radiation constant
11518 radcn2 = 1.4387752 ! Second radiation constant
11520 sbcnst = 5.670400e-04 ! Stefan-Boltzmann constant
11522 secdy = 8.6400e4 ! Number of seconds per day
11525 ! units are generally cgs
11527 ! The first and second radiation constants are taken from NIST.
11528 ! They were previously obtained from the relations:
11529 ! radcn1 = 2.*planck*clight*clight*1.e-07
11530 ! radcn2 = planck*clight/boltz
11532 ! Heatfac is the factor by which delta-flux / delta-pressure is
11533 ! multiplied, with flux in W/m-2 and pressure in mbar, to get
11534 ! the heating rate in units of degrees/day. It is equal to:
11536 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
11537 ! Here, cpdair (1.004) is in units of J g-1 K-1, and the
11538 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
11539 ! = (9.8066)(86400)(1e-5)/(1.004)
11542 ! Modified value for consistency with CAM3:
11543 ! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p)
11544 ! Here, cpdair (1.00464) is in units of J g-1 K-1, and the
11545 ! constant (1.e-5) converts mb to Pa and g-1 to kg-1.
11546 ! = (9.80616)(86400)(1e-5)/(1.00464)
11547 ! heatfac = 8.43339130434
11549 ! Calculated value:
11550 ! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2)
11551 ! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2)
11552 ! converts mb to Pa when heatfac is multiplied by W m-2 mb-1.
11553 heatfac = grav * secdy / (cpdair * 1.e2 )
11555 end subroutine lwdatinit
11557 !***************************************************************************
11558 subroutine lwcmbdat
11559 !***************************************************************************
11563 ! ------- Definitions -------
11564 ! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands:
11565 ! This mapping from 256 to 140 points has been carefully selected to
11566 ! minimize the effect on the resulting fluxes and cooling rates, and
11567 ! caution should be used if the mapping is modified. The full 256
11568 ! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc.
11569 ! ngptlw The total number of new g-points
11570 ! ngc The number of new g-points in each band
11571 ! ngs The cumulative sum of new g-points for each band
11572 ! ngm The index of each new g-point relative to the original
11573 ! 16 g-points for each band.
11574 ! ngn The number of original g-points that are combined to make
11575 ! each new g-point in each band.
11576 ! ngb The band index for each new g-point.
11577 ! wt RRTM weights for 16 g-points.
11579 ! ------- Data statements -------
11580 ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/)
11581 ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/)
11582 ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1
11583 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2
11584 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3
11585 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4
11586 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5
11587 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6
11588 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7
11589 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8
11590 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9
11591 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10
11592 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11
11593 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12
11594 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13
11595 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14
11596 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15
11597 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16
11598 ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1
11599 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2
11600 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3
11601 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4
11602 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5
11603 2,2,2,2,2,2,2,2, & ! band 6
11604 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7
11605 2,2,2,2,2,2,2,2, & ! band 8
11606 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9
11607 2,2,2,2,4,4, & ! band 10
11608 1,1,2,2,2,2,3,3, & ! band 11
11609 1,1,1,1,2,2,4,4, & ! band 12
11610 3,3,4,6, & ! band 13
11614 ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1
11615 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2
11616 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3
11617 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4
11618 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5
11619 6,6,6,6,6,6,6,6, & ! band 6
11620 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7
11621 8,8,8,8,8,8,8,8, & ! band 8
11622 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9
11623 10,10,10,10,10,10, & ! band 10
11624 11,11,11,11,11,11,11,11, & ! band 11
11625 12,12,12,12,12,12,12,12, & ! band 12
11626 13,13,13,13, & ! band 13
11630 wt(:) = (/ 0.1527534276 , 0.1491729617 , 0.1420961469 , &
11631 0.1316886544 , 0.1181945205 , 0.1019300893 , &
11632 0.0832767040 , 0.0626720116 , 0.0424925000 , &
11633 0.0046269894 , 0.0038279891 , 0.0030260086 , &
11634 0.0022199750 , 0.0014140010 , 0.0005330000 , &
11637 end subroutine lwcmbdat
11639 !***************************************************************************
11641 !***************************************************************************
11643 ! Original version: MJIacono; July 1998
11644 ! Revision for GCMs: MJIacono; September 1998
11645 ! Revision for RRTMG: MJIacono, September 2002
11646 ! Revision for F90 reformatting: MJIacono, June 2006
11648 ! The subroutines CMBGB1->CMBGB16 input the absorption coefficient
11649 ! data for each band, which are defined for 16 g-points and 16 spectral
11650 ! bands. The data are combined with appropriate weighting following the
11651 ! g-point mapping arrays specified in RRTMINIT. Plank fraction data
11652 ! in arrays FRACREFA and FRACREFB are combined without weighting. All
11653 ! g-point reduced data are put into new arrays for use in RRTM.
11655 ! band 1: 10-350 cm-1 (low key - h2o; low minor - n2)
11656 ! (high key - h2o; high minor - n2)
11657 ! note: previous versions of rrtm band 1:
11658 ! 10-250 cm-1 (low - h2o; high - h2o)
11659 !***************************************************************************
11661 use parrrtm_f, only : mg, nbndlw, ngptlw, ng1
11662 use rrlw_kg01_f, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
11663 selfrefo, forrefo, &
11664 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, &
11667 ! ------- Local -------
11668 integer :: jt, jp, igc, ipr, iprsm
11669 real :: sumk, sumk1, sumk2, sumf1, sumf2
11677 do ipr = 1, ngn(igc)
11679 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm)
11681 ka(jt,jp,igc) = sumk
11688 do ipr = 1, ngn(igc)
11690 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm)
11692 kb(jt,jp,igc) = sumk
11701 do ipr = 1, ngn(igc)
11703 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm)
11705 selfref(jt,igc) = sumk
11713 do ipr = 1, ngn(igc)
11715 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm)
11717 forref(jt,igc) = sumk
11726 do ipr = 1, ngn(igc)
11728 sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm)
11729 sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm)
11731 ka_mn2(jt,igc) = sumk1
11732 kb_mn2(jt,igc) = sumk2
11740 do ipr = 1, ngn(igc)
11742 sumf1= sumf1+ fracrefao(iprsm)
11743 sumf2= sumf2+ fracrefbo(iprsm)
11745 fracrefa(igc) = sumf1
11746 fracrefb(igc) = sumf2
11749 end subroutine cmbgb1
11751 !***************************************************************************
11753 !***************************************************************************
11755 ! band 2: 350-500 cm-1 (low key - h2o; high key - h2o)
11757 ! note: previous version of rrtm band 2:
11758 ! 250 - 500 cm-1 (low - h2o; high - h2o)
11759 !***************************************************************************
11761 use parrrtm_f, only : mg, nbndlw, ngptlw, ng2
11762 use rrlw_kg02_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
11763 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
11765 ! ------- Local -------
11766 integer :: jt, jp, igc, ipr, iprsm
11767 real :: sumk, sumf1, sumf2
11775 do ipr = 1, ngn(ngs(1)+igc)
11777 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16)
11779 ka(jt,jp,igc) = sumk
11786 do ipr = 1, ngn(ngs(1)+igc)
11788 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16)
11790 kb(jt,jp,igc) = sumk
11799 do ipr = 1, ngn(ngs(1)+igc)
11801 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16)
11803 selfref(jt,igc) = sumk
11811 do ipr = 1, ngn(ngs(1)+igc)
11813 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16)
11815 forref(jt,igc) = sumk
11823 do ipr = 1, ngn(ngs(1)+igc)
11825 sumf1= sumf1+ fracrefao(iprsm)
11826 sumf2= sumf2+ fracrefbo(iprsm)
11828 fracrefa(igc) = sumf1
11829 fracrefb(igc) = sumf2
11832 end subroutine cmbgb2
11834 !***************************************************************************
11836 !***************************************************************************
11838 ! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o)
11839 ! (high key - h2o,co2; high minor - n2o)
11841 ! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2)
11842 !***************************************************************************
11844 use parrrtm_f, only : mg, nbndlw, ngptlw, ng3
11845 use rrlw_kg03_f, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, &
11846 selfrefo, forrefo, &
11847 fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, &
11850 ! ------- Local -------
11851 integer :: jn, jt, jp, igc, ipr, iprsm
11861 do ipr = 1, ngn(ngs(2)+igc)
11863 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32)
11865 ka(jn,jt,jp,igc) = sumk
11876 do ipr = 1, ngn(ngs(2)+igc)
11878 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32)
11880 kb(jn,jt,jp,igc) = sumk
11891 do ipr = 1, ngn(ngs(2)+igc)
11893 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
11895 ka_mn2o(jn,jt,igc) = sumk
11905 do ipr = 1, ngn(ngs(2)+igc)
11907 sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32)
11909 kb_mn2o(jn,jt,igc) = sumk
11918 do ipr = 1, ngn(ngs(2)+igc)
11920 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32)
11922 selfref(jt,igc) = sumk
11930 do ipr = 1, ngn(ngs(2)+igc)
11932 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32)
11934 forref(jt,igc) = sumk
11942 do ipr = 1, ngn(ngs(2)+igc)
11944 sumf = sumf + fracrefao(iprsm,jp)
11946 fracrefa(igc,jp) = sumf
11954 do ipr = 1, ngn(ngs(2)+igc)
11956 sumf = sumf + fracrefbo(iprsm,jp)
11958 fracrefb(igc,jp) = sumf
11962 end subroutine cmbgb3
11964 !***************************************************************************
11966 !***************************************************************************
11968 ! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2)
11970 ! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2)
11971 !***************************************************************************
11973 use parrrtm_f, only : mg, nbndlw, ngptlw, ng4
11974 use rrlw_kg04_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
11975 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
11977 ! ------- Local -------
11978 integer :: jn, jt, jp, igc, ipr, iprsm
11988 do ipr = 1, ngn(ngs(3)+igc)
11990 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48)
11992 ka(jn,jt,jp,igc) = sumk
12003 do ipr = 1, ngn(ngs(3)+igc)
12005 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48)
12007 kb(jn,jt,jp,igc) = sumk
12017 do ipr = 1, ngn(ngs(3)+igc)
12019 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48)
12021 selfref(jt,igc) = sumk
12029 do ipr = 1, ngn(ngs(3)+igc)
12031 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48)
12033 forref(jt,igc) = sumk
12041 do ipr = 1, ngn(ngs(3)+igc)
12043 sumf = sumf + fracrefao(iprsm,jp)
12045 fracrefa(igc,jp) = sumf
12053 do ipr = 1, ngn(ngs(3)+igc)
12055 sumf = sumf + fracrefbo(iprsm,jp)
12057 fracrefb(igc,jp) = sumf
12061 end subroutine cmbgb4
12063 !***************************************************************************
12065 !***************************************************************************
12067 ! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4)
12068 ! (high key - o3,co2)
12070 ! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2)
12071 !***************************************************************************
12073 use parrrtm_f, only : mg, nbndlw, ngptlw, ng5
12074 use rrlw_kg05_f, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, &
12075 selfrefo, forrefo, &
12076 fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, &
12079 ! ------- Local -------
12080 integer :: jn, jt, jp, igc, ipr, iprsm
12090 do ipr = 1, ngn(ngs(4)+igc)
12092 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64)
12094 ka(jn,jt,jp,igc) = sumk
12105 do ipr = 1, ngn(ngs(4)+igc)
12107 sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64)
12109 kb(jn,jt,jp,igc) = sumk
12120 do ipr = 1, ngn(ngs(4)+igc)
12122 sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64)
12124 ka_mo3(jn,jt,igc) = sumk
12133 do ipr = 1, ngn(ngs(4)+igc)
12135 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64)
12137 selfref(jt,igc) = sumk
12145 do ipr = 1, ngn(ngs(4)+igc)
12147 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64)
12149 forref(jt,igc) = sumk
12157 do ipr = 1, ngn(ngs(4)+igc)
12159 sumf = sumf + fracrefao(iprsm,jp)
12161 fracrefa(igc,jp) = sumf
12169 do ipr = 1, ngn(ngs(4)+igc)
12171 sumf = sumf + fracrefbo(iprsm,jp)
12173 fracrefb(igc,jp) = sumf
12180 do ipr = 1, ngn(ngs(4)+igc)
12182 sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64)
12187 end subroutine cmbgb5
12189 !***************************************************************************
12191 !***************************************************************************
12193 ! band 6: 820-980 cm-1 (low key - h2o; low minor - co2)
12194 ! (high key - nothing; high minor - cfc11, cfc12)
12196 ! old band 6: 820-980 cm-1 (low - h2o; high - nothing)
12197 !***************************************************************************
12199 use parrrtm_f, only : mg, nbndlw, ngptlw, ng6
12200 use rrlw_kg06_f, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, &
12201 selfrefo, forrefo, &
12202 fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, &
12205 ! ------- Local -------
12206 integer :: jt, jp, igc, ipr, iprsm
12207 real :: sumk, sumf, sumk1, sumk2
12215 do ipr = 1, ngn(ngs(5)+igc)
12217 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80)
12219 ka(jt,jp,igc) = sumk
12228 do ipr = 1, ngn(ngs(5)+igc)
12230 sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80)
12232 ka_mco2(jt,igc) = sumk
12240 do ipr = 1, ngn(ngs(5)+igc)
12242 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80)
12244 selfref(jt,igc) = sumk
12252 do ipr = 1, ngn(ngs(5)+igc)
12254 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80)
12256 forref(jt,igc) = sumk
12265 do ipr = 1, ngn(ngs(5)+igc)
12267 sumf = sumf + fracrefao(iprsm)
12268 sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80)
12269 sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80)
12271 fracrefa(igc) = sumf
12272 cfc11adj(igc) = sumk1
12276 end subroutine cmbgb6
12278 !***************************************************************************
12280 !***************************************************************************
12282 ! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2)
12283 ! (high key - o3; high minor - co2)
12285 ! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3)
12286 !***************************************************************************
12288 use parrrtm_f, only : mg, nbndlw, ngptlw, ng7
12289 use rrlw_kg07_f, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, &
12290 selfrefo, forrefo, &
12291 fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, &
12294 ! ------- Local -------
12295 integer :: jn, jt, jp, igc, ipr, iprsm
12305 do ipr = 1, ngn(ngs(6)+igc)
12307 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96)
12309 ka(jn,jt,jp,igc) = sumk
12319 do ipr = 1, ngn(ngs(6)+igc)
12321 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96)
12323 kb(jt,jp,igc) = sumk
12333 do ipr = 1, ngn(ngs(6)+igc)
12335 sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96)
12337 ka_mco2(jn,jt,igc) = sumk
12346 do ipr = 1, ngn(ngs(6)+igc)
12348 sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96)
12350 kb_mco2(jt,igc) = sumk
12358 do ipr = 1, ngn(ngs(6)+igc)
12360 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96)
12362 selfref(jt,igc) = sumk
12370 do ipr = 1, ngn(ngs(6)+igc)
12372 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96)
12374 forref(jt,igc) = sumk
12382 do ipr = 1, ngn(ngs(6)+igc)
12384 sumf = sumf + fracrefao(iprsm,jp)
12386 fracrefa(igc,jp) = sumf
12393 do ipr = 1, ngn(ngs(6)+igc)
12395 sumf = sumf + fracrefbo(iprsm)
12397 fracrefb(igc) = sumf
12400 end subroutine cmbgb7
12402 !***************************************************************************
12404 !***************************************************************************
12406 ! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o)
12407 ! (high key - o3; high minor - co2, n2o)
12409 ! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3)
12410 !***************************************************************************
12412 use parrrtm_f, only : mg, nbndlw, ngptlw, ng8
12413 use rrlw_kg08_f, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
12414 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
12415 cfc12o, cfc22adjo, &
12416 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, &
12417 ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, &
12420 ! ------- Local -------
12421 integer :: jt, jp, igc, ipr, iprsm
12422 real :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2
12430 do ipr = 1, ngn(ngs(7)+igc)
12432 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112)
12434 ka(jt,jp,igc) = sumk
12443 do ipr = 1, ngn(ngs(7)+igc)
12445 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112)
12447 kb(jt,jp,igc) = sumk
12456 do ipr = 1, ngn(ngs(7)+igc)
12458 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112)
12460 selfref(jt,igc) = sumk
12468 do ipr = 1, ngn(ngs(7)+igc)
12470 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112)
12472 forref(jt,igc) = sumk
12484 do ipr = 1, ngn(ngs(7)+igc)
12486 sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112)
12487 sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112)
12488 sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112)
12489 sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112)
12490 sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112)
12492 ka_mco2(jt,igc) = sumk1
12493 kb_mco2(jt,igc) = sumk2
12494 ka_mo3(jt,igc) = sumk3
12495 ka_mn2o(jt,igc) = sumk4
12496 kb_mn2o(jt,igc) = sumk5
12506 do ipr = 1, ngn(ngs(7)+igc)
12508 sumf1= sumf1+ fracrefao(iprsm)
12509 sumf2= sumf2+ fracrefbo(iprsm)
12510 sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112)
12511 sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112)
12513 fracrefa(igc) = sumf1
12514 fracrefb(igc) = sumf2
12516 cfc22adj(igc) = sumk2
12519 end subroutine cmbgb8
12521 !***************************************************************************
12523 !***************************************************************************
12525 ! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o)
12526 ! (high key - ch4; high minor - n2o)!
12528 ! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4)
12529 !***************************************************************************
12531 use parrrtm_f, only : mg, nbndlw, ngptlw, ng9
12532 use rrlw_kg09_f, only: fracrefao, fracrefbo, kao, kao_mn2o, &
12533 kbo, kbo_mn2o, selfrefo, forrefo, &
12534 fracrefa, fracrefb, absa, ka, ka_mn2o, &
12535 absb, kb, kb_mn2o, selfref, forref
12537 ! ------- Local -------
12538 integer :: jn, jt, jp, igc, ipr, iprsm
12548 do ipr = 1, ngn(ngs(8)+igc)
12550 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128)
12552 ka(jn,jt,jp,igc) = sumk
12563 do ipr = 1, ngn(ngs(8)+igc)
12565 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128)
12567 kb(jt,jp,igc) = sumk
12577 do ipr = 1, ngn(ngs(8)+igc)
12579 sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128)
12581 ka_mn2o(jn,jt,igc) = sumk
12590 do ipr = 1, ngn(ngs(8)+igc)
12592 sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128)
12594 kb_mn2o(jt,igc) = sumk
12602 do ipr = 1, ngn(ngs(8)+igc)
12604 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128)
12606 selfref(jt,igc) = sumk
12614 do ipr = 1, ngn(ngs(8)+igc)
12616 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128)
12618 forref(jt,igc) = sumk
12626 do ipr = 1, ngn(ngs(8)+igc)
12628 sumf = sumf + fracrefao(iprsm,jp)
12630 fracrefa(igc,jp) = sumf
12637 do ipr = 1, ngn(ngs(8)+igc)
12639 sumf = sumf + fracrefbo(iprsm)
12641 fracrefb(igc) = sumf
12644 end subroutine cmbgb9
12646 !***************************************************************************
12648 !***************************************************************************
12650 ! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o)
12652 ! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o)
12653 !***************************************************************************
12655 use parrrtm_f, only : mg, nbndlw, ngptlw, ng10
12656 use rrlw_kg10_f, only: fracrefao, fracrefbo, kao, kbo, &
12657 selfrefo, forrefo, &
12658 fracrefa, fracrefb, absa, ka, absb, kb, &
12661 ! ------- Local -------
12662 integer :: jt, jp, igc, ipr, iprsm
12663 real :: sumk, sumf1, sumf2
12671 do ipr = 1, ngn(ngs(9)+igc)
12673 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144)
12675 ka(jt,jp,igc) = sumk
12685 do ipr = 1, ngn(ngs(9)+igc)
12687 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144)
12689 kb(jt,jp,igc) = sumk
12698 do ipr = 1, ngn(ngs(9)+igc)
12700 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144)
12702 selfref(jt,igc) = sumk
12710 do ipr = 1, ngn(ngs(9)+igc)
12712 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144)
12714 forref(jt,igc) = sumk
12722 do ipr = 1, ngn(ngs(9)+igc)
12724 sumf1= sumf1+ fracrefao(iprsm)
12725 sumf2= sumf2+ fracrefbo(iprsm)
12727 fracrefa(igc) = sumf1
12728 fracrefb(igc) = sumf2
12731 end subroutine cmbgb10
12733 !***************************************************************************
12735 !***************************************************************************
12737 ! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
12738 ! (high key - h2o; high minor - o2)
12740 ! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2)
12741 ! (high key - h2o; high minor - o2)
12742 !***************************************************************************
12744 use parrrtm_f, only : mg, nbndlw, ngptlw, ng11
12745 use rrlw_kg11_f, only: fracrefao, fracrefbo, kao, kao_mo2, &
12746 kbo, kbo_mo2, selfrefo, forrefo, &
12747 fracrefa, fracrefb, absa, ka, ka_mo2, &
12748 absb, kb, kb_mo2, selfref, forref
12750 ! ------- Local -------
12751 integer :: jt, jp, igc, ipr, iprsm
12752 real :: sumk, sumk1, sumk2, sumf1, sumf2
12760 do ipr = 1, ngn(ngs(10)+igc)
12762 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160)
12764 ka(jt,jp,igc) = sumk
12773 do ipr = 1, ngn(ngs(10)+igc)
12775 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160)
12777 kb(jt,jp,igc) = sumk
12787 do ipr = 1, ngn(ngs(10)+igc)
12789 sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160)
12790 sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160)
12792 ka_mo2(jt,igc) = sumk1
12793 kb_mo2(jt,igc) = sumk2
12801 do ipr = 1, ngn(ngs(10)+igc)
12803 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160)
12805 selfref(jt,igc) = sumk
12813 do ipr = 1, ngn(ngs(10)+igc)
12815 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160)
12817 forref(jt,igc) = sumk
12825 do ipr = 1, ngn(ngs(10)+igc)
12827 sumf1= sumf1+ fracrefao(iprsm)
12828 sumf2= sumf2+ fracrefbo(iprsm)
12830 fracrefa(igc) = sumf1
12831 fracrefb(igc) = sumf2
12834 end subroutine cmbgb11
12836 !***************************************************************************
12838 !***************************************************************************
12840 ! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
12842 ! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing)
12843 !***************************************************************************
12845 use parrrtm_f, only : mg, nbndlw, ngptlw, ng12
12846 use rrlw_kg12_f, only: fracrefao, kao, selfrefo, forrefo, &
12847 fracrefa, absa, ka, selfref, forref
12849 ! ------- Local -------
12850 integer :: jn, jt, jp, igc, ipr, iprsm
12860 do ipr = 1, ngn(ngs(11)+igc)
12862 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176)
12864 ka(jn,jt,jp,igc) = sumk
12874 do ipr = 1, ngn(ngs(11)+igc)
12876 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176)
12878 selfref(jt,igc) = sumk
12886 do ipr = 1, ngn(ngs(11)+igc)
12888 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176)
12890 forref(jt,igc) = sumk
12898 do ipr = 1, ngn(ngs(11)+igc)
12900 sumf = sumf + fracrefao(iprsm,jp)
12902 fracrefa(igc,jp) = sumf
12906 end subroutine cmbgb12
12908 !***************************************************************************
12910 !***************************************************************************
12912 ! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor)
12914 ! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing)
12915 !***************************************************************************
12917 use parrrtm_f, only : mg, nbndlw, ngptlw, ng13
12918 use rrlw_kg13_f, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
12919 kbo_mo3, selfrefo, forrefo, &
12920 fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, &
12921 kb_mo3, selfref, forref
12923 ! ------- Local -------
12924 integer :: jn, jt, jp, igc, ipr, iprsm
12925 real :: sumk, sumk1, sumk2, sumf
12934 do ipr = 1, ngn(ngs(12)+igc)
12936 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192)
12938 ka(jn,jt,jp,igc) = sumk
12950 do ipr = 1, ngn(ngs(12)+igc)
12952 sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192)
12953 sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192)
12955 ka_mco2(jn,jt,igc) = sumk1
12956 ka_mco(jn,jt,igc) = sumk2
12965 do ipr = 1, ngn(ngs(12)+igc)
12967 sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192)
12969 kb_mo3(jt,igc) = sumk
12977 do ipr = 1, ngn(ngs(12)+igc)
12979 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192)
12981 selfref(jt,igc) = sumk
12989 do ipr = 1, ngn(ngs(12)+igc)
12991 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192)
12993 forref(jt,igc) = sumk
13000 do ipr = 1, ngn(ngs(12)+igc)
13002 sumf = sumf + fracrefbo(iprsm)
13004 fracrefb(igc) = sumf
13011 do ipr = 1, ngn(ngs(12)+igc)
13013 sumf = sumf + fracrefao(iprsm,jp)
13015 fracrefa(igc,jp) = sumf
13019 end subroutine cmbgb13
13021 !***************************************************************************
13023 !***************************************************************************
13025 ! band 14: 2250-2380 cm-1 (low - co2; high - co2)
13027 ! old band 14: 2250-2380 cm-1 (low - co2; high - co2)
13028 !***************************************************************************
13030 use parrrtm_f, only : mg, nbndlw, ngptlw, ng14
13031 use rrlw_kg14_f, only: fracrefao, fracrefbo, kao, kbo, &
13032 selfrefo, forrefo, &
13033 fracrefa, fracrefb, absa, ka, absb, kb, &
13036 ! ------- Local -------
13037 integer :: jt, jp, igc, ipr, iprsm
13038 real :: sumk, sumf1, sumf2
13046 do ipr = 1, ngn(ngs(13)+igc)
13048 sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208)
13050 ka(jt,jp,igc) = sumk
13060 do ipr = 1, ngn(ngs(13)+igc)
13062 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208)
13064 kb(jt,jp,igc) = sumk
13073 do ipr = 1, ngn(ngs(13)+igc)
13075 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208)
13077 selfref(jt,igc) = sumk
13085 do ipr = 1, ngn(ngs(13)+igc)
13087 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208)
13089 forref(jt,igc) = sumk
13097 do ipr = 1, ngn(ngs(13)+igc)
13099 sumf1= sumf1+ fracrefao(iprsm)
13100 sumf2= sumf2+ fracrefbo(iprsm)
13102 fracrefa(igc) = sumf1
13103 fracrefb(igc) = sumf2
13106 end subroutine cmbgb14
13108 !***************************************************************************
13110 !***************************************************************************
13112 ! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2)
13115 ! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing)
13116 !***************************************************************************
13118 use parrrtm_f, only : mg, nbndlw, ngptlw, ng15
13119 use rrlw_kg15_f, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, &
13120 fracrefa, absa, ka, ka_mn2, selfref, forref
13122 ! ------- Local -------
13123 integer :: jn, jt, jp, igc, ipr, iprsm
13133 do ipr = 1, ngn(ngs(14)+igc)
13135 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224)
13137 ka(jn,jt,jp,igc) = sumk
13148 do ipr = 1, ngn(ngs(14)+igc)
13150 sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224)
13152 ka_mn2(jn,jt,igc) = sumk
13161 do ipr = 1, ngn(ngs(14)+igc)
13163 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224)
13165 selfref(jt,igc) = sumk
13173 do ipr = 1, ngn(ngs(14)+igc)
13175 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224)
13177 forref(jt,igc) = sumk
13185 do ipr = 1, ngn(ngs(14)+igc)
13187 sumf = sumf + fracrefao(iprsm,jp)
13189 fracrefa(igc,jp) = sumf
13193 end subroutine cmbgb15
13195 !***************************************************************************
13197 !***************************************************************************
13199 ! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4)
13201 ! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing)
13202 !***************************************************************************
13204 use parrrtm_f, only : mg, nbndlw, ngptlw, ng16
13205 use rrlw_kg16_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, &
13206 fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref
13208 ! ------- Local -------
13209 integer :: jn, jt, jp, igc, ipr, iprsm
13219 do ipr = 1, ngn(ngs(15)+igc)
13221 sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240)
13223 ka(jn,jt,jp,igc) = sumk
13234 do ipr = 1, ngn(ngs(15)+igc)
13236 sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240)
13238 kb(jt,jp,igc) = sumk
13247 do ipr = 1, ngn(ngs(15)+igc)
13249 sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240)
13251 selfref(jt,igc) = sumk
13259 do ipr = 1, ngn(ngs(15)+igc)
13261 sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240)
13263 forref(jt,igc) = sumk
13270 do ipr = 1, ngn(ngs(15)+igc)
13272 sumf = sumf + fracrefbo(iprsm)
13274 fracrefb(igc) = sumf
13281 do ipr = 1, ngn(ngs(15)+igc)
13283 sumf = sumf + fracrefao(iprsm,jp)
13285 fracrefa(igc,jp) = sumf
13289 end subroutine cmbgb16
13291 !***************************************************************************
13293 !***************************************************************************
13295 ! --------- Modules ----------
13297 use rrlw_cld_f, only: abscld1, absliq0, absliq1, &
13298 absice0, absice1, absice2, absice3
13302 ! ABSCLDn is the liquid water absorption coefficient (m2/g).
13304 abscld1 = 0.0602410
13306 ! Everything below is for INFLAG = 2.
13308 ! ABSICEn(J,IB) are the parameters needed to compute the liquid water
13309 ! absorption coefficient in spectral region IB for ICEFLAG=n. The units
13310 ! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)).
13313 absice0(:)= (/0.005 , 1.0 /)
13316 absice1(1,:) = (/0.0036 , 0.0068 , 0.0003 , 0.0016 , 0.0020 /)
13317 absice1(2,:) = (/1.136 , 0.600 , 1.338 , 1.166 , 1.118 /)
13319 ! For ICEFLAG = 2. In each band, the absorption
13320 ! coefficients are listed for a range of effective radii from 5.0
13321 ! to 131.0 microns in increments of 3.0 microns.
13322 ! Spherical Ice Particle Parameterization
13323 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
13324 absice2(:,1) = (/ &
13326 7.798999e-02 ,6.340479e-02 ,5.417973e-02 ,4.766245e-02 ,4.272663e-02 , &
13327 3.880939e-02 ,3.559544e-02 ,3.289241e-02 ,3.057511e-02 ,2.855800e-02 , &
13328 2.678022e-02 ,2.519712e-02 ,2.377505e-02 ,2.248806e-02 ,2.131578e-02 , &
13329 2.024194e-02 ,1.925337e-02 ,1.833926e-02 ,1.749067e-02 ,1.670007e-02 , &
13330 1.596113e-02 ,1.526845e-02 ,1.461739e-02 ,1.400394e-02 ,1.342462e-02 , &
13331 1.287639e-02 ,1.235656e-02 ,1.186279e-02 ,1.139297e-02 ,1.094524e-02 , &
13332 1.051794e-02 ,1.010956e-02 ,9.718755e-03 ,9.344316e-03 ,8.985139e-03 , &
13333 8.640223e-03 ,8.308656e-03 ,7.989606e-03 ,7.682312e-03 ,7.386076e-03 , &
13334 7.100255e-03 ,6.824258e-03 ,6.557540e-03 /)
13335 absice2(:,2) = (/ &
13337 2.784879e-02 ,2.709863e-02 ,2.619165e-02 ,2.529230e-02 ,2.443225e-02 , &
13338 2.361575e-02 ,2.284021e-02 ,2.210150e-02 ,2.139548e-02 ,2.071840e-02 , &
13339 2.006702e-02 ,1.943856e-02 ,1.883064e-02 ,1.824120e-02 ,1.766849e-02 , &
13340 1.711099e-02 ,1.656737e-02 ,1.603647e-02 ,1.551727e-02 ,1.500886e-02 , &
13341 1.451045e-02 ,1.402132e-02 ,1.354084e-02 ,1.306842e-02 ,1.260355e-02 , &
13342 1.214575e-02 ,1.169460e-02 ,1.124971e-02 ,1.081072e-02 ,1.037731e-02 , &
13343 9.949167e-03 ,9.526021e-03 ,9.107615e-03 ,8.693714e-03 ,8.284096e-03 , &
13344 7.878558e-03 ,7.476910e-03 ,7.078974e-03 ,6.684586e-03 ,6.293589e-03 , &
13345 5.905839e-03 ,5.521200e-03 ,5.139543e-03 /)
13346 absice2(:,3) = (/ &
13348 1.065397e-01 ,8.005726e-02 ,6.546428e-02 ,5.589131e-02 ,4.898681e-02 , &
13349 4.369932e-02 ,3.947901e-02 ,3.600676e-02 ,3.308299e-02 ,3.057561e-02 , &
13350 2.839325e-02 ,2.647040e-02 ,2.475872e-02 ,2.322164e-02 ,2.183091e-02 , &
13351 2.056430e-02 ,1.940407e-02 ,1.833586e-02 ,1.734787e-02 ,1.643034e-02 , &
13352 1.557512e-02 ,1.477530e-02 ,1.402501e-02 ,1.331924e-02 ,1.265364e-02 , &
13353 1.202445e-02 ,1.142838e-02 ,1.086257e-02 ,1.032445e-02 ,9.811791e-03 , &
13354 9.322587e-03 ,8.855053e-03 ,8.407591e-03 ,7.978763e-03 ,7.567273e-03 , &
13355 7.171949e-03 ,6.791728e-03 ,6.425642e-03 ,6.072809e-03 ,5.732424e-03 , &
13356 5.403748e-03 ,5.086103e-03 ,4.778865e-03 /)
13357 absice2(:,4) = (/ &
13359 1.804566e-01 ,1.168987e-01 ,8.680442e-02 ,6.910060e-02 ,5.738174e-02 , &
13360 4.902332e-02 ,4.274585e-02 ,3.784923e-02 ,3.391734e-02 ,3.068690e-02 , &
13361 2.798301e-02 ,2.568480e-02 ,2.370600e-02 ,2.198337e-02 ,2.046940e-02 , &
13362 1.912777e-02 ,1.793016e-02 ,1.685420e-02 ,1.588193e-02 ,1.499882e-02 , &
13363 1.419293e-02 ,1.345440e-02 ,1.277496e-02 ,1.214769e-02 ,1.156669e-02 , &
13364 1.102694e-02 ,1.052412e-02 ,1.005451e-02 ,9.614854e-03 ,9.202335e-03 , &
13365 8.814470e-03 ,8.449077e-03 ,8.104223e-03 ,7.778195e-03 ,7.469466e-03 , &
13366 7.176671e-03 ,6.898588e-03 ,6.634117e-03 ,6.382264e-03 ,6.142134e-03 , &
13367 5.912913e-03 ,5.693862e-03 ,5.484308e-03 /)
13368 absice2(:,5) = (/ &
13370 2.131806e-01 ,1.311372e-01 ,9.407171e-02 ,7.299442e-02 ,5.941273e-02 , &
13371 4.994043e-02 ,4.296242e-02 ,3.761113e-02 ,3.337910e-02 ,2.994978e-02 , &
13372 2.711556e-02 ,2.473461e-02 ,2.270681e-02 ,2.095943e-02 ,1.943839e-02 , &
13373 1.810267e-02 ,1.692057e-02 ,1.586719e-02 ,1.492275e-02 ,1.407132e-02 , &
13374 1.329989e-02 ,1.259780e-02 ,1.195618e-02 ,1.136761e-02 ,1.082583e-02 , &
13375 1.032552e-02 ,9.862158e-03 ,9.431827e-03 ,9.031157e-03 ,8.657217e-03 , &
13376 8.307449e-03 ,7.979609e-03 ,7.671724e-03 ,7.382048e-03 ,7.109032e-03 , &
13377 6.851298e-03 ,6.607615e-03 ,6.376881e-03 ,6.158105e-03 ,5.950394e-03 , &
13378 5.752942e-03 ,5.565019e-03 ,5.385963e-03 /)
13379 absice2(:,6) = (/ &
13381 1.546177e-01 ,1.039251e-01 ,7.910347e-02 ,6.412429e-02 ,5.399997e-02 , &
13382 4.664937e-02 ,4.104237e-02 ,3.660781e-02 ,3.300218e-02 ,3.000586e-02 , &
13383 2.747148e-02 ,2.529633e-02 ,2.340647e-02 ,2.174723e-02 ,2.027731e-02 , &
13384 1.896487e-02 ,1.778492e-02 ,1.671761e-02 ,1.574692e-02 ,1.485978e-02 , &
13385 1.404543e-02 ,1.329489e-02 ,1.260066e-02 ,1.195636e-02 ,1.135657e-02 , &
13386 1.079664e-02 ,1.027257e-02 ,9.780871e-03 ,9.318505e-03 ,8.882815e-03 , &
13387 8.471458e-03 ,8.082364e-03 ,7.713696e-03 ,7.363817e-03 ,7.031264e-03 , &
13388 6.714725e-03 ,6.413021e-03 ,6.125086e-03 ,5.849958e-03 ,5.586764e-03 , &
13389 5.334707e-03 ,5.093066e-03 ,4.861179e-03 /)
13390 absice2(:,7) = (/ &
13392 7.583404e-02 ,6.181558e-02 ,5.312027e-02 ,4.696039e-02 ,4.225986e-02 , &
13393 3.849735e-02 ,3.538340e-02 ,3.274182e-02 ,3.045798e-02 ,2.845343e-02 , &
13394 2.667231e-02 ,2.507353e-02 ,2.362606e-02 ,2.230595e-02 ,2.109435e-02 , &
13395 1.997617e-02 ,1.893916e-02 ,1.797328e-02 ,1.707016e-02 ,1.622279e-02 , &
13396 1.542523e-02 ,1.467241e-02 ,1.395997e-02 ,1.328414e-02 ,1.264164e-02 , &
13397 1.202958e-02 ,1.144544e-02 ,1.088697e-02 ,1.035218e-02 ,9.839297e-03 , &
13398 9.346733e-03 ,8.873057e-03 ,8.416980e-03 ,7.977335e-03 ,7.553066e-03 , &
13399 7.143210e-03 ,6.746888e-03 ,6.363297e-03 ,5.991700e-03 ,5.631422e-03 , &
13400 5.281840e-03 ,4.942378e-03 ,4.612505e-03 /)
13401 absice2(:,8) = (/ &
13403 9.022185e-02 ,6.922700e-02 ,5.710674e-02 ,4.898377e-02 ,4.305946e-02 , &
13404 3.849553e-02 ,3.484183e-02 ,3.183220e-02 ,2.929794e-02 ,2.712627e-02 , &
13405 2.523856e-02 ,2.357810e-02 ,2.210286e-02 ,2.078089e-02 ,1.958747e-02 , &
13406 1.850310e-02 ,1.751218e-02 ,1.660205e-02 ,1.576232e-02 ,1.498440e-02 , &
13407 1.426107e-02 ,1.358624e-02 ,1.295474e-02 ,1.236212e-02 ,1.180456e-02 , &
13408 1.127874e-02 ,1.078175e-02 ,1.031106e-02 ,9.864433e-03 ,9.439878e-03 , &
13409 9.035637e-03 ,8.650140e-03 ,8.281981e-03 ,7.929895e-03 ,7.592746e-03 , &
13410 7.269505e-03 ,6.959238e-03 ,6.661100e-03 ,6.374317e-03 ,6.098185e-03 , &
13411 5.832059e-03 ,5.575347e-03 ,5.327504e-03 /)
13412 absice2(:,9) = (/ &
13414 1.294087e-01 ,8.788217e-02 ,6.728288e-02 ,5.479720e-02 ,4.635049e-02 , &
13415 4.022253e-02 ,3.555576e-02 ,3.187259e-02 ,2.888498e-02 ,2.640843e-02 , &
13416 2.431904e-02 ,2.253038e-02 ,2.098024e-02 ,1.962267e-02 ,1.842293e-02 , &
13417 1.735426e-02 ,1.639571e-02 ,1.553060e-02 ,1.474552e-02 ,1.402953e-02 , &
13418 1.337363e-02 ,1.277033e-02 ,1.221336e-02 ,1.169741e-02 ,1.121797e-02 , &
13419 1.077117e-02 ,1.035369e-02 ,9.962643e-03 ,9.595509e-03 ,9.250088e-03 , &
13420 8.924447e-03 ,8.616876e-03 ,8.325862e-03 ,8.050057e-03 ,7.788258e-03 , &
13421 7.539388e-03 ,7.302478e-03 ,7.076656e-03 ,6.861134e-03 ,6.655197e-03 , &
13422 6.458197e-03 ,6.269543e-03 ,6.088697e-03 /)
13423 absice2(:,10) = (/ &
13425 1.593628e-01 ,1.014552e-01 ,7.458955e-02 ,5.903571e-02 ,4.887582e-02 , &
13426 4.171159e-02 ,3.638480e-02 ,3.226692e-02 ,2.898717e-02 ,2.631256e-02 , &
13427 2.408925e-02 ,2.221156e-02 ,2.060448e-02 ,1.921325e-02 ,1.799699e-02 , &
13428 1.692456e-02 ,1.597177e-02 ,1.511961e-02 ,1.435289e-02 ,1.365933e-02 , &
13429 1.302890e-02 ,1.245334e-02 ,1.192576e-02 ,1.144037e-02 ,1.099230e-02 , &
13430 1.057739e-02 ,1.019208e-02 ,9.833302e-03 ,9.498395e-03 ,9.185047e-03 , &
13431 8.891237e-03 ,8.615185e-03 ,8.355325e-03 ,8.110267e-03 ,7.878778e-03 , &
13432 7.659759e-03 ,7.452224e-03 ,7.255291e-03 ,7.068166e-03 ,6.890130e-03 , &
13433 6.720536e-03 ,6.558794e-03 ,6.404371e-03 /)
13434 absice2(:,11) = (/ &
13436 1.656227e-01 ,1.032129e-01 ,7.487359e-02 ,5.871431e-02 ,4.828355e-02 , &
13437 4.099989e-02 ,3.562924e-02 ,3.150755e-02 ,2.824593e-02 ,2.560156e-02 , &
13438 2.341503e-02 ,2.157740e-02 ,2.001169e-02 ,1.866199e-02 ,1.748669e-02 , &
13439 1.645421e-02 ,1.554015e-02 ,1.472535e-02 ,1.399457e-02 ,1.333553e-02 , &
13440 1.273821e-02 ,1.219440e-02 ,1.169725e-02 ,1.124104e-02 ,1.082096e-02 , &
13441 1.043290e-02 ,1.007336e-02 ,9.739338e-03 ,9.428223e-03 ,9.137756e-03 , &
13442 8.865964e-03 ,8.611115e-03 ,8.371686e-03 ,8.146330e-03 ,7.933852e-03 , &
13443 7.733187e-03 ,7.543386e-03 ,7.363597e-03 ,7.193056e-03 ,7.031072e-03 , &
13444 6.877024e-03 ,6.730348e-03 ,6.590531e-03 /)
13445 absice2(:,12) = (/ &
13447 9.194591e-02 ,6.446867e-02 ,4.962034e-02 ,4.042061e-02 ,3.418456e-02 , &
13448 2.968856e-02 ,2.629900e-02 ,2.365572e-02 ,2.153915e-02 ,1.980791e-02 , &
13449 1.836689e-02 ,1.714979e-02 ,1.610900e-02 ,1.520946e-02 ,1.442476e-02 , &
13450 1.373468e-02 ,1.312345e-02 ,1.257858e-02 ,1.209010e-02 ,1.164990e-02 , &
13451 1.125136e-02 ,1.088901e-02 ,1.055827e-02 ,1.025531e-02 ,9.976896e-03 , &
13452 9.720255e-03 ,9.483022e-03 ,9.263160e-03 ,9.058902e-03 ,8.868710e-03 , &
13453 8.691240e-03 ,8.525312e-03 ,8.369886e-03 ,8.224042e-03 ,8.086961e-03 , &
13454 7.957917e-03 ,7.836258e-03 ,7.721400e-03 ,7.612821e-03 ,7.510045e-03 , &
13455 7.412648e-03 ,7.320242e-03 ,7.232476e-03 /)
13456 absice2(:,13) = (/ &
13458 1.437021e-01 ,8.872535e-02 ,6.392420e-02 ,4.991833e-02 ,4.096790e-02 , &
13459 3.477881e-02 ,3.025782e-02 ,2.681909e-02 ,2.412102e-02 ,2.195132e-02 , &
13460 2.017124e-02 ,1.868641e-02 ,1.743044e-02 ,1.635529e-02 ,1.542540e-02 , &
13461 1.461388e-02 ,1.390003e-02 ,1.326766e-02 ,1.270395e-02 ,1.219860e-02 , &
13462 1.174326e-02 ,1.133107e-02 ,1.095637e-02 ,1.061442e-02 ,1.030126e-02 , &
13463 1.001352e-02 ,9.748340e-03 ,9.503256e-03 ,9.276155e-03 ,9.065205e-03 , &
13464 8.868808e-03 ,8.685571e-03 ,8.514268e-03 ,8.353820e-03 ,8.203272e-03 , &
13465 8.061776e-03 ,7.928578e-03 ,7.803001e-03 ,7.684443e-03 ,7.572358e-03 , &
13466 7.466258e-03 ,7.365701e-03 ,7.270286e-03 /)
13467 absice2(:,14) = (/ &
13469 1.288870e-01 ,8.160295e-02 ,5.964745e-02 ,4.703790e-02 ,3.888637e-02 , &
13470 3.320115e-02 ,2.902017e-02 ,2.582259e-02 ,2.330224e-02 ,2.126754e-02 , &
13471 1.959258e-02 ,1.819130e-02 ,1.700289e-02 ,1.598320e-02 ,1.509942e-02 , &
13472 1.432666e-02 ,1.364572e-02 ,1.304156e-02 ,1.250220e-02 ,1.201803e-02 , &
13473 1.158123e-02 ,1.118537e-02 ,1.082513e-02 ,1.049605e-02 ,1.019440e-02 , &
13474 9.916989e-03 ,9.661116e-03 ,9.424457e-03 ,9.205005e-03 ,9.001022e-03 , &
13475 8.810992e-03 ,8.633588e-03 ,8.467646e-03 ,8.312137e-03 ,8.166151e-03 , &
13476 8.028878e-03 ,7.899597e-03 ,7.777663e-03 ,7.662498e-03 ,7.553581e-03 , &
13477 7.450444e-03 ,7.352662e-03 ,7.259851e-03 /)
13478 absice2(:,15) = (/ &
13480 8.254229e-02 ,5.808787e-02 ,4.492166e-02 ,3.675028e-02 ,3.119623e-02 , &
13481 2.718045e-02 ,2.414450e-02 ,2.177073e-02 ,1.986526e-02 ,1.830306e-02 , &
13482 1.699991e-02 ,1.589698e-02 ,1.495199e-02 ,1.413374e-02 ,1.341870e-02 , &
13483 1.278883e-02 ,1.223002e-02 ,1.173114e-02 ,1.128322e-02 ,1.087900e-02 , &
13484 1.051254e-02 ,1.017890e-02 ,9.873991e-03 ,9.594347e-03 ,9.337044e-03 , &
13485 9.099589e-03 ,8.879842e-03 ,8.675960e-03 ,8.486341e-03 ,8.309594e-03 , &
13486 8.144500e-03 ,7.989986e-03 ,7.845109e-03 ,7.709031e-03 ,7.581007e-03 , &
13487 7.460376e-03 ,7.346544e-03 ,7.238978e-03 ,7.137201e-03 ,7.040780e-03 , &
13488 6.949325e-03 ,6.862483e-03 ,6.779931e-03 /)
13489 absice2(:,16) = (/ &
13491 1.382062e-01 ,8.643227e-02 ,6.282935e-02 ,4.934783e-02 ,4.063891e-02 , &
13492 3.455591e-02 ,3.007059e-02 ,2.662897e-02 ,2.390631e-02 ,2.169972e-02 , &
13493 1.987596e-02 ,1.834393e-02 ,1.703924e-02 ,1.591513e-02 ,1.493679e-02 , &
13494 1.407780e-02 ,1.331775e-02 ,1.264061e-02 ,1.203364e-02 ,1.148655e-02 , &
13495 1.099099e-02 ,1.054006e-02 ,1.012807e-02 ,9.750215e-03 ,9.402477e-03 , &
13496 9.081428e-03 ,8.784143e-03 ,8.508107e-03 ,8.251146e-03 ,8.011373e-03 , &
13497 7.787140e-03 ,7.577002e-03 ,7.379687e-03 ,7.194071e-03 ,7.019158e-03 , &
13498 6.854061e-03 ,6.697986e-03 ,6.550224e-03 ,6.410138e-03 ,6.277153e-03 , &
13499 6.150751e-03 ,6.030462e-03 ,5.915860e-03 /)
13501 ! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in
13502 ! increments of 3 microns.
13504 ! Hexagonal Ice Particle Parameterization
13505 ! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)]
13506 absice3(:,1) = (/ &
13508 3.110649e-03 ,4.666352e-02 ,6.606447e-02 ,6.531678e-02 ,6.012598e-02 , &
13509 5.437494e-02 ,4.906411e-02 ,4.441146e-02 ,4.040585e-02 ,3.697334e-02 , &
13510 3.403027e-02 ,3.149979e-02 ,2.931596e-02 ,2.742365e-02 ,2.577721e-02 , &
13511 2.433888e-02 ,2.307732e-02 ,2.196644e-02 ,2.098437e-02 ,2.011264e-02 , &
13512 1.933561e-02 ,1.863992e-02 ,1.801407e-02 ,1.744812e-02 ,1.693346e-02 , &
13513 1.646252e-02 ,1.602866e-02 ,1.562600e-02 ,1.524933e-02 ,1.489399e-02 , &
13514 1.455580e-02 ,1.423098e-02 ,1.391612e-02 ,1.360812e-02 ,1.330413e-02 , &
13515 1.300156e-02 ,1.269801e-02 ,1.239127e-02 ,1.207928e-02 ,1.176014e-02 , &
13516 1.143204e-02 ,1.109334e-02 ,1.074243e-02 ,1.037786e-02 ,9.998198e-03 , &
13518 absice3(:,2) = (/ &
13520 3.984966e-04 ,1.681097e-02 ,2.627680e-02 ,2.767465e-02 ,2.700722e-02 , &
13521 2.579180e-02 ,2.448677e-02 ,2.323890e-02 ,2.209096e-02 ,2.104882e-02 , &
13522 2.010547e-02 ,1.925003e-02 ,1.847128e-02 ,1.775883e-02 ,1.710358e-02 , &
13523 1.649769e-02 ,1.593449e-02 ,1.540829e-02 ,1.491429e-02 ,1.444837e-02 , &
13524 1.400704e-02 ,1.358729e-02 ,1.318654e-02 ,1.280258e-02 ,1.243346e-02 , &
13525 1.207750e-02 ,1.173325e-02 ,1.139941e-02 ,1.107487e-02 ,1.075861e-02 , &
13526 1.044975e-02 ,1.014753e-02 ,9.851229e-03 ,9.560240e-03 ,9.274003e-03 , &
13527 8.992020e-03 ,8.713845e-03 ,8.439074e-03 ,8.167346e-03 ,7.898331e-03 , &
13528 7.631734e-03 ,7.367286e-03 ,7.104742e-03 ,6.843882e-03 ,6.584504e-03 , &
13530 absice3(:,3) = (/ &
13532 6.933163e-02 ,8.540475e-02 ,7.701816e-02 ,6.771158e-02 ,5.986953e-02 , &
13533 5.348120e-02 ,4.824962e-02 ,4.390563e-02 ,4.024411e-02 ,3.711404e-02 , &
13534 3.440426e-02 ,3.203200e-02 ,2.993478e-02 ,2.806474e-02 ,2.638464e-02 , &
13535 2.486516e-02 ,2.348288e-02 ,2.221890e-02 ,2.105780e-02 ,1.998687e-02 , &
13536 1.899552e-02 ,1.807490e-02 ,1.721750e-02 ,1.641693e-02 ,1.566773e-02 , &
13537 1.496515e-02 ,1.430509e-02 ,1.368398e-02 ,1.309865e-02 ,1.254634e-02 , &
13538 1.202456e-02 ,1.153114e-02 ,1.106409e-02 ,1.062166e-02 ,1.020224e-02 , &
13539 9.804381e-03 ,9.426771e-03 ,9.068205e-03 ,8.727578e-03 ,8.403876e-03 , &
13540 8.096160e-03 ,7.803564e-03 ,7.525281e-03 ,7.260560e-03 ,7.008697e-03 , &
13542 absice3(:,4) = (/ &
13544 1.765735e-01 ,1.382700e-01 ,1.095129e-01 ,8.987475e-02 ,7.591185e-02 , &
13545 6.554169e-02 ,5.755500e-02 ,5.122083e-02 ,4.607610e-02 ,4.181475e-02 , &
13546 3.822697e-02 ,3.516432e-02 ,3.251897e-02 ,3.021073e-02 ,2.817876e-02 , &
13547 2.637607e-02 ,2.476582e-02 ,2.331871e-02 ,2.201113e-02 ,2.082388e-02 , &
13548 1.974115e-02 ,1.874983e-02 ,1.783894e-02 ,1.699922e-02 ,1.622280e-02 , &
13549 1.550296e-02 ,1.483390e-02 ,1.421064e-02 ,1.362880e-02 ,1.308460e-02 , &
13550 1.257468e-02 ,1.209611e-02 ,1.164628e-02 ,1.122287e-02 ,1.082381e-02 , &
13551 1.044725e-02 ,1.009154e-02 ,9.755166e-03 ,9.436783e-03 ,9.135163e-03 , &
13552 8.849193e-03 ,8.577856e-03 ,8.320225e-03 ,8.075451e-03 ,7.842755e-03 , &
13554 absice3(:,5) = (/ &
13556 2.339673e-01 ,1.692124e-01 ,1.291656e-01 ,1.033837e-01 ,8.562949e-02 , &
13557 7.273526e-02 ,6.298262e-02 ,5.537015e-02 ,4.927787e-02 ,4.430246e-02 , &
13558 4.017061e-02 ,3.669072e-02 ,3.372455e-02 ,3.116995e-02 ,2.894977e-02 , &
13559 2.700471e-02 ,2.528842e-02 ,2.376420e-02 ,2.240256e-02 ,2.117959e-02 , &
13560 2.007567e-02 ,1.907456e-02 ,1.816271e-02 ,1.732874e-02 ,1.656300e-02 , &
13561 1.585725e-02 ,1.520445e-02 ,1.459852e-02 ,1.403419e-02 ,1.350689e-02 , &
13562 1.301260e-02 ,1.254781e-02 ,1.210941e-02 ,1.169468e-02 ,1.130118e-02 , &
13563 1.092675e-02 ,1.056945e-02 ,1.022757e-02 ,9.899560e-03 ,9.584021e-03 , &
13564 9.279705e-03 ,8.985479e-03 ,8.700322e-03 ,8.423306e-03 ,8.153590e-03 , &
13566 absice3(:,6) = (/ &
13568 1.145369e-01 ,1.174566e-01 ,9.917866e-02 ,8.332990e-02 ,7.104263e-02 , &
13569 6.153370e-02 ,5.405472e-02 ,4.806281e-02 ,4.317918e-02 ,3.913795e-02 , &
13570 3.574916e-02 ,3.287437e-02 ,3.041067e-02 ,2.828017e-02 ,2.642292e-02 , &
13571 2.479206e-02 ,2.335051e-02 ,2.206851e-02 ,2.092195e-02 ,1.989108e-02 , &
13572 1.895958e-02 ,1.811385e-02 ,1.734245e-02 ,1.663573e-02 ,1.598545e-02 , &
13573 1.538456e-02 ,1.482700e-02 ,1.430750e-02 ,1.382150e-02 ,1.336499e-02 , &
13574 1.293447e-02 ,1.252685e-02 ,1.213939e-02 ,1.176968e-02 ,1.141555e-02 , &
13575 1.107508e-02 ,1.074655e-02 ,1.042839e-02 ,1.011923e-02 ,9.817799e-03 , &
13576 9.522962e-03 ,9.233688e-03 ,8.949041e-03 ,8.668171e-03 ,8.390301e-03 , &
13578 absice3(:,7) = (/ &
13580 1.222345e-02 ,5.344230e-02 ,5.523465e-02 ,5.128759e-02 ,4.676925e-02 , &
13581 4.266150e-02 ,3.910561e-02 ,3.605479e-02 ,3.342843e-02 ,3.115052e-02 , &
13582 2.915776e-02 ,2.739935e-02 ,2.583499e-02 ,2.443266e-02 ,2.316681e-02 , &
13583 2.201687e-02 ,2.096619e-02 ,2.000112e-02 ,1.911044e-02 ,1.828481e-02 , &
13584 1.751641e-02 ,1.679866e-02 ,1.612598e-02 ,1.549360e-02 ,1.489742e-02 , &
13585 1.433392e-02 ,1.380002e-02 ,1.329305e-02 ,1.281068e-02 ,1.235084e-02 , &
13586 1.191172e-02 ,1.149171e-02 ,1.108936e-02 ,1.070341e-02 ,1.033271e-02 , &
13587 9.976220e-03 ,9.633021e-03 ,9.302273e-03 ,8.983216e-03 ,8.675161e-03 , &
13588 8.377478e-03 ,8.089595e-03 ,7.810986e-03 ,7.541170e-03 ,7.279706e-03 , &
13590 absice3(:,8) = (/ &
13592 6.711058e-02 ,6.918198e-02 ,6.127484e-02 ,5.411944e-02 ,4.836902e-02 , &
13593 4.375293e-02 ,3.998077e-02 ,3.683587e-02 ,3.416508e-02 ,3.186003e-02 , &
13594 2.984290e-02 ,2.805671e-02 ,2.645895e-02 ,2.501733e-02 ,2.370689e-02 , &
13595 2.250808e-02 ,2.140532e-02 ,2.038609e-02 ,1.944018e-02 ,1.855918e-02 , &
13596 1.773609e-02 ,1.696504e-02 ,1.624106e-02 ,1.555990e-02 ,1.491793e-02 , &
13597 1.431197e-02 ,1.373928e-02 ,1.319743e-02 ,1.268430e-02 ,1.219799e-02 , &
13598 1.173682e-02 ,1.129925e-02 ,1.088393e-02 ,1.048961e-02 ,1.011516e-02 , &
13599 9.759543e-03 ,9.421813e-03 ,9.101089e-03 ,8.796559e-03 ,8.507464e-03 , &
13600 8.233098e-03 ,7.972798e-03 ,7.725942e-03 ,7.491940e-03 ,7.270238e-03 , &
13602 absice3(:,9) = (/ &
13604 1.236780e-01 ,9.222386e-02 ,7.383997e-02 ,6.204072e-02 ,5.381029e-02 , &
13605 4.770678e-02 ,4.296928e-02 ,3.916131e-02 ,3.601540e-02 ,3.335878e-02 , &
13606 3.107493e-02 ,2.908247e-02 ,2.732282e-02 ,2.575276e-02 ,2.433968e-02 , &
13607 2.305852e-02 ,2.188966e-02 ,2.081757e-02 ,1.982974e-02 ,1.891599e-02 , &
13608 1.806794e-02 ,1.727865e-02 ,1.654227e-02 ,1.585387e-02 ,1.520924e-02 , &
13609 1.460476e-02 ,1.403730e-02 ,1.350416e-02 ,1.300293e-02 ,1.253153e-02 , &
13610 1.208808e-02 ,1.167094e-02 ,1.127862e-02 ,1.090979e-02 ,1.056323e-02 , &
13611 1.023786e-02 ,9.932665e-03 ,9.646744e-03 ,9.379250e-03 ,9.129409e-03 , &
13612 8.896500e-03 ,8.679856e-03 ,8.478852e-03 ,8.292904e-03 ,8.121463e-03 , &
13614 absice3(:,10) = (/ &
13616 1.655966e-01 ,1.134205e-01 ,8.714344e-02 ,7.129241e-02 ,6.063739e-02 , &
13617 5.294203e-02 ,4.709309e-02 ,4.247476e-02 ,3.871892e-02 ,3.559206e-02 , &
13618 3.293893e-02 ,3.065226e-02 ,2.865558e-02 ,2.689288e-02 ,2.532221e-02 , &
13619 2.391150e-02 ,2.263582e-02 ,2.147549e-02 ,2.041476e-02 ,1.944089e-02 , &
13620 1.854342e-02 ,1.771371e-02 ,1.694456e-02 ,1.622989e-02 ,1.556456e-02 , &
13621 1.494415e-02 ,1.436491e-02 ,1.382354e-02 ,1.331719e-02 ,1.284339e-02 , &
13622 1.239992e-02 ,1.198486e-02 ,1.159647e-02 ,1.123323e-02 ,1.089375e-02 , &
13623 1.057679e-02 ,1.028124e-02 ,1.000607e-02 ,9.750376e-03 ,9.513303e-03 , &
13624 9.294082e-03 ,9.092003e-03 ,8.906412e-03 ,8.736702e-03 ,8.582314e-03 , &
13626 absice3(:,11) = (/ &
13628 1.775615e-01 ,1.180046e-01 ,8.929607e-02 ,7.233500e-02 ,6.108333e-02 , &
13629 5.303642e-02 ,4.696927e-02 ,4.221206e-02 ,3.836768e-02 ,3.518576e-02 , &
13630 3.250063e-02 ,3.019825e-02 ,2.819758e-02 ,2.643943e-02 ,2.487953e-02 , &
13631 2.348414e-02 ,2.222705e-02 ,2.108762e-02 ,2.004936e-02 ,1.909892e-02 , &
13632 1.822539e-02 ,1.741975e-02 ,1.667449e-02 ,1.598330e-02 ,1.534084e-02 , &
13633 1.474253e-02 ,1.418446e-02 ,1.366325e-02 ,1.317597e-02 ,1.272004e-02 , &
13634 1.229321e-02 ,1.189350e-02 ,1.151915e-02 ,1.116859e-02 ,1.084042e-02 , &
13635 1.053338e-02 ,1.024636e-02 ,9.978326e-03 ,9.728357e-03 ,9.495613e-03 , &
13636 9.279327e-03 ,9.078798e-03 ,8.893383e-03 ,8.722488e-03 ,8.565568e-03 , &
13638 absice3(:,12) = (/ &
13640 9.465447e-02 ,6.432047e-02 ,5.060973e-02 ,4.267283e-02 ,3.741843e-02 , &
13641 3.363096e-02 ,3.073531e-02 ,2.842405e-02 ,2.651789e-02 ,2.490518e-02 , &
13642 2.351273e-02 ,2.229056e-02 ,2.120335e-02 ,2.022541e-02 ,1.933763e-02 , &
13643 1.852546e-02 ,1.777763e-02 ,1.708528e-02 ,1.644134e-02 ,1.584009e-02 , &
13644 1.527684e-02 ,1.474774e-02 ,1.424955e-02 ,1.377957e-02 ,1.333549e-02 , &
13645 1.291534e-02 ,1.251743e-02 ,1.214029e-02 ,1.178265e-02 ,1.144337e-02 , &
13646 1.112148e-02 ,1.081609e-02 ,1.052642e-02 ,1.025178e-02 ,9.991540e-03 , &
13647 9.745130e-03 ,9.512038e-03 ,9.291797e-03 ,9.083980e-03 ,8.888195e-03 , &
13648 8.704081e-03 ,8.531306e-03 ,8.369560e-03 ,8.218558e-03 ,8.078032e-03 , &
13650 absice3(:,13) = (/ &
13652 1.560311e-01 ,9.961097e-02 ,7.502949e-02 ,6.115022e-02 ,5.214952e-02 , &
13653 4.578149e-02 ,4.099731e-02 ,3.724174e-02 ,3.419343e-02 ,3.165356e-02 , &
13654 2.949251e-02 ,2.762222e-02 ,2.598073e-02 ,2.452322e-02 ,2.321642e-02 , &
13655 2.203516e-02 ,2.096002e-02 ,1.997579e-02 ,1.907036e-02 ,1.823401e-02 , &
13656 1.745879e-02 ,1.673819e-02 ,1.606678e-02 ,1.544003e-02 ,1.485411e-02 , &
13657 1.430574e-02 ,1.379215e-02 ,1.331092e-02 ,1.285996e-02 ,1.243746e-02 , &
13658 1.204183e-02 ,1.167164e-02 ,1.132567e-02 ,1.100281e-02 ,1.070207e-02 , &
13659 1.042258e-02 ,1.016352e-02 ,9.924197e-03 ,9.703953e-03 ,9.502199e-03 , &
13660 9.318400e-03 ,9.152066e-03 ,9.002749e-03 ,8.870038e-03 ,8.753555e-03 , &
13662 absice3(:,14) = (/ &
13664 1.559547e-01 ,9.896700e-02 ,7.441231e-02 ,6.061469e-02 ,5.168730e-02 , &
13665 4.537821e-02 ,4.064106e-02 ,3.692367e-02 ,3.390714e-02 ,3.139438e-02 , &
13666 2.925702e-02 ,2.740783e-02 ,2.578547e-02 ,2.434552e-02 ,2.305506e-02 , &
13667 2.188910e-02 ,2.082842e-02 ,1.985789e-02 ,1.896553e-02 ,1.814165e-02 , &
13668 1.737839e-02 ,1.666927e-02 ,1.600891e-02 ,1.539279e-02 ,1.481712e-02 , &
13669 1.427865e-02 ,1.377463e-02 ,1.330266e-02 ,1.286068e-02 ,1.244689e-02 , &
13670 1.205973e-02 ,1.169780e-02 ,1.135989e-02 ,1.104492e-02 ,1.075192e-02 , &
13671 1.048004e-02 ,1.022850e-02 ,9.996611e-03 ,9.783753e-03 ,9.589361e-03 , &
13672 9.412924e-03 ,9.253977e-03 ,9.112098e-03 ,8.986903e-03 ,8.878039e-03 , &
13674 absice3(:,15) = (/ &
13676 1.102926e-01 ,7.176622e-02 ,5.530316e-02 ,4.606056e-02 ,4.006116e-02 , &
13677 3.579628e-02 ,3.256909e-02 ,3.001360e-02 ,2.791920e-02 ,2.615617e-02 , &
13678 2.464023e-02 ,2.331426e-02 ,2.213817e-02 ,2.108301e-02 ,2.012733e-02 , &
13679 1.925493e-02 ,1.845331e-02 ,1.771269e-02 ,1.702531e-02 ,1.638493e-02 , &
13680 1.578648e-02 ,1.522579e-02 ,1.469940e-02 ,1.420442e-02 ,1.373841e-02 , &
13681 1.329931e-02 ,1.288535e-02 ,1.249502e-02 ,1.212700e-02 ,1.178015e-02 , &
13682 1.145348e-02 ,1.114612e-02 ,1.085730e-02 ,1.058633e-02 ,1.033263e-02 , &
13683 1.009564e-02 ,9.874895e-03 ,9.669960e-03 ,9.480449e-03 ,9.306014e-03 , &
13684 9.146339e-03 ,9.001138e-03 ,8.870154e-03 ,8.753148e-03 ,8.649907e-03 , &
13686 absice3(:,16) = (/ &
13688 1.688344e-01 ,1.077072e-01 ,7.994467e-02 ,6.403862e-02 ,5.369850e-02 , &
13689 4.641582e-02 ,4.099331e-02 ,3.678724e-02 ,3.342069e-02 ,3.065831e-02 , &
13690 2.834557e-02 ,2.637680e-02 ,2.467733e-02 ,2.319286e-02 ,2.188299e-02 , &
13691 2.071701e-02 ,1.967121e-02 ,1.872692e-02 ,1.786931e-02 ,1.708641e-02 , &
13692 1.636846e-02 ,1.570743e-02 ,1.509665e-02 ,1.453052e-02 ,1.400433e-02 , &
13693 1.351407e-02 ,1.305631e-02 ,1.262810e-02 ,1.222688e-02 ,1.185044e-02 , &
13694 1.149683e-02 ,1.116436e-02 ,1.085153e-02 ,1.055701e-02 ,1.027961e-02 , &
13695 1.001831e-02 ,9.772141e-03 ,9.540280e-03 ,9.321966e-03 ,9.116517e-03 , &
13696 8.923315e-03 ,8.741803e-03 ,8.571472e-03 ,8.411860e-03 ,8.262543e-03 , &
13700 absliq0 = 0.0903614
13702 ! For LIQFLAG = 1. In each band, the absorption
13703 ! coefficients are listed for a range of effective radii from 2.5
13704 ! to 59.5 microns in increments of 1.0 micron.
13705 absliq1(:, 1) = (/ &
13707 1.64047e-03 , 6.90533e-02 , 7.72017e-02 , 7.78054e-02 , 7.69523e-02 , &
13708 7.58058e-02 , 7.46400e-02 , 7.35123e-02 , 7.24162e-02 , 7.13225e-02 , &
13709 6.99145e-02 , 6.66409e-02 , 6.36582e-02 , 6.09425e-02 , 5.84593e-02 , &
13710 5.61743e-02 , 5.40571e-02 , 5.20812e-02 , 5.02245e-02 , 4.84680e-02 , &
13711 4.67959e-02 , 4.51944e-02 , 4.36516e-02 , 4.21570e-02 , 4.07015e-02 , &
13712 3.92766e-02 , 3.78747e-02 , 3.64886e-02 , 3.53632e-02 , 3.41992e-02 , &
13713 3.31016e-02 , 3.20643e-02 , 3.10817e-02 , 3.01490e-02 , 2.92620e-02 , &
13714 2.84171e-02 , 2.76108e-02 , 2.68404e-02 , 2.61031e-02 , 2.53966e-02 , &
13715 2.47189e-02 , 2.40678e-02 , 2.34418e-02 , 2.28392e-02 , 2.22586e-02 , &
13716 2.16986e-02 , 2.11580e-02 , 2.06356e-02 , 2.01305e-02 , 1.96417e-02 , &
13717 1.91682e-02 , 1.87094e-02 , 1.82643e-02 , 1.78324e-02 , 1.74129e-02 , &
13718 1.70052e-02 , 1.66088e-02 , 1.62231e-02 /)
13719 absliq1(:, 2) = (/ &
13721 2.19486e-01 , 1.80687e-01 , 1.59150e-01 , 1.44731e-01 , 1.33703e-01 , &
13722 1.24355e-01 , 1.15756e-01 , 1.07318e-01 , 9.86119e-02 , 8.92739e-02 , &
13723 8.34911e-02 , 7.70773e-02 , 7.15240e-02 , 6.66615e-02 , 6.23641e-02 , &
13724 5.85359e-02 , 5.51020e-02 , 5.20032e-02 , 4.91916e-02 , 4.66283e-02 , &
13725 4.42813e-02 , 4.21236e-02 , 4.01330e-02 , 3.82905e-02 , 3.65797e-02 , &
13726 3.49869e-02 , 3.35002e-02 , 3.21090e-02 , 3.08957e-02 , 2.97601e-02 , &
13727 2.86966e-02 , 2.76984e-02 , 2.67599e-02 , 2.58758e-02 , 2.50416e-02 , &
13728 2.42532e-02 , 2.35070e-02 , 2.27997e-02 , 2.21284e-02 , 2.14904e-02 , &
13729 2.08834e-02 , 2.03051e-02 , 1.97536e-02 , 1.92271e-02 , 1.87239e-02 , &
13730 1.82425e-02 , 1.77816e-02 , 1.73399e-02 , 1.69162e-02 , 1.65094e-02 , &
13731 1.61187e-02 , 1.57430e-02 , 1.53815e-02 , 1.50334e-02 , 1.46981e-02 , &
13732 1.43748e-02 , 1.40628e-02 , 1.37617e-02 /)
13733 absliq1(:, 3) = (/ &
13735 2.95174e-01 , 2.34765e-01 , 1.98038e-01 , 1.72114e-01 , 1.52083e-01 , &
13736 1.35654e-01 , 1.21613e-01 , 1.09252e-01 , 9.81263e-02 , 8.79448e-02 , &
13737 8.12566e-02 , 7.44563e-02 , 6.86374e-02 , 6.36042e-02 , 5.92094e-02 , &
13738 5.53402e-02 , 5.19087e-02 , 4.88455e-02 , 4.60951e-02 , 4.36124e-02 , &
13739 4.13607e-02 , 3.93096e-02 , 3.74338e-02 , 3.57119e-02 , 3.41261e-02 , &
13740 3.26610e-02 , 3.13036e-02 , 3.00425e-02 , 2.88497e-02 , 2.78077e-02 , &
13741 2.68317e-02 , 2.59158e-02 , 2.50545e-02 , 2.42430e-02 , 2.34772e-02 , &
13742 2.27533e-02 , 2.20679e-02 , 2.14181e-02 , 2.08011e-02 , 2.02145e-02 , &
13743 1.96561e-02 , 1.91239e-02 , 1.86161e-02 , 1.81311e-02 , 1.76673e-02 , &
13744 1.72234e-02 , 1.67981e-02 , 1.63903e-02 , 1.59989e-02 , 1.56230e-02 , &
13745 1.52615e-02 , 1.49138e-02 , 1.45791e-02 , 1.42565e-02 , 1.39455e-02 , &
13746 1.36455e-02 , 1.33559e-02 , 1.30761e-02 /)
13747 absliq1(:, 4) = (/ &
13749 3.00925e-01 , 2.36949e-01 , 1.96947e-01 , 1.68692e-01 , 1.47190e-01 , &
13750 1.29986e-01 , 1.15719e-01 , 1.03568e-01 , 9.30028e-02 , 8.36658e-02 , &
13751 7.71075e-02 , 7.07002e-02 , 6.52284e-02 , 6.05024e-02 , 5.63801e-02 , &
13752 5.27534e-02 , 4.95384e-02 , 4.66690e-02 , 4.40925e-02 , 4.17664e-02 , &
13753 3.96559e-02 , 3.77326e-02 , 3.59727e-02 , 3.43561e-02 , 3.28662e-02 , &
13754 3.14885e-02 , 3.02110e-02 , 2.90231e-02 , 2.78948e-02 , 2.69109e-02 , &
13755 2.59884e-02 , 2.51217e-02 , 2.43058e-02 , 2.35364e-02 , 2.28096e-02 , &
13756 2.21218e-02 , 2.14700e-02 , 2.08515e-02 , 2.02636e-02 , 1.97041e-02 , &
13757 1.91711e-02 , 1.86625e-02 , 1.81769e-02 , 1.77126e-02 , 1.72683e-02 , &
13758 1.68426e-02 , 1.64344e-02 , 1.60427e-02 , 1.56664e-02 , 1.53046e-02 , &
13759 1.49565e-02 , 1.46214e-02 , 1.42985e-02 , 1.39871e-02 , 1.36866e-02 , &
13760 1.33965e-02 , 1.31162e-02 , 1.28453e-02 /)
13761 absliq1(:, 5) = (/ &
13763 2.64691e-01 , 2.12018e-01 , 1.78009e-01 , 1.53539e-01 , 1.34721e-01 , &
13764 1.19580e-01 , 1.06996e-01 , 9.62772e-02 , 8.69710e-02 , 7.87670e-02 , &
13765 7.29272e-02 , 6.70920e-02 , 6.20977e-02 , 5.77732e-02 , 5.39910e-02 , &
13766 5.06538e-02 , 4.76866e-02 , 4.50301e-02 , 4.26374e-02 , 4.04704e-02 , &
13767 3.84981e-02 , 3.66948e-02 , 3.50394e-02 , 3.35141e-02 , 3.21038e-02 , &
13768 3.07957e-02 , 2.95788e-02 , 2.84438e-02 , 2.73790e-02 , 2.64390e-02 , &
13769 2.55565e-02 , 2.47263e-02 , 2.39437e-02 , 2.32047e-02 , 2.25056e-02 , &
13770 2.18433e-02 , 2.12149e-02 , 2.06177e-02 , 2.00495e-02 , 1.95081e-02 , &
13771 1.89917e-02 , 1.84984e-02 , 1.80269e-02 , 1.75755e-02 , 1.71431e-02 , &
13772 1.67283e-02 , 1.63303e-02 , 1.59478e-02 , 1.55801e-02 , 1.52262e-02 , &
13773 1.48853e-02 , 1.45568e-02 , 1.42400e-02 , 1.39342e-02 , 1.36388e-02 , &
13774 1.33533e-02 , 1.30773e-02 , 1.28102e-02 /)
13775 absliq1(:, 6) = (/ &
13777 8.81182e-02 , 1.06745e-01 , 9.79753e-02 , 8.99625e-02 , 8.35200e-02 , &
13778 7.81899e-02 , 7.35939e-02 , 6.94696e-02 , 6.56266e-02 , 6.19148e-02 , &
13779 5.83355e-02 , 5.49306e-02 , 5.19642e-02 , 4.93325e-02 , 4.69659e-02 , &
13780 4.48148e-02 , 4.28431e-02 , 4.10231e-02 , 3.93332e-02 , 3.77563e-02 , &
13781 3.62785e-02 , 3.48882e-02 , 3.35758e-02 , 3.23333e-02 , 3.11536e-02 , &
13782 3.00310e-02 , 2.89601e-02 , 2.79365e-02 , 2.70502e-02 , 2.62618e-02 , &
13783 2.55025e-02 , 2.47728e-02 , 2.40726e-02 , 2.34013e-02 , 2.27583e-02 , &
13784 2.21422e-02 , 2.15522e-02 , 2.09869e-02 , 2.04453e-02 , 1.99260e-02 , &
13785 1.94280e-02 , 1.89501e-02 , 1.84913e-02 , 1.80506e-02 , 1.76270e-02 , &
13786 1.72196e-02 , 1.68276e-02 , 1.64500e-02 , 1.60863e-02 , 1.57357e-02 , &
13787 1.53975e-02 , 1.50710e-02 , 1.47558e-02 , 1.44511e-02 , 1.41566e-02 , &
13788 1.38717e-02 , 1.35960e-02 , 1.33290e-02 /)
13789 absliq1(:, 7) = (/ &
13791 4.32174e-02 , 7.36078e-02 , 6.98340e-02 , 6.65231e-02 , 6.41948e-02 , &
13792 6.23551e-02 , 6.06638e-02 , 5.88680e-02 , 5.67124e-02 , 5.38629e-02 , &
13793 4.99579e-02 , 4.86289e-02 , 4.70120e-02 , 4.52854e-02 , 4.35466e-02 , &
13794 4.18480e-02 , 4.02169e-02 , 3.86658e-02 , 3.71992e-02 , 3.58168e-02 , &
13795 3.45155e-02 , 3.32912e-02 , 3.21390e-02 , 3.10538e-02 , 3.00307e-02 , &
13796 2.90651e-02 , 2.81524e-02 , 2.72885e-02 , 2.62821e-02 , 2.55744e-02 , &
13797 2.48799e-02 , 2.42029e-02 , 2.35460e-02 , 2.29108e-02 , 2.22981e-02 , &
13798 2.17079e-02 , 2.11402e-02 , 2.05945e-02 , 2.00701e-02 , 1.95663e-02 , &
13799 1.90824e-02 , 1.86174e-02 , 1.81706e-02 , 1.77411e-02 , 1.73281e-02 , &
13800 1.69307e-02 , 1.65483e-02 , 1.61801e-02 , 1.58254e-02 , 1.54835e-02 , &
13801 1.51538e-02 , 1.48358e-02 , 1.45288e-02 , 1.42322e-02 , 1.39457e-02 , &
13802 1.36687e-02 , 1.34008e-02 , 1.31416e-02 /)
13803 absliq1(:, 8) = (/ &
13805 1.41881e-01 , 7.15419e-02 , 6.30335e-02 , 6.11132e-02 , 6.01931e-02 , &
13806 5.92420e-02 , 5.78968e-02 , 5.58876e-02 , 5.28923e-02 , 4.84462e-02 , &
13807 4.60839e-02 , 4.56013e-02 , 4.45410e-02 , 4.31866e-02 , 4.17026e-02 , &
13808 4.01850e-02 , 3.86892e-02 , 3.72461e-02 , 3.58722e-02 , 3.45749e-02 , &
13809 3.33564e-02 , 3.22155e-02 , 3.11494e-02 , 3.01541e-02 , 2.92253e-02 , &
13810 2.83584e-02 , 2.75488e-02 , 2.67925e-02 , 2.57692e-02 , 2.50704e-02 , &
13811 2.43918e-02 , 2.37350e-02 , 2.31005e-02 , 2.24888e-02 , 2.18996e-02 , &
13812 2.13325e-02 , 2.07870e-02 , 2.02623e-02 , 1.97577e-02 , 1.92724e-02 , &
13813 1.88056e-02 , 1.83564e-02 , 1.79241e-02 , 1.75079e-02 , 1.71070e-02 , &
13814 1.67207e-02 , 1.63482e-02 , 1.59890e-02 , 1.56424e-02 , 1.53077e-02 , &
13815 1.49845e-02 , 1.46722e-02 , 1.43702e-02 , 1.40782e-02 , 1.37955e-02 , &
13816 1.35219e-02 , 1.32569e-02 , 1.30000e-02 /)
13817 absliq1(:, 9) = (/ &
13819 6.72726e-02 , 6.61013e-02 , 6.47866e-02 , 6.33780e-02 , 6.18985e-02 , &
13820 6.03335e-02 , 5.86136e-02 , 5.65876e-02 , 5.39839e-02 , 5.03536e-02 , &
13821 4.71608e-02 , 4.63630e-02 , 4.50313e-02 , 4.34526e-02 , 4.17876e-02 , &
13822 4.01261e-02 , 3.85171e-02 , 3.69860e-02 , 3.55442e-02 , 3.41954e-02 , &
13823 3.29384e-02 , 3.17693e-02 , 3.06832e-02 , 2.96745e-02 , 2.87374e-02 , &
13824 2.78662e-02 , 2.70557e-02 , 2.63008e-02 , 2.52450e-02 , 2.45424e-02 , &
13825 2.38656e-02 , 2.32144e-02 , 2.25885e-02 , 2.19873e-02 , 2.14099e-02 , &
13826 2.08554e-02 , 2.03230e-02 , 1.98116e-02 , 1.93203e-02 , 1.88482e-02 , &
13827 1.83944e-02 , 1.79578e-02 , 1.75378e-02 , 1.71335e-02 , 1.67440e-02 , &
13828 1.63687e-02 , 1.60069e-02 , 1.56579e-02 , 1.53210e-02 , 1.49958e-02 , &
13829 1.46815e-02 , 1.43778e-02 , 1.40841e-02 , 1.37999e-02 , 1.35249e-02 , &
13830 1.32585e-02 , 1.30004e-02 , 1.27502e-02 /)
13831 absliq1(:,10) = (/ &
13833 7.97040e-02 , 7.63844e-02 , 7.36499e-02 , 7.13525e-02 , 6.93043e-02 , &
13834 6.72807e-02 , 6.50227e-02 , 6.22395e-02 , 5.86093e-02 , 5.37815e-02 , &
13835 5.14682e-02 , 4.97214e-02 , 4.77392e-02 , 4.56961e-02 , 4.36858e-02 , &
13836 4.17569e-02 , 3.99328e-02 , 3.82224e-02 , 3.66265e-02 , 3.51416e-02 , &
13837 3.37617e-02 , 3.24798e-02 , 3.12887e-02 , 3.01812e-02 , 2.91505e-02 , &
13838 2.81900e-02 , 2.72939e-02 , 2.64568e-02 , 2.54165e-02 , 2.46832e-02 , &
13839 2.39783e-02 , 2.33017e-02 , 2.26531e-02 , 2.20314e-02 , 2.14359e-02 , &
13840 2.08653e-02 , 2.03187e-02 , 1.97947e-02 , 1.92924e-02 , 1.88106e-02 , &
13841 1.83483e-02 , 1.79043e-02 , 1.74778e-02 , 1.70678e-02 , 1.66735e-02 , &
13842 1.62941e-02 , 1.59286e-02 , 1.55766e-02 , 1.52371e-02 , 1.49097e-02 , &
13843 1.45937e-02 , 1.42885e-02 , 1.39936e-02 , 1.37085e-02 , 1.34327e-02 , &
13844 1.31659e-02 , 1.29075e-02 , 1.26571e-02 /)
13845 absliq1(:,11) = (/ &
13847 1.49438e-01 , 1.33535e-01 , 1.21542e-01 , 1.11743e-01 , 1.03263e-01 , &
13848 9.55774e-02 , 8.83382e-02 , 8.12943e-02 , 7.42533e-02 , 6.70609e-02 , &
13849 6.38761e-02 , 5.97788e-02 , 5.59841e-02 , 5.25318e-02 , 4.94132e-02 , &
13850 4.66014e-02 , 4.40644e-02 , 4.17706e-02 , 3.96910e-02 , 3.77998e-02 , &
13851 3.60742e-02 , 3.44947e-02 , 3.30442e-02 , 3.17079e-02 , 3.04730e-02 , &
13852 2.93283e-02 , 2.82642e-02 , 2.72720e-02 , 2.61789e-02 , 2.53277e-02 , &
13853 2.45237e-02 , 2.37635e-02 , 2.30438e-02 , 2.23615e-02 , 2.17140e-02 , &
13854 2.10987e-02 , 2.05133e-02 , 1.99557e-02 , 1.94241e-02 , 1.89166e-02 , &
13855 1.84317e-02 , 1.79679e-02 , 1.75238e-02 , 1.70983e-02 , 1.66901e-02 , &
13856 1.62983e-02 , 1.59219e-02 , 1.55599e-02 , 1.52115e-02 , 1.48761e-02 , &
13857 1.45528e-02 , 1.42411e-02 , 1.39402e-02 , 1.36497e-02 , 1.33690e-02 , &
13858 1.30976e-02 , 1.28351e-02 , 1.25810e-02 /)
13859 absliq1(:,12) = (/ &
13861 3.71985e-02 , 3.88586e-02 , 3.99070e-02 , 4.04351e-02 , 4.04610e-02 , &
13862 3.99834e-02 , 3.89953e-02 , 3.74886e-02 , 3.54551e-02 , 3.28870e-02 , &
13863 3.32576e-02 , 3.22444e-02 , 3.12384e-02 , 3.02584e-02 , 2.93146e-02 , &
13864 2.84120e-02 , 2.75525e-02 , 2.67361e-02 , 2.59618e-02 , 2.52280e-02 , &
13865 2.45327e-02 , 2.38736e-02 , 2.32487e-02 , 2.26558e-02 , 2.20929e-02 , &
13866 2.15579e-02 , 2.10491e-02 , 2.05648e-02 , 1.99749e-02 , 1.95704e-02 , &
13867 1.91731e-02 , 1.87839e-02 , 1.84032e-02 , 1.80315e-02 , 1.76689e-02 , &
13868 1.73155e-02 , 1.69712e-02 , 1.66362e-02 , 1.63101e-02 , 1.59928e-02 , &
13869 1.56842e-02 , 1.53840e-02 , 1.50920e-02 , 1.48080e-02 , 1.45318e-02 , &
13870 1.42631e-02 , 1.40016e-02 , 1.37472e-02 , 1.34996e-02 , 1.32586e-02 , &
13871 1.30239e-02 , 1.27954e-02 , 1.25728e-02 , 1.23559e-02 , 1.21445e-02 , &
13872 1.19385e-02 , 1.17376e-02 , 1.15417e-02 /)
13873 absliq1(:,13) = (/ &
13875 3.11868e-02 , 4.48357e-02 , 4.90224e-02 , 4.96406e-02 , 4.86806e-02 , &
13876 4.69610e-02 , 4.48630e-02 , 4.25795e-02 , 4.02138e-02 , 3.78236e-02 , &
13877 3.74266e-02 , 3.60384e-02 , 3.47074e-02 , 3.34434e-02 , 3.22499e-02 , &
13878 3.11264e-02 , 3.00704e-02 , 2.90784e-02 , 2.81463e-02 , 2.72702e-02 , &
13879 2.64460e-02 , 2.56698e-02 , 2.49381e-02 , 2.42475e-02 , 2.35948e-02 , &
13880 2.29774e-02 , 2.23925e-02 , 2.18379e-02 , 2.11793e-02 , 2.07076e-02 , &
13881 2.02470e-02 , 1.97981e-02 , 1.93613e-02 , 1.89367e-02 , 1.85243e-02 , &
13882 1.81240e-02 , 1.77356e-02 , 1.73588e-02 , 1.69935e-02 , 1.66392e-02 , &
13883 1.62956e-02 , 1.59624e-02 , 1.56393e-02 , 1.53259e-02 , 1.50219e-02 , &
13884 1.47268e-02 , 1.44404e-02 , 1.41624e-02 , 1.38925e-02 , 1.36302e-02 , &
13885 1.33755e-02 , 1.31278e-02 , 1.28871e-02 , 1.26530e-02 , 1.24253e-02 , &
13886 1.22038e-02 , 1.19881e-02 , 1.17782e-02 /)
13887 absliq1(:,14) = (/ &
13889 1.58988e-02 , 3.50652e-02 , 4.00851e-02 , 4.07270e-02 , 3.98101e-02 , &
13890 3.83306e-02 , 3.66829e-02 , 3.50327e-02 , 3.34497e-02 , 3.19609e-02 , &
13891 3.13712e-02 , 3.03348e-02 , 2.93415e-02 , 2.83973e-02 , 2.75037e-02 , &
13892 2.66604e-02 , 2.58654e-02 , 2.51161e-02 , 2.44100e-02 , 2.37440e-02 , &
13893 2.31154e-02 , 2.25215e-02 , 2.19599e-02 , 2.14282e-02 , 2.09242e-02 , &
13894 2.04459e-02 , 1.99915e-02 , 1.95594e-02 , 1.90254e-02 , 1.86598e-02 , &
13895 1.82996e-02 , 1.79455e-02 , 1.75983e-02 , 1.72584e-02 , 1.69260e-02 , &
13896 1.66013e-02 , 1.62843e-02 , 1.59752e-02 , 1.56737e-02 , 1.53799e-02 , &
13897 1.50936e-02 , 1.48146e-02 , 1.45429e-02 , 1.42782e-02 , 1.40203e-02 , &
13898 1.37691e-02 , 1.35243e-02 , 1.32858e-02 , 1.30534e-02 , 1.28270e-02 , &
13899 1.26062e-02 , 1.23909e-02 , 1.21810e-02 , 1.19763e-02 , 1.17766e-02 , &
13900 1.15817e-02 , 1.13915e-02 , 1.12058e-02 /)
13901 absliq1(:,15) = (/ &
13903 5.02079e-03 , 2.17615e-02 , 2.55449e-02 , 2.59484e-02 , 2.53650e-02 , &
13904 2.45281e-02 , 2.36843e-02 , 2.29159e-02 , 2.22451e-02 , 2.16716e-02 , &
13905 2.11451e-02 , 2.05817e-02 , 2.00454e-02 , 1.95372e-02 , 1.90567e-02 , &
13906 1.86028e-02 , 1.81742e-02 , 1.77693e-02 , 1.73866e-02 , 1.70244e-02 , &
13907 1.66815e-02 , 1.63563e-02 , 1.60477e-02 , 1.57544e-02 , 1.54755e-02 , &
13908 1.52097e-02 , 1.49564e-02 , 1.47146e-02 , 1.43684e-02 , 1.41728e-02 , &
13909 1.39762e-02 , 1.37797e-02 , 1.35838e-02 , 1.33891e-02 , 1.31961e-02 , &
13910 1.30051e-02 , 1.28164e-02 , 1.26302e-02 , 1.24466e-02 , 1.22659e-02 , &
13911 1.20881e-02 , 1.19131e-02 , 1.17412e-02 , 1.15723e-02 , 1.14063e-02 , &
13912 1.12434e-02 , 1.10834e-02 , 1.09264e-02 , 1.07722e-02 , 1.06210e-02 , &
13913 1.04725e-02 , 1.03269e-02 , 1.01839e-02 , 1.00436e-02 , 9.90593e-03 , &
13914 9.77080e-03 , 9.63818e-03 , 9.50800e-03 /)
13915 absliq1(:,16) = (/ &
13917 5.64971e-02 , 9.04736e-02 , 8.11726e-02 , 7.05450e-02 , 6.20052e-02 , &
13918 5.54286e-02 , 5.03503e-02 , 4.63791e-02 , 4.32290e-02 , 4.06959e-02 , &
13919 3.74690e-02 , 3.52964e-02 , 3.33799e-02 , 3.16774e-02 , 3.01550e-02 , &
13920 2.87856e-02 , 2.75474e-02 , 2.64223e-02 , 2.53953e-02 , 2.44542e-02 , &
13921 2.35885e-02 , 2.27894e-02 , 2.20494e-02 , 2.13622e-02 , 2.07222e-02 , &
13922 2.01246e-02 , 1.95654e-02 , 1.90408e-02 , 1.84398e-02 , 1.80021e-02 , &
13923 1.75816e-02 , 1.71775e-02 , 1.67889e-02 , 1.64152e-02 , 1.60554e-02 , &
13924 1.57089e-02 , 1.53751e-02 , 1.50531e-02 , 1.47426e-02 , 1.44428e-02 , &
13925 1.41532e-02 , 1.38734e-02 , 1.36028e-02 , 1.33410e-02 , 1.30875e-02 , &
13926 1.28420e-02 , 1.26041e-02 , 1.23735e-02 , 1.21497e-02 , 1.19325e-02 , &
13927 1.17216e-02 , 1.15168e-02 , 1.13177e-02 , 1.11241e-02 , 1.09358e-02 , &
13928 1.07525e-02 , 1.05741e-02 , 1.04003e-02 /)
13930 end subroutine lwcldpr
13932 end module rrtmg_lw_init_f
13934 module rrtmg_lw_rad_f
13936 ! --------------------------------------------------------------------------
13938 ! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). |
13939 ! | This software may be used, copied, or redistributed as long as it is |
13940 ! | not sold and this copyright notice is reproduced on each copy made. |
13941 ! | This model is provided as is without any express or implied warranties. |
13942 ! | (http://www.rtweb.aer.com/) |
13944 ! --------------------------------------------------------------------------
13951 use gpu_mcica_subcol_gen_lw
13953 use gpu_rrtmg_lw_rtrnmc
13954 use gpu_rrtmg_lw_setcoef
13955 use gpu_rrtmg_lw_cldprmc
13957 use gpu_rrtmg_lw_taumol, only: taumolg, copyGPUTaumol
13958 use rrlw_cld_f, only: abscld1, absliq0, absliq1, &
13959 absice0, absice1, absice2, absice3
13960 use rrlw_wvn_f, only: ngb, ngs
13961 use rrlw_tbl_f, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl, ntbl
13962 use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi, grav, avogad
13968 integer _gpudev, allocatable :: ngbd(:)
13969 integer, allocatable _gpudev :: ncbandsd(:)
13970 integer, allocatable _gpudev :: icbd(:)
13971 integer, allocatable _gpudev :: icldlyr(:,:)
13972 real _gpudev, allocatable :: fracsd(:,:,:)
13973 real _gpudev, allocatable :: taug(:,:,:)
13974 !$OMP THREADPRIVATE(ngbd,ncbandsd,icbd,icldlyr,fracsd,taug)
13977 real :: timings(10)
13978 INTEGER, PARAMETER :: debug_level_lwf=100
13980 !------------------------------------------------------------------
13982 !------------------------------------------------------------------
13983 subroutine rrtmg_lw( &
13984 ncol ,nlay ,icld ,idrv , &
13985 play ,plev ,tlay ,tlev ,tsfc , &
13986 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
13987 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
13988 inflglw ,iceflglw,liqflglw,cldfrac , &
13989 tauc ,ciwp ,clwp ,cswp ,rei ,rel , res , &
13991 uflx ,dflx ,hr ,uflxc ,dflxc ,hrc , &
13992 duflx_dt,duflxc_dt)
13993 ! -------- Description --------
13995 ! This program is the driver subroutine for RRTMG_LW, the AER LW radiation
13996 ! model for application to GCMs, that has been adapted from RRTM_LW for
13997 ! improved efficiency.
13999 ! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization
14000 ! area, since this has to be called only once.
14003 ! a) calls INATM to read in the atmospheric profile from GCM;
14004 ! all layering in RRTMG is ordered from surface to toa.
14005 ! b) calls CLDPRMC to set cloud optical depth for McICA based
14006 ! on input cloud properties
14007 ! c) calls SETCOEF to calculate various quantities needed for
14008 ! the radiative transfer algorithm
14009 ! d) calls TAUMOL to calculate gaseous optical depths for each
14010 ! of the 16 spectral bands
14011 ! e) calls RTRNMC (for both clear and cloudy profiles) to perform the
14012 ! radiative transfer calculation using McICA, the Monte-Carlo
14013 ! Independent Column Approximation, to represent sub-grid scale
14014 ! cloud variability
14015 ! f) passes the necessary fluxes and cooling rates back to GCM
14017 ! Two modes of operation are possible:
14018 ! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use
14019 ! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM.
14021 ! 1) Standard, single forward model calculation (imca = 0)
14022 ! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al.,
14023 ! JC, 2003) method is applied to the forward model calculation (imca = 1)
14025 ! This call to RRTMG_LW must be preceeded by a call to the module
14026 ! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator,
14027 ! which will provide the cloud physical or cloud optical properties
14028 ! on the RRTMG quadrature point (ngpt) dimension.
14029 ! Two random number generators are available for use when imca = 1.
14030 ! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw.
14031 ! 1) KISSVEC (irnd = 0)
14032 ! 2) Mersenne-Twister (irnd = 1)
14034 ! Two methods of cloud property input are possible:
14035 ! Cloud properties can be input in one of two ways (controlled by input
14036 ! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions
14037 ! and subroutine rrtmg_lw_cldprmc.f90 for further details):
14039 ! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0)
14040 ! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2);
14041 ! cloud optical properties are calculated by cldprmc or cldprmc based
14042 ! on input settings of iceflglw and liqflglw. Ice particle size provided
14043 ! must be appropriately defined for the ice parameterization selected.
14045 ! One method of aerosol property input is possible:
14046 ! Aerosol properties can be input in only one way (controlled by input
14047 ! flag iaer; see text file rrtmg_lw_instructions for further details):
14049 ! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10);
14050 ! band average optical depth at the mid-point of each spectral band.
14051 ! RRTMG_LW currently treats only aerosol absorption;
14052 ! scattering capability is not presently available.
14054 ! The optional calculation of the change in upward flux as a function of surface
14055 ! temperature is available (controlled by input flag idrv). This can be utilized
14056 ! to approximate adjustments to the upward flux profile caused only by a change in
14057 ! surface temperature between full radiation calls. This feature uses the pre-
14058 ! calculated derivative of the Planck function with respect to surface temperature.
14060 ! 1) Normal forward calculation for the input profile (idrv=0)
14061 ! 2) Normal forward calculation with optional calculation of the change
14062 ! in upward flux as a function of surface temperature for clear sky
14063 ! and total sky flux. Flux partial derivatives are provided in arrays
14064 ! duflx_dt and duflxc_dt for total and clear sky. (idrv=1)
14067 ! ------- Modifications -------
14069 ! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced
14070 ! set of g-points for application to GCMs.
14072 !-- Original version (derived from RRTM_LW), reduction of g-points, other
14073 ! revisions for use with GCMs.
14074 ! 1999: M. J. Iacono, AER, Inc.
14075 !-- Adapted for use with NCAR/CAM.
14076 ! May 2004: M. J. Iacono, AER, Inc.
14077 !-- Revised to add McICA capability.
14078 ! Nov 2005: M. J. Iacono, AER, Inc.
14079 !-- Conversion to F90 formatting for consistency with rrtmg_sw.
14080 ! Feb 2007: M. J. Iacono, AER, Inc.
14081 !-- Modifications to formatting to use assumed-shape arrays.
14082 ! Aug 2007: M. J. Iacono, AER, Inc.
14083 !-- Modified to add longwave aerosol absorption.
14084 ! Apr 2008: M. J. Iacono, AER, Inc.
14085 !-- Added capability to calculate derivative of upward flux wrt surface temperature.
14086 ! Nov 2009: M. J. Iacono, E. J. Mlawer, AER, Inc.
14087 !-- Added capability to run on GPU
14088 ! Aug 2012: David Berthiaume, AER, Inc.
14089 ! --------- Modules ----------
14091 use parrrtm_f, only : nbndlw, ngptlw, maxxsec, mxmol, mxlay, nbndlw
14092 use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi
14093 use rrlw_wvn_f, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave
14095 ! ------- Declarations -------
14097 ! integer , parameter:: maxlay = 203
14098 ! integer , parameter:: mxmol = 38
14101 ! ----- Input -----
14102 ! Note: All volume mixing ratios are in dimensionless units of mole fraction obtained
14103 ! by scaling mass mixing ratio (g/g) with the appropriate molecular weights (g/mol)
14104 integer , intent(in) :: ncol ! Number of horizontal columns
14105 integer , intent(in) :: nlay ! Number of model layers
14106 integer , intent(inout) :: icld ! Cloud overlap method
14109 ! 2: Maximum/random
14111 ! 4: Exponential (inactive)
14112 integer , intent(in) :: idrv ! Flag for calculation of dFdT, the change
14113 ! in upward flux as a function of
14114 ! surface temperature [0=off, 1=on]
14115 ! 0: Normal forward calculation
14116 ! 1: Normal forward calculation with
14117 ! duflx_dt and duflxc_dt output
14119 ! integer , intent(in) :: cloudMH, cloudHH ! cloud layer heights for cloudFlag
14120 real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
14121 ! Dimensions: (ncol,nlay)
14122 real , intent(in) :: plev(:,0:) ! Interface pressures (hPa, mb)
14123 ! Dimensions: (ncol,nlay+1)
14124 real , intent(in) :: tlay(:,:) ! Layer temperatures (K)
14125 ! Dimensions: (ncol,nlay)
14126 real , intent(in) :: tlev(:,0:) ! Interface temperatures (K)
14127 ! Dimensions: (ncol,nlay+1)
14128 real , intent(in) :: tsfc(:) ! Surface temperature (K)
14129 ! Dimensions: (ncol)
14130 real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
14131 ! Dimensions: (ncol,nlay)
14132 real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
14133 ! Dimensions: (ncol,nlay)
14134 real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
14135 ! Dimensions: (ncol,nlay)
14136 real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
14137 ! Dimensions: (ncol,nlay)
14138 real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
14139 ! Dimensions: (ncol,nlay)
14140 real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
14141 ! Dimensions: (ncol,nlay)
14142 real , intent(in) :: cfc11vmr(:, :) ! CFC11 volume mixing ratio
14143 ! Dimensions: (ncol,nlay)
14144 real , intent(in) :: cfc12vmr(:, :) ! CFC12 volume mixing ratio
14145 ! Dimensions: (ncol,nlay)
14146 real , intent(in) :: cfc22vmr(:, :) ! CFC22 volume mixing ratio
14147 ! Dimensions: (ncol,nlay)
14148 real , intent(in) :: ccl4vmr(:, :) ! CCL4 volume mixing ratio
14149 ! Dimensions: (ncol,nlay)
14150 real , intent(in) :: emis(:, :) ! Surface emissivity
14151 ! Dimensions: (ncol,nbndlw)
14153 integer , intent(in) :: inflglw ! Flag for cloud optical properties
14154 integer , intent(in) :: iceflglw ! Flag for ice particle specification
14155 integer , intent(in) :: liqflglw ! Flag for liquid droplet specification
14157 real , intent(in) :: cldfrac(:,:) ! Cloud fraction
14158 ! Dimensions: (ncol,nlay)
14159 real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2)
14160 ! Dimensions: (ncol,nlay)
14161 real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2)
14162 ! Dimensions: (ncol,nlay)
14163 real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2)
14164 ! Dimensions: (ncol,nlay)
14165 real , intent(in) :: rei(:,:) ! Cloud ice particle effective size (microns)
14166 ! Dimensions: (ncol,nlay)
14167 ! specific definition of reicmcl depends on setting of iceflglw:
14168 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
14169 ! r_ec must be >= 10.0 microns
14170 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
14171 ! r_ec range is limited to 13.0 to 130.0 microns
14172 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
14173 ! r_k range is limited to 5.0 to 131.0 microns
14174 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
14175 ! dge range is limited to 5.0 to 140.0 microns
14176 ! [dge = 1.0315 * r_ec]
14177 real , intent(in) :: rel(:, :) ! Cloud water drop effective radius (microns)
14178 ! Dimensions: (ncol,nlay)
14179 real , intent(in) :: res(:, :) ! Cloud snow effective radius (microns)
14180 ! Dimensions: (ncol,nlay)
14181 real , intent(in) :: tauc(:, :, :) ! In-cloud optical depth
14182 ! Dimensions: (ncol,nbndlw,nlay)
14183 real , intent(in) :: tauaer(:,:,:) ! aerosol optical depth
14184 ! at mid-point of LW spectral bands
14185 ! Dimensions: (ncol,nlay,nbndlw)
14187 ! ----- Output -----
14189 real , intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2)
14190 ! Dimensions: (ncol,nlay+1)
14191 real , intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2)
14192 ! Dimensions: (ncol,nlay+1)
14193 real , intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d)
14194 ! Dimensions: (ncol,nlay)
14195 real , intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2)
14196 ! Dimensions: (ncol,nlay+1)
14197 real , intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2)
14198 ! Dimensions: (ncol,nlay+1)
14199 real , intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d)
14200 ! Dimensions: (ncol,nlay)
14202 ! ----- Optional Output -----
14203 real , intent(out), optional :: duflx_dt(:,:)
14204 ! change in upward longwave flux (w/m2/K)
14205 ! with respect to surface temperature
14206 ! Dimensions: (ncol,nlay)
14207 real , intent(out), optional :: duflxc_dt(:,:)
14208 ! change in clear sky upward longwave flux (w/m2/K)
14209 ! with respect to surface temperature
14210 ! Dimensions: (ncol,nlay)
14211 ! integer , intent(out), optional :: cloudFlag(:,:)
14213 real, pointer :: alp(:,:)
14216 integer :: colstart
14217 integer :: cn, ns, i, np, mns
14220 integer :: numDevices, err
14222 integer :: numThreads
14223 integer,external :: omp_get_thread_num
14224 CHARACTER(LEN=256) :: message
14226 ! Cuda device information
14228 type(cudadeviceprop) :: prop
14230 ! store the available device global and constant memory
14235 !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num()
14238 err = cudaGetDeviceProperties( prop, 0)
14239 gmem = prop%totalGlobalMem
14240 ! print *, "total GPU global memory is ", gmem / (1024.0*1024.0) , "MB"
14244 ! (dmb 2012) Here we calculate the number of groups to partition
14247 ! determine the minimum GPU memory
14248 ! force the GPUFlag off if there are no devices available
14254 ! on the CPU partiion the inputs into 2 GB chunks. Runtime
14255 ! is pretty constant on the CPU as a function of the number
14256 ! of steps, so we pick a quantity that uses a relatively low
14257 ! amount of CPU memory.
14258 minmem = 2.0 * (1024.0**3)
14260 ! set the number of 'devices' to the available number of CPUs
14262 ! print *, "available working memory is ", int(minmem / (1024*1024)) , " MB"
14265 ! use the available memory to determine the minumum number
14266 ! of steps that will be required.
14267 ! We use 1500 profiles per available GB as a conservative
14269 cn = minmem * 1500 / (1024**3)
14271 ! with device emulation (for debugging) make sure there is a lower
14272 ! limit to the number of supported columns
14276 ! Set number of columns per partition to be no larger than total number of columns
14277 if (cn > ncol) then
14284 WRITE(message,*)'RRTMG_LWF: Number of columns is ',ncol
14285 call wrf_debug( debug_level_lwf, message)
14286 WRITE(message,*)'RRTMG_LWF: Number of columns per partition is ',cn
14287 call wrf_debug( debug_level_lwf, message)
14288 ns = ceiling( real(ncol) / real(cn) )
14289 WRITE(message,*)'RRTMG_LWF: Number of partitions is ',ns
14290 call wrf_debug( debug_level_lwf, message)
14297 !jm if ( i .eq. IDEBUG_BASE ) then
14300 !jm call unsetdebug
14305 call rrtmg_lw_part &
14306 (ns, ncol, (i-1)*cn + 1, min(cn, ncol - (i-1)*cn), &
14308 play ,plev ,tlay ,tlev ,tsfc , &
14309 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
14310 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
14311 inflglw ,iceflglw,liqflglw,cldfrac , &
14312 tauc ,ciwp ,clwp ,cswp ,rei ,rel ,res , &
14314 uflx ,dflx ,hr ,uflxc ,dflxc, hrc, &
14315 duflx_dt,duflxc_dt)
14320 WRITE(message,*)'------------------------------------------------'
14321 call wrf_debug( debug_level_lwf, message)
14322 WRITE(message,*)'TOTAL RRTMG_LWF RUN TIME IS ', t2-t1
14323 call wrf_debug( debug_level_lwf, message)
14324 WRITE(message,*)'------------------------------------------------'
14325 call wrf_debug( debug_level_lwf, message)
14329 subroutine rrtmg_lw_part &
14330 (npart, ncol , colstart, pncol , &
14331 nlay ,icld ,idrv , &
14332 play ,plev ,tlay ,tlev ,tsfc , &
14333 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
14334 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
14335 inflglw ,iceflglw,liqflglw,cldfrac , &
14336 tauc ,ciwp ,clwp ,cswp ,rei ,rel ,res , &
14338 uflx ,dflx ,hr ,uflxc ,dflxc, hrc, &
14339 duflx_dt,duflxc_dt)
14341 use gpu_mcica_subcol_gen_lw, only: mcica_subcol_lwg, generate_stochastic_cloudsg
14343 use parrrtm_f, only : nbndlw, ngptlw, maxxsec, mxmol, mxlay, nbndlw, nmol
14344 use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi
14345 use rrlw_wvn_f, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave, ixindx
14348 ! ----- Input -----
14349 ! Note: All volume mixing ratios are in dimensionless units of mole fraction obtained
14350 ! by scaling mass mixing ratio (g/g) with the appropriate molecular weights (g/mol)
14351 integer , intent(in) :: npart
14352 integer , intent(in) :: ncol ! Number of horizontal columns
14353 integer , intent(in) :: nlay ! Number of model layers
14354 integer , intent(inout) :: icld ! Cloud overlap method
14357 ! 2: Maximum/random
14359 ! 4: Exponential (inactive)
14360 integer , intent(in) :: idrv ! Flag for calculation of dFdT, the change
14361 ! in upward flux as a function of
14362 ! surface temperature [0=off, 1=on]
14363 ! 0: Normal forward calculation
14364 ! 1: Normal forward calculation with
14365 ! duflx_dt and duflxc_dt output
14367 real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb)
14368 ! Dimensions: (ncol,nlay)
14369 real , intent(in) :: plev(:,0:) ! Interface pressures (hPa, mb)
14370 ! Dimensions: (ncol,nlay+1)
14371 real , intent(in) :: tlay(:,:) ! Layer temperatures (K)
14372 ! Dimensions: (ncol,nlay)
14373 real , intent(in) :: tlev(:,0:) ! Interface temperatures (K)
14374 ! Dimensions: (ncol,nlay+1)
14375 real , intent(in) :: tsfc(:) ! Surface temperature (K)
14376 ! Dimensions: (ncol)
14377 real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio
14378 ! Dimensions: (ncol,nlay)
14379 real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio
14380 ! Dimensions: (ncol,nlay)
14381 real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio
14382 ! Dimensions: (ncol,nlay)
14383 real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio
14384 ! Dimensions: (ncol,nlay)
14385 real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio
14386 ! Dimensions: (ncol,nlay)
14387 real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio
14388 ! Dimensions: (ncol,nlay)
14389 real , intent(in) :: cfc11vmr(:, :) ! CFC11 volume mixing ratio
14390 ! Dimensions: (ncol,nlay)
14391 real , intent(in) :: cfc12vmr(:, :) ! CFC12 volume mixing ratio
14392 ! Dimensions: (ncol,nlay)
14393 real , intent(in) :: cfc22vmr(:, :) ! CFC22 volume mixing ratio
14394 ! Dimensions: (ncol,nlay)
14395 real , intent(in) :: ccl4vmr(:, :) ! CCL4 volume mixing ratio
14396 ! Dimensions: (ncol,nlay)
14397 real , intent(in) :: emis(:, :) ! Surface emissivity
14398 ! Dimensions: (ncol,nbndlw)
14400 integer , intent(in) :: inflglw ! Flag for cloud optical properties
14401 integer , intent(in) :: iceflglw ! Flag for ice particle specification
14402 integer , intent(in) :: liqflglw ! Flag for liquid droplet specification
14404 real , intent(in) :: cldfrac(:,:) ! Cloud fraction
14405 ! Dimensions: (ngptlw,ncol,nlay)
14406 real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2)
14407 ! Dimensions: (ngptlw,ncol,nlay)
14408 real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2)
14409 ! Dimensions: (ngptlw,ncol,nlay)
14410 real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2)
14411 ! Dimensions: (ngptlw,ncol,nlay)
14412 real , intent(in) :: rei(:,:) ! Cloud ice particle effective size (microns)
14413 ! Dimensions: (ncol,nlay)
14414 ! specific definition of reicmcl depends on setting of iceflglw:
14415 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
14416 ! r_ec must be >= 10.0 microns
14417 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
14418 ! r_ec range is limited to 13.0 to 130.0 microns
14419 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
14420 ! r_k range is limited to 5.0 to 131.0 microns
14421 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
14422 ! dge range is limited to 5.0 to 140.0 microns
14423 ! [dge = 1.0315 * r_ec]
14424 real , intent(in) :: rel(:, :) ! Cloud water drop effective radius (microns)
14425 ! Dimensions: (ncol,nlay)
14426 real , intent(in) :: res(:, :) ! Cloud snow effective radius (microns)
14427 ! Dimensions: (ncol,nlay)
14428 real , intent(in) :: tauc(:, :,:) ! In-cloud optical depth
14429 ! Dimensions: (ncol,nbndlw,nlay)
14431 real , intent(in) :: tauaer(:,:,:) ! aerosol optical depth
14432 ! at mid-point of LW spectral bands
14433 ! Dimensions: (ncol,nlay,nbndlw)
14435 integer , intent(in) :: pncol
14436 integer , intent(in) :: colstart
14439 # define pncol CHNK
14442 ! ----- Output -----
14444 real , intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2)
14445 ! Dimensions: (ncol,nlay+1)
14446 real , intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2)
14447 ! Dimensions: (ncol,nlay+1)
14448 real , intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d)
14449 ! Dimensions: (ncol,nlay)
14450 real , intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2)
14451 ! Dimensions: (ncol,nlay+1)
14452 real , intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2)
14453 ! Dimensions: (ncol,nlay+1)
14454 real , intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d)
14455 ! Dimensions: (ncol,nlay)
14457 ! ----- Optional Output -----
14458 real , intent(out), optional :: duflx_dt(:,:)
14459 ! change in upward longwave flux (w/m2/K)
14460 ! with respect to surface temperature
14461 ! Dimensions: (ncol,nlay)
14462 real , intent(out), optional :: duflxc_dt(:,:)
14463 ! change in clear sky upward longwave flux (w/m2/K)
14464 ! with respect to surface temperature
14465 ! Dimensions: (ncol,nlay)
14466 ! integer , intent(out), optional :: cloudFlag(:,:)
14468 real _gpudeva :: cldfmcd(:,:,:) ! layer cloud fraction [mcica]
14469 ! Dimensions: (ngptlw,nlayers)
14471 real :: cldfmcd(pncol, ngptlw, nlay+1) ! layer cloud fraction [mcica]
14475 ! ----- Local -----
14478 integer ncol_,nlayers_,nbndlw_,ngptlw_ ! for passing through argument list
14479 integer ncol__,nlayers__,nbndlw__,ngptlw__ ! for passing through argument list
14480 ! here is where the previously allocatable things are made local variables
14481 real :: pmid(pncol, nlay)
14483 real :: relqmc(pncol, nlay+1), reicmc(pncol, nlay+1)
14484 real :: resnmc(pncol, nlay+1)
14486 real :: ciwpmcd(pncol, ngptlw, nlay+1)
14487 real :: clwpmcd(pncol, ngptlw, nlay+1)
14488 real :: cswpmcd(pncol, ngptlw, nlay+1)
14490 real :: taucmcd(pncol, ngptlw, nlay+1)
14491 real :: pzd(pncol, 0:nlay+1)
14492 real :: pwvcmd(pncol)
14493 real :: semissd(pncol, nbndlw)
14494 real :: planklayd(pncol,nlay+1,nbndlw)
14495 real :: planklevd(pncol, 0:nlay+1, nbndlw)
14496 real :: plankbndd(pncol,nbndlw)
14497 real :: gurad(pncol,ngptlw,0:nlay+1) ! upward longwave flux (w/m2)
14498 real :: gdrad(pncol,ngptlw,0:nlay+1) ! downward longwave flux (w/m2)
14499 real :: gclrurad(pncol,ngptlw,0:nlay+1) ! clear sky upward longwave flux (w/m2)
14500 real :: gclrdrad(pncol,ngptlw,0:nlay+1) ! clear sky downward longwave flux (w/m2)
14502 real :: gdtotuflux_dtd( pncol, ngptlw, 0:nlay+1)
14503 real :: gdtotuclfl_dtd( pncol, ngptlw, 0:nlay+1)
14505 real :: totufluxd(pncol, 0:nlay+1) ! upward longwave flux (w/m2)
14506 real :: totdfluxd(pncol, 0:nlay+1) ! downward longwave flux (w/m2)
14507 real :: fnetd(pncol, 0:nlay+1) ! net longwave flux (w/m2)
14508 real :: htrd(pncol, 0:nlay+1) ! longwave heating rate (k/day)
14509 real :: totuclfld(pncol, 0:nlay+1) ! clear sky upward longwave flux (w/m2)
14510 real :: totdclfld(pncol, 0:nlay+1) ! clear sky downward longwave flux (w/m2)
14511 real :: fnetcd(pncol, 0:nlay+1) ! clear sky net longwave flux (w/m2)
14512 real :: htrcd(pncol, 0:nlay+1) ! clear sky longwave heating rate (k/day)
14513 real :: dtotuflux_dtd(pncol, 0:nlay+1) ! change in upward longwave flux (w/m2/k)
14514 real :: dtotuclfl_dtd(pncol, 0:nlay+1)
14515 real :: dplankbnd_dtd(pncol,nbndlw)
14517 real :: taveld( pncol, nlay)
14518 real :: tzd( pncol, 0:nlay)
14519 real :: tboundd( pncol )
14520 real :: wbroadd( pncol, nlay)
14522 real :: wx1( pncol, nlay )
14523 real :: wx2( pncol, nlay )
14524 real :: wx3( pncol, nlay )
14525 real :: wx4( pncol, nlay )
14527 real :: tauaa( pncol, nlay, nbndlw )
14528 !jm integer :: nspad( nbndlw )
14529 !jm integer :: nspbd( nbndlw )
14531 integer :: icbd(16)
14532 integer :: ncbandsd(pncol)
14533 integer :: icldlyr(pncol, nlay+1)
14534 real :: fracsd( pncol, nlay+1, ngptlw )
14535 real :: taug( pncol, nlay+1, ngptlw )
14540 integer(kind=4) :: nlayers ! total number of layers
14541 integer(kind=4) :: istart ! beginning band of calculation
14542 integer(kind=4) :: iend ! ending band of calculation
14543 integer(kind=4) :: iout ! output option flag (inactive)
14544 integer :: iaer ! aerosol option flag
14545 integer(kind=4) :: iplon ! column loop index
14546 integer :: imca ! flag for mcica [0=off, 1=on]
14547 integer :: ims ! value for changing mcica permute seed
14548 integer :: k ! layer loop index
14549 integer :: ig ! g-point loop index
14553 real :: pavel(pncol,nlay+1) ! layer pressures (mb)
14554 real :: tavel(pncol,nlay+1) ! layer temperatures (K)
14555 real :: pz(pncol,0:nlay+1) ! level (interface) pressures (hPa, mb)
14556 real :: tz(pncol,0:nlay+1) ! level (interface) temperatures (K)
14557 real :: tbound(pncol) ! surface temperature (K)
14558 real :: coldry(pncol,nlay+1) ! dry air column density (mol/cm2)
14559 real :: wbrodl(pncol,nlay+1) ! broadening gas column density (mol/cm2)
14560 real :: wkl(pncol,mxmol,nlay+1) ! molecular amounts (mol/cm-2)
14561 real :: wx(pncol,maxxsec,nlay+1) ! cross-section amounts (mol/cm-2)
14562 real :: pwvcm(pncol) ! precipitable water vapor (cm)
14563 real :: semiss(pncol,nbndlw) ! lw surface emissivity
14564 real :: fracs(pncol,nlay+1,ngptlw) !
14566 real :: taut(pncol,nlay+1,ngptlw) ! gaseous + aerosol optical depths
14568 real :: taua(pncol,nlay+1,nbndlw) ! aerosol optical depth
14569 ! real :: ssaa(pncol,nlay+1,nbndlw) ! aerosol single scattering albedo
14570 ! for future expansion
14571 ! (lw aerosols/scattering not yet available)
14572 ! real :: asma(pncol,nlay+1,nbndlw) ! aerosol asymmetry parameter
14573 ! for future expansion
14574 ! (lw aerosols/scattering not yet available)
14576 ! Atmosphere - setcoef
14577 integer :: laytrop(pncol) ! tropopause layer index
14578 integer :: jp(pncol,nlay+1) ! lookup table index
14579 integer :: jt(pncol,nlay+1) ! lookup table index
14580 integer :: jt1(pncol,nlay+1) ! lookup table index
14581 real :: planklay(pncol,nlay+1,nbndlw) !
14582 real :: planklev(pncol,0:nlay+1,nbndlw) !
14583 real :: plankbnd(pncol,nbndlw) !
14584 real :: dplankbnd_dt(pncol,nbndlw) !
14586 real :: colh2o(pncol,nlay+1) ! column amount (h2o)
14587 real :: colco2(pncol,nlay+1) ! column amount (co2)
14588 real :: colo3(pncol,nlay+1) ! column amount (o3)
14589 real :: coln2o(pncol,nlay+1) ! column amount (n2o)
14590 real :: colco(pncol,nlay+1) ! column amount (co)
14591 real :: colch4(pncol,nlay+1) ! column amount (ch4)
14592 real :: colo2(pncol,nlay+1) ! column amount (o2)
14593 real :: colbrd(pncol,nlay+1) ! column amount (broadening gases)
14595 integer :: indself(pncol,nlay+1)
14596 integer :: indfor(pncol,nlay+1)
14597 real :: selffac(pncol,nlay+1)
14598 real :: selffrac(pncol,nlay+1)
14599 real :: forfac(pncol,nlay+1)
14600 real :: forfrac(pncol,nlay+1)
14602 integer :: indminor(pncol,nlay+1)
14603 real :: minorfrac(pncol,nlay+1)
14604 real :: scaleminor(pncol,nlay+1)
14605 real :: scaleminorn2(pncol,nlay+1)
14608 fac00(pncol,nlay+1), fac01(pncol,nlay+1), &
14609 fac10(pncol,nlay+1), fac11(pncol,nlay+1)
14611 rat_h2oco2(pncol,nlay+1),rat_h2oco2_1(pncol,nlay+1), &
14612 rat_h2oo3(pncol,nlay+1),rat_h2oo3_1(pncol,nlay+1), &
14613 rat_h2on2o(pncol,nlay+1),rat_h2on2o_1(pncol,nlay+1), &
14614 rat_h2och4(pncol,nlay+1),rat_h2och4_1(pncol,nlay+1), &
14615 rat_n2oco2(pncol,nlay+1),rat_n2oco2_1(pncol,nlay+1), &
14616 rat_o3co2(pncol,nlay+1),rat_o3co2_1(pncol,nlay+1)
14618 ! Atmosphere/clouds - cldprop
14619 integer :: ncbands(pncol) ! number of cloud spectral bands
14620 integer :: inflag(pncol) ! flag for cloud property method
14621 integer :: iceflag(pncol) ! flag for ice cloud properties
14622 integer :: liqflag(pncol) ! flag for liquid cloud properties
14626 real :: totuflux(pncol,0:nlay+1) ! upward longwave flux (w/m2)
14627 real :: totdflux(pncol,0:nlay+1) ! downward longwave flux (w/m2)
14628 real :: fnet(pncol,0:nlay+1) ! net longwave flux (w/m2)
14629 real :: htr(pncol,0:nlay+1) ! longwave heating rate (k/day)
14630 real :: totuclfl(pncol,0:nlay+1) ! clear sky upward longwave flux (w/m2)
14631 real :: totdclfl(pncol,0:nlay+1) ! clear sky downward longwave flux (w/m2)
14632 real :: fnetc(pncol,0:nlay+1) ! clear sky net longwave flux (w/m2)
14633 real :: htrc(pncol,0:nlay+1) ! clear sky longwave heating rate (k/day)
14634 real :: dtotuflux_dt(pncol,0:nlay+1) ! change in upward longwave flux (w/m2/k)
14635 ! with respect to surface temperature
14636 real :: dtotuclfl_dt(pncol,0:nlay+1) ! change in clear sky upward longwave flux (w/m2/k)
14637 ! with respect to surface temperature
14638 real :: curad(pncol,ngptlw,0:nlay+1) ! upward longwave flux (w/m2)
14639 real :: cdrad(pncol,ngptlw,0:nlay+1) ! downward longwave flux (w/m2)
14640 real :: cclrurad(pncol,ngptlw,0:nlay+1) ! clear sky upward longwave flux (w/m2)
14641 real :: cclrdrad(pncol,ngptlw,0:nlay+1) ! clear sky downward longwave flux (w/m2)
14643 real :: cldfracq(pncol,mxlay+1) ! Cloud fraction
14644 ! Dimensions: (ngptlw,ncol,nlay)
14645 real :: ciwpq(pncol,mxlay+1) ! In-cloud ice water path (g/m2)
14646 ! Dimensions: (ngptlw,ncol,nlay)
14647 real :: clwpq(pncol,mxlay+1) ! In-cloud liquid water path (g/m2)
14648 ! Dimensions: (ngptlw,ncol,nlay)
14649 real :: cswpq(pncol,mxlay+1) ! In-cloud snow water path (g/m2)
14650 ! Dimensions: (ngptlw,ncol,nlay)
14651 real :: reiq(pncol,mxlay) ! Cloud ice particle effective size (microns)
14652 ! Dimensions: (ncol,nlay)
14653 ! specific definition of reicmcl depends on setting of iceflglw:
14654 ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
14655 ! r_ec must be >= 10.0 microns
14656 ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992),
14657 ! r_ec range is limited to 13.0 to 130.0 microns
14658 ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996)
14659 ! r_k range is limited to 5.0 to 131.0 microns
14660 ! iceflglw = 3: generalized effective size, dge, (Fu, 1996),
14661 ! dge range is limited to 5.0 to 140.0 microns
14662 ! [dge = 1.0315 * r_ec]
14663 real :: relq(pncol, mxlay) ! Cloud water drop effective radius (microns)
14664 ! Dimensions: (ncol,nlay)
14665 real :: resq(pncol, mxlay) ! Cloud snow effective radius (microns)
14666 ! Dimensions: (ncol,nlay)
14667 real :: taucq(pncol, nbndlw, mxlay) ! In-cloud optical depth
14668 ! Dimensions: (ncol,nbndlw,nlay)
14669 ! mji - tauaq dimensions?
14670 real :: tauaq(pncol, mxlay, nbndlw) ! aerosol optical depth
14671 ! Dimensions: (ncol,nlay,nbndlw)
14674 integer :: permuteseed ! this is set, below
14677 ! local looping variables
14678 integer :: i,j,kk, piplon
14682 ! cuda thread and grid block dimensions
14684 type(dim3) :: dimGrid, dimBlock
14687 real , dimension(16) :: a0 =(/ 1.66 , 1.55 , 1.58 , 1.66 , &
14688 1.54 , 1.454 , 1.89 , 1.33 , &
14689 1.668 , 1.66 , 1.66 , 1.66 , &
14690 1.66 , 1.66 , 1.66 , 1.66 /)
14691 real , dimension(16) :: a1=(/ 0.00 , 0.25 , 0.22 , 0.00 , &
14692 0.13 , 0.446 , -0.10 , 0.40 , &
14693 -0.006 , 0.00 , 0.00 , 0.00 , &
14694 0.00 , 0.00 , 0.00 , 0.00 /)
14695 real , dimension(16) :: a2 =(/ 0.00 , -12.0 , -11.7 , 0.00 , &
14696 -0.72 ,-0.243 , 0.19 ,-0.062 , &
14697 0.414 , 0.00 , 0.00 , 0.00 , &
14698 0.00 , 0.00 , 0.00 , 0.00 /)
14699 real , parameter :: amd = 28.9660 ! Effective molecular weight of dry air (g/mol)
14700 real , parameter :: amw = 18.0160 ! Molecular weight of water vapor (g/mol)
14702 ! (dmb 2012) these arrays were moved to the main routine so that we can bypass some of the
14703 ! inatm inefficiencies when running on the GPU
14704 real , parameter :: amdw = 1.607793 ! Molecular weight of dry air / water vapor
14705 real , parameter :: amdc = 0.658114 ! Molecular weight of dry air / carbon dioxide
14706 real , parameter :: amdo = 0.603428 ! Molecular weight of dry air / ozone
14707 real , parameter :: amdm = 1.805423 ! Molecular weight of dry air / methane
14708 real , parameter :: amdn = 0.658090 ! Molecular weight of dry air / nitrous oxide
14709 real , parameter :: amdo2 = 0.905140 ! Molecular weight of dry air / oxygen
14710 real , parameter :: amdc1 = 0.210852 ! Molecular weight of dry air / CFC11
14711 real , parameter :: amdc2 = 0.239546 ! Molecular weight of dry air / CFC12
14712 real :: amm, amttl, wvttl, wvsh, summol
14713 integer :: isp, l, ix, n, imol, ib ! Loop indices
14714 integer, save :: counter =0
14716 !real :: gwiff1,gwiff2,gwiff3,gwiff4
14717 !integer :: ilay, iplon, igp
14718 ! integer :: cloudFlagq(pncol, 4)
14719 integer _gpudev :: pncold, nlayd, icldd
14720 integer,external :: omp_get_thread_num
14725 ncol_ = pncol ; nlayers_ = nlay ; nbndlw_ = nbndlw ; ngptlw_ = ngptlw ! for passing through argument list
14726 ncol__ = pncol ; nlayers__ = nlay ; nbndlw__ = nbndlw ; ngptlw__ = ngptlw ! for passing through argument list
14729 icb(:) = (/ 1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5 /)
14731 oneminus = 1. - 1.e-6
14732 pi = 2. * asin(1. )
14733 fluxfac = pi * 2.e4 ! orig: fluxfac = pi * 2.d4
14741 cldfracq(1:pncol,1:nlay) = cldfrac(colstart:(colstart+pncol-1), 1:nlay)
14742 ciwpq(1:pncol,1:nlay) = ciwp(colstart:(colstart+pncol-1), 1:nlay)
14743 clwpq(1:pncol,1:nlay) = clwp(colstart:(colstart+pncol-1), 1:nlay)
14744 cswpq(1:pncol,1:nlay) = cswp(colstart:(colstart+pncol-1), 1:nlay)
14745 reiq(1:pncol,1:nlay) = rei(colstart:(colstart+pncol-1), 1:nlay)
14746 relq(1:pncol,1:nlay) = rel(colstart:(colstart+pncol-1), 1:nlay)
14747 resq(1:pncol,1:nlay) = res(colstart:(colstart+pncol-1), 1:nlay)
14748 taucq(1:pncol,1:nbndlw,1:nlay) = tauc(colstart:(colstart+pncol-1), 1:nbndlw, 1:nlay)
14749 tauaq(1:pncol,1:nlay,1:nbndlw) = tauaer(colstart:(colstart+pncol-1), 1:nlay, 1:nbndlw)
14752 allocate( cldfmcd(pncol, ngptlw, nlay+1))
14753 allocate( ngbd(140) )
14758 # define pncol CHNK
14761 allocate( icbd(16))
14762 allocate( ncbandsd(pncol))
14763 allocate( icldlyr(pncol, nlay+1))
14765 call allocateGPUcldprmcg(pncol, nlay, ngptlw)
14766 call allocateGPUrtrnmcg(pncol, nlay, ngptlw, idrv)
14772 # define nspad nspa
14773 # define nspbd nspb
14775 # define fracsd fracs
14778 # define icldd icld
14781 ! Set imca to select calculation type:
14782 ! imca = 0, use standard forward model calculation
14783 ! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability
14785 ! *** This version uses McICA (imca = 1) ***
14787 ! Set icld to select of clear or cloud calculation and cloud overlap method
14788 ! icld = 0, clear only
14789 ! icld = 1, with clouds using random cloud overlap
14790 ! icld = 2, with clouds using maximum/random cloud overlap
14791 ! icld = 3, with clouds using maximum cloud overlap (McICA only)
14792 ! icld = 4, with clouds using exponential cloud overlap (INACTIVE; McICA only)
14793 if (icld.lt.0.or.icld.gt.4) icld = 2
14795 ! Set iaer to select aerosol option
14796 ! iaer = 0, no aerosols
14797 ! icld = 10, input total aerosol optical depth (tauaer) directly
14800 ! Call model and data initialization, compute lookup tables, perform
14801 ! reduction of g-points from 256 to 140 for input absorption coefficient
14802 ! data and other arrays.
14804 ! In a GCM this call should be placed in the model initialization
14805 ! area, since this has to be called only once.
14806 ! call rrtmg_lw_ini(cpdair)
14808 ! call rrtmg_lw_ini(1.004 )
14809 ! This is the main longitude/column loop within RRTMG.
14810 ! Prepare atmospheric profile from GCM for use in RRTMG, and define
14811 ! other input parameters.
14818 call allocateGPUTaumol( pncol, nlayers, npart)
14821 allocate( fracsd( pncol, nlayers+1, ngptlw ))
14822 allocate( taug( pncol, nlayers+1, ngptlw ))
14824 tbound = tsfc(colstart:(colstart+pncol-1))
14825 pz(:,0:nlay) = plev(colstart:(colstart+pncol-1),0:nlay)
14826 tz(:,0:nlay) = tlev(colstart:(colstart+pncol-1),0:nlay)
14827 pavel(:,1:nlay) = play(colstart:(colstart+pncol-1),1:nlay)
14828 tavel(:,1:nlay) = tlay(colstart:(colstart+pncol-1),1:nlay)
14831 call copyGPUTaumolMol( colstart, pncol, nlayers, h2ovmr, co2vmr, o3vmr, n2ovmr, ch4vmr, &
14832 o2vmr, ccl4vmr, cfc11vmr, cfc12vmr, cfc22vmr, npart)
14834 colh2o(1:pncol, 1:nlayers) = h2ovmr( colstart:(colstart+pncol-1), 1:nlayers)
14835 colco2(1:pncol, 1:nlayers) = co2vmr( colstart:(colstart+pncol-1), 1:nlayers)
14836 colo3(1:pncol, 1:nlayers) = o3vmr( colstart:(colstart+pncol-1), 1:nlayers)
14837 coln2o(1:pncol, 1:nlayers) = n2ovmr( colstart:(colstart+pncol-1), 1:nlayers)
14839 colch4(1:pncol, 1:nlayers) = ch4vmr( colstart:(colstart+pncol-1), 1:nlayers)
14840 colo2(1:pncol, 1:nlayers) = o2vmr( colstart:(colstart+pncol-1), 1:nlayers)
14841 wx1(1:pncol, 1:nlayers) = ccl4vmr(colstart:(colstart+pncol-1), 1:nlayers)
14842 wx2(1:pncol, 1:nlayers) = cfc11vmr(colstart:(colstart+pncol-1), 1:nlayers)
14843 wx3(1:pncol, 1:nlayers) = cfc12vmr(colstart:(colstart+pncol-1), 1:nlayers)
14844 wx4(1:pncol, 1:nlayers) = cfc22vmr(colstart:(colstart+pncol-1), 1:nlayers)
14845 colco(1:pncol, :) = 0
14846 if (npart > 1) then
14847 tauaa(1:pncol, :, :) = tauaer(colstart:(colstart+pncol-1), :, :)
14857 permuteseed=150 ! if you change this, change value in module_ra_rrtmg_lw.F
14858 call mcica_subcol_lwg(colstart, pncol, nlay, icld, counter, permuteseed, &
14860 pmid,clwp,ciwp,cswp,tauc, &
14862 play, cldfracq, ciwpq, &
14863 clwpq, cswpq, taucq,ngbd, cldfmcd, ciwpmcd, clwpmcd, cswpmcd, &
14867 !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num()
14869 ! Generate the stochastic subcolumns of cloud optical properties for the longwave;
14871 dimGrid = dim3( (ncol+255)/256,(140+1)/2, 1)
14872 dimBlock = dim3( 256,2,1)
14875 call generate_stochastic_cloudsg _gpuchv (pncold, nlayd, icldd, ngbd, &
14877 pmid,cldfracq,clwpq,ciwpq,cswpq,taucq,permuteseed, &
14879 cldfmcd, clwpmcd, ciwpmcd, cswpmcd, taucmcd)
14882 !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num()
14883 do iplon = 1, pncol
14885 piplon = iplon + colstart - 1
14889 amm = (1. - h2ovmr(piplon,l)) * amd +h2ovmr(piplon,l) * amw
14890 coldry(iplon, l) = (pz(iplon, l-1)-pz(iplon, l)) * 1.e3 * avogad / &
14891 (1.e2 * grav * amm * (1. + h2ovmr(piplon,l)))
14895 summol = co2vmr(piplon,l) + o3vmr(piplon,l) + n2ovmr(piplon,l) + ch4vmr(piplon,l) + o2vmr(piplon,l)
14896 btemp = h2ovmr(piplon, l) * coldry(iplon, l)
14897 wbrodl(iplon, l) = coldry(iplon, l) * (1. - summol)
14898 amttl = amttl + coldry(iplon, l)+btemp
14899 wvttl = wvttl + btemp
14902 wvsh = (amw * wvttl) / (amd * amttl)
14903 pwvcm(iplon) = wvsh * (1.e3 * pz(iplon, 0)) / (1.e2 * grav)
14905 ! Transfer aerosol optical properties to RRTM variable;
14906 ! modify to reverse layer indexing here if necessary.
14908 if (icld .ge. 1) then
14909 inflag(iplon) = inflglw
14910 iceflag(iplon) = iceflglw
14911 liqflag(iplon) = liqflglw
14913 ! Move incoming GCM cloud arrays to RRTMG cloud arrays.
14914 ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw)
14920 deallocate( pmidd, cldfracd)
14921 deallocate( clwpd, ciwpd, cswpd, taucd)
14923 ! For cloudy atmosphere, use cldprmc to set cloud optical properties based on
14924 ! input cloud physical properties. Select method based on choices described
14925 ! in cldprmc. Cloud fraction, water path, liquid droplet and ice particle
14926 ! effective radius must be passed into cldprmc. Cloud fraction and cloud
14927 ! optical depth are transferred to rrtmg_lw arrays in cldprmc.
14929 ! If the GPU flag is active, then we call the GPU code. Otherwise, call the CPU code
14931 ! (dmb 2012) Copy the needed arrays over to the GPU for the cldprmc subroutine.
14932 call copyGPUcldprmcg( inflag, iceflag, liqflag,&
14933 absice0, absice1, absice2, absice3, absliq1 )
14935 ! copy common arrays over to the GPU
14948 # define delwaved delwave
14949 # define relqmcd relq
14950 # define reicmcd reiq
14951 # define resnmcd resq
14957 ! (dmb 2012) Allocate the arrays for the SetCoef and Taumol kernels
14958 call allocateGPUSetCoef( pncol, nlayers)
14960 ! (dmb 2012) Copy the needed data of to the GPU for the SetCoef and Taumol kernels
14962 call copyGPUTaumol( pavel, wx, coldry, tauaer, pncol, colstart, nlay , npart)
14964 call copyGPUSetCoef( )
14965 ! (dmb 2012) Copy over additional common arrays
14971 semissd(1:pncol,1:nbndlw) = emis(colstart:(colstart+pncol-1),1:nbndlw)
14973 call copyToGPUref()
14974 call copyGPUrtrnmcg(pz, pwvcm, idrv, taut)
14977 semissd(1:pncol,1:nbndlw) = emis(colstart:(colstart+pncol-1),1:nbndlw)
14980 # define taveld tavel
14981 # define tboundd tbound
14982 # define wbroadd wbrodl
14985 # define pwvcmd pwvcm
14986 # define idrvd idrv
14987 # define bpaded bpade
14988 # define heatfacd heatfac
14989 # define fluxfacd fluxfac
14990 # define oneminusd oneminus
14993 ! (dmb 2012) Here we configure the grids and blocks to run the cldpmcd kernel
14994 ! on the GPU. I decided to keep the block dimensions to 16x16 to coincide with
14995 ! coalesced memory access when I am able to parition the profiles to multiples
14998 dimGrid = dim3( (pncol+255)/256,(nlayers)/1, ngptlw)
14999 dimBlock = dim3( 256,1,1)
15003 ! (dmb 2012) Call the cldprmcg kernel
15004 call cldprmcg _gpuchv (pncol, nlayers, &
15006 inflag,iceflag,liqflag,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, &
15007 absice0,absice1,absice2,absice3,absliq1, &
15009 cldfmcd, taucmcd, ngbd, icbd, ncbandsd, icldlyr)
15011 ! synchronize the GPU with the CPU before taking timing results or passing data back to the CPU
15013 ierr = cudaThreadSynchronize()
15017 ! Calculate information needed by the radiative transfer routine
15018 ! that is specific to this atmosphere, especially some of the
15019 ! coefficients and indices needed to compute the optical depths
15020 ! by interpolating data from stored reference atmospheres.
15022 ! (dmb 2012) Initialize the grid and block dimensions and call the setcoefg kernel
15024 dimGrid = dim3( (pncol+255)/256,1, 1)
15025 dimBlock = dim3( 256,1,1)
15027 call setcoefg _gpuchv (pncol, nlayers, istart &
15028 # include "rrtmg_lw_cpu_args.h"
15029 # include "taug_cpu_args.h"
15031 ,tavel,tz,tbound,wbroadd,totplnk,totplk16,totplnkderiv,totplk16deriv &
15035 ! (dmb 2012) end if GPU flag
15037 ! Calculate the gaseous optical depths and Planck fractions for
15038 ! each longwave spectral band.
15040 ! (dmb 2012) Call the taumolg subroutine. This subroutine calls all of the individal taumol kernels.
15041 call taumolg(1, pncol,nlayers, ngbd, taug, fracsd &
15042 !# include "taug_cpu_args.h"
15044 ,ncol__,nlayers__,nbndlw__,ngptlw__ &
15045 ,pavel,wx1,wx2,wx3,wx4,coldry,laytrop,jp,jt,jt1,colh2o,colco2,colo3,coln2o &
15046 ,colco,colch4,colo2,colbrd,indself,indfor,selffac,selffrac,forfac,forfrac &
15047 ,indminor,minorfrac,scaleminor,scaleminorn2,fac00,fac01,fac10,fac11 &
15048 ,rat_h2oco2,rat_h2oco2_1,rat_h2oo3,rat_h2oo3_1,rat_h2on2o,rat_h2on2o_1 &
15049 ,rat_h2och4,rat_h2och4_1,rat_n2oco2,rat_n2oco2_1,rat_o3co2,rat_o3co2_1 &
15050 ,tauaa,nspad,nspbd,oneminusd &
15054 ! Call the radiative transfer routine.
15055 ! Either routine can be called to do clear sky calculation. If clouds
15056 ! are present, then select routine based on cloud overlap assumption
15057 ! to be used. Clear sky calculation is done simultaneously.
15058 ! For McICA, RTRNMC is called for clear and cloudy calculations.
15062 ierr = cudaThreadSynchronize()
15066 dimGrid = dim3( (pncol+255)/256, 70, 1)
15067 dimBlock = dim3( 256,2,1)
15070 call rtrnmcg _gpuchv (pncol,nlayers, istart, iend, iout &
15072 ,ncol_,nlayers_,nbndlw_,ngptlw_ &
15073 ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad &
15074 ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d &
15075 ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd &
15076 ,dtotuclfl_dtd,dplankbnd_dtd &
15078 ,ngbd, icldlyr, taug, fracsd, cldfmcd)
15081 ierr = cudaThreadSynchronize()
15084 !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num()
15086 ! sum up the results
15092 dtotuflux_dtd = 0.0
15093 dtotuclfl_dtd = 0.0
15096 dimGrid = dim3( (pncol+255)/256,nlayers+1,1)
15097 dimBlock = dim3( 256, 1, 1)
15100 uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers))
15101 dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers))
15103 ! (dmb 2012) Here we integrate across the g-point fluxes to arrive at total fluxes
15104 ! This functionality was factored out of the original rtrnmc routine so that I could
15105 ! parallelize across multiple dimensions.
15106 call rtrnadd _gpuchv (pncol, nlayers, ngptlw, idrv &
15108 ,ncol_,nlayers_,nbndlw_,ngptlw_ &
15109 ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad &
15110 ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d &
15111 ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd &
15112 ,dtotuclfl_dtd,dplankbnd_dtd &
15116 ierr = cudaThreadSynchronize()
15117 dimGrid = dim3( (pncol+255)/256,nlayers,1)
15120 uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers))
15121 dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers))
15123 ! (dmb 2012) Calculate the heating rates.
15124 call rtrnheatrates _gpuchv (pncol, nlayers &
15126 ,ncol_,nlayers_,nbndlw_,ngptlw_ &
15127 ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad &
15128 ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d &
15129 ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd &
15130 ,dtotuclfl_dtd,dplankbnd_dtd &
15134 ierr = cudaThreadSynchronize()
15137 ! copy the partition data back to the CPU
15139 !these are redundant with the copies before the call to rtrnheatrates, above
15140 uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers))
15141 dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers))
15143 uflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totuclfld(1:pncol,0:(nlayers))
15144 dflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdclfld(1:pncol,0:(nlayers))
15145 hr(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrd(1:pncol,0:(nlayers))
15146 hrc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrcd(1:pncol,0:(nlayers))
15148 if (idrv .eq. 1) then
15150 duflx_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuflux_dtd(1:pncol,0:(nlayers))
15151 duflxc_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuclfl_dtd(1:pncol,0:(nlayers))
15155 !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num()
15157 ! Transfer up and down fluxes and heating rate to output arrays.
15158 ! Vertical indexing goes from bottom to top; reverse here for GCM if necessary.
15160 deallocate( cldfmcd)
15162 deallocate( ncbandsd)
15163 deallocate( icldlyr)
15165 call deallocateGPUTaumol()
15166 deallocate( fracsd)
15169 call deallocateGPUcldprmcg()
15170 call deallocateGPUrtrnmcg(idrv)
15171 call deallocateGPUSetCoef( )
15198 end subroutine rrtmg_lw_part
15200 end module rrtmg_lw_rad_f
15208 !------------------------------------------------------------------
15209 MODULE module_ra_rrtmg_lwf
15211 use module_model_constants, only : cp
15212 use module_wrf_error
15215 use parrrtm_f, only : nbndlw, ngptlw
15216 use rrtmg_lw_init_f, only: rrtmg_lw_ini
15217 use rrtmg_lw_rad_f, only: rrtmg_lw
15218 ! use mcica_subcol_gen_lw, only: mcica_subcol_lw
15222 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, &
15223 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, &
15224 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, &
15225 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, &
15226 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, &
15227 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, &
15228 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, &
15229 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, &
15230 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, &
15231 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, &
15232 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, &
15233 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, &
15234 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, &
15235 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, &
15236 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, &
15237 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/
15240 ! For buffer layer adjustment. Steven Cavallo, Dec 2010.
15241 INTEGER , SAVE :: nlayers
15242 REAL, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb
15246 !------------------------------------------------------------------
15247 SUBROUTINE RRTMG_LWRAD_FAST( &
15250 lwupt, lwuptc, lwdnt, lwdntc, &
15251 lwupb, lwupbc, lwdnb, lwdnbc, &
15252 ! lwupflx, lwupflxc, lwdnflx, lwdnflxc, &
15253 glw, olr, lwcf, emiss, &
15255 dz8w, tsk, t3d, t8w, rho3d, r, g, &
15256 icloud, warm_rain, cldfra3d, &
15259 f_ice_phy, f_rain_phy, &
15260 xland, xice, snow, &
15261 qv3d, qc3d, qr3d, &
15262 qi3d, qs3d, qg3d, &
15264 f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, &
15265 re_cloud, re_ice, re_snow, & ! G. Thompson
15266 has_reqc, has_reqi, has_reqs, & ! G. Thompson
15267 tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
15268 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
15269 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
15270 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao
15271 aer_ra_feedback, & !czhao
15272 !jdfcz progn,prescribe, & !czhao
15274 qndrop3d,f_qndrop, & !czhao
15275 !ccc added for time varying gases.
15276 yr,julian,ghg_input, &
15278 ids,ide, jds,jde, kds,kde, &
15279 ims,ime, jms,jme, kms,kme, &
15280 its,ite, jts,jte, kts,kte, &
15281 lwupflx, lwupflxc, lwdnflx, lwdnflxc &
15283 !------------------------------------------------------------------
15284 !ccc To use clWRF time varying trace gases
15285 USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
15288 !------------------------------------------------------------------
15289 LOGICAL, INTENT(IN ) :: warm_rain
15290 LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
15292 INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, &
15293 ims,ime, jms,jme, kms,kme, &
15294 its,ite, jts,jte, kts,kte
15296 INTEGER, INTENT(IN ) :: ICLOUD, GHG_INPUT
15298 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
15299 INTENT(IN ) :: dz8w, &
15307 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
15308 INTENT(INOUT) :: RTHRATENLW, &
15310 REAL, DIMENSION( ims:ime, jms:jme ) , &
15311 INTENT(INOUT) :: GLW, &
15315 REAL, DIMENSION( ims:ime, jms:jme ) , &
15316 INTENT(IN ) :: EMISS, &
15319 REAL, INTENT(IN ) :: R,G
15321 REAL, DIMENSION( ims:ime, jms:jme ) , &
15322 INTENT(IN ) :: XLAND, &
15325 !ccc Added for time-varying trace gases.
15326 INTEGER, INTENT(IN ) :: yr
15327 REAL, INTENT(IN ) :: julian
15333 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
15348 !..Added by G. Thompson to couple cloud physics effective radii.
15349 REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: &
15353 INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
15355 real pi,third,relconst,lwpmin,rhoh2o
15357 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
15363 LOGICAL, OPTIONAL, INTENT(IN) :: &
15364 F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP
15366 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , &
15367 INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao
15368 tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao
15369 tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao
15370 tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
15372 INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback
15373 !jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe
15374 INTEGER, INTENT(IN ), OPTIONAL :: progn
15376 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , &
15378 INTENT(INOUT) :: O33D
15379 INTEGER, INTENT(IN ) :: o3input
15381 real, parameter :: thresh=1.e-9
15383 character(len=200) :: msg
15386 ! Top of atmosphere and surface longwave fluxes (W m-2)
15387 REAL, DIMENSION( ims:ime, jms:jme ), &
15388 OPTIONAL, INTENT(INOUT) :: &
15389 LWUPT,LWUPTC,LWDNT,LWDNTC, &
15390 LWUPB,LWUPBC,LWDNB,LWDNBC
15392 ! Layer longwave fluxes (including extra layer above model top)
15393 ! Vertical ordering is from bottom to top (W m-2)
15394 REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), &
15395 OPTIONAL, INTENT(OUT) :: &
15396 LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC
15400 REAL, DIMENSION( kts:kte+1 ) :: Pw1D, &
15403 REAL, DIMENSION( kts:kte ) :: TTEN1D, &
15417 ! Added local arrays for RRTMG
15425 ! the mod in the macro below is to quiet range checking
15426 #define TILEPTS (jte-jts+1)*(ite-its+1)+mod((jte-jts+1)*(ite-its+1),CHNK)
15427 ! Dimension with extra layer from model top to TOA
15428 real, dimension( TILEPTS, kts:nlayers+1 ) :: &
15431 real, dimension( TILEPTS, kts:nlayers ) :: &
15444 real, dimension( kts:nlayers ) :: o3mmr
15445 ! For old cloud property specification for rrtm_lw
15446 real, dimension( kts:kte ) :: clwp, &
15451 ! Surface emissivity (for 16 LW spectral bands)
15452 real, dimension( TILEPTS, nbndlw ) :: &
15454 ! Dimension with extra layer from model top to TOA,
15455 ! though no clouds are allowed in extra layer
15456 real, dimension( TILEPTS, kts:nlayers ) :: &
15464 real, dimension( TILEPTS, nbndlw, kts:nlayers ) :: &
15466 real, dimension( TILEPTS, kts:nlayers, nbndlw ) :: &
15468 real, dimension( TILEPTS, kts:nlayers+1 ) :: &
15473 real, dimension( TILEPTS, kts:nlayers+1 ) :: &
15476 real, dimension( TILEPTS, kts:nlayers+1 ) :: &
15480 real, dimension ( TILEPTS ) :: &
15485 real:: snow_mass_factor
15487 !..We can use message interface regardless of what options are running,
15488 !.. so let us ask for it here.
15489 CHARACTER(LEN=256) :: message
15490 LOGICAL, EXTERNAL :: wrf_dm_on_monitor
15492 !ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc. from file
15493 ! then interpolate to date of run.
15494 REAL(8) :: co2, n2o, ch4, cfc11, cfc12
15496 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
15500 data cfc22 / 0.169e-9 /
15503 data ccl4 / 0.093e-9 /
15504 ! Set oxygen volume mixing ratio (for o2mmr=0.23143)
15506 data o2 / 0.209488 /
15508 integer :: iplon, irng, permuteseed
15511 ! For old cloud property specification for rrtm_lw
15512 ! Cloud and precipitation absorption coefficients
15513 real :: abcw,abice,abrn,absn
15515 data abice /0.0735/
15516 data abrn /0.330e-3/
15517 data absn /2.34e-3/
15519 ! Molecular weights and ratios for converting mmr to vmr units
15520 ! real :: amd ! Effective molecular weight of dry air (g/mol)
15521 ! real :: amw ! Molecular weight of water vapor (g/mol)
15522 ! real :: amo ! Molecular weight of ozone (g/mol)
15523 ! real :: amo2 ! Molecular weight of oxygen (g/mol)
15524 ! Atomic weights for conversion from mass to volume mixing ratios
15525 ! data amd / 28.9660 /
15526 ! data amw / 18.0160 /
15527 ! data amo / 47.9998 /
15528 ! data amo2 / 31.9999 /
15530 real :: amdw ! Molecular weight of dry air / water vapor
15531 real :: amdo ! Molecular weight of dry air / ozone
15532 real :: amdo2 ! Molecular weight of dry air / oxygen
15533 data amdw / 1.607793 /
15534 data amdo / 0.603461 /
15535 data amdo2 / 0.905190 /
15538 real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb)
15540 real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path
15541 cliqwp, & ! in-cloud cloud liquid water path
15542 csnowp, & ! in-cloud snow water path
15543 reliq, & ! effective drop radius (microns)
15544 reice ! effective ice crystal size (microns)
15545 real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1):: recloud1d, &
15549 real :: gliqwp, gicewp, gsnowp, gravmks
15552 ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP
15554 real, dimension ((jte-jts+1)*(ite-its+1)) :: landfrac, landm, snowh, icefrac
15556 integer :: pcols, pver
15559 INTEGER :: i,j,K, idx_rei
15561 LOGICAL :: predicate
15563 ! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010
15564 INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table
15565 INTEGER :: L, LL, klev ! Loop indices
15566 REAL, DIMENSION( kts:nlayers+1 ) :: varint
15567 REAL :: wght,vark,vark1
15568 REAL :: PPROF(nproflevs), TPROF(nproflevs)
15569 ! Weighted mean pressure and temperature profiles from midlatitude
15570 ! summer (MLS),midlatitude winter (MLW), sub-Arctic
15571 ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP)
15572 ! standard atmospheres.
15573 DATA PPROF /1000.00,855.47,731.82,626.05,535.57,458.16, &
15574 391.94,335.29,286.83,245.38,209.91,179.57, &
15575 153.62,131.41,112.42,96.17,82.27,70.38, &
15576 60.21,51.51,44.06,37.69,32.25,27.59, &
15577 23.60,20.19,17.27,14.77,12.64,10.81, &
15578 9.25,7.91,6.77,5.79,4.95,4.24, &
15579 3.63,3.10,2.65,2.27,1.94,1.66, &
15580 1.42,1.22,1.04,0.89,0.76,0.65, &
15581 0.56,0.48,0.41,0.35,0.30,0.26, &
15582 0.22,0.19,0.16,0.14,0.12,0.10/
15583 DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, &
15584 245.62,238.41,231.57,225.91,221.72,217.79, &
15585 215.06,212.74,210.25,210.16,210.69,212.14, &
15586 213.74,215.37,216.82,217.94,219.03,220.18, &
15587 221.37,222.64,224.16,225.88,227.63,229.51, &
15588 231.50,233.73,236.18,238.78,241.60,244.44, &
15589 247.35,250.33,253.32,256.30,259.22,262.12, &
15590 264.80,266.50,267.59,268.44,268.69,267.76, &
15591 266.13,263.96,261.54,258.93,256.15,253.23, &
15592 249.89,246.67,243.48,240.25,236.66,233.86/
15593 !------------------------------------------------------------------
15594 #if ( WRF_CHEM == 1 )
15595 IF ( aer_ra_feedback == 1) then
15597 ( PRESENT(tauaerlw1) .AND. &
15598 PRESENT(tauaerlw2) .AND. &
15599 PRESENT(tauaerlw3) .AND. &
15600 PRESENT(tauaerlw4) .AND. &
15601 PRESENT(tauaerlw5) .AND. &
15602 PRESENT(tauaerlw6) .AND. &
15603 PRESENT(tauaerlw7) .AND. &
15604 PRESENT(tauaerlw8) .AND. &
15605 PRESENT(tauaerlw9) .AND. &
15606 PRESENT(tauaerlw10) .AND. &
15607 PRESENT(tauaerlw11) .AND. &
15608 PRESENT(tauaerlw12) .AND. &
15609 PRESENT(tauaerlw13) .AND. &
15610 PRESENT(tauaerlw14) .AND. &
15611 PRESENT(tauaerlw15) .AND. &
15612 PRESENT(tauaerlw16) ) ) THEN
15613 CALL wrf_error_fatal &
15614 ('Warning: missing fields required for aerosol radiation' )
15620 !-----CALCULATE LONG WAVE RADIATION
15622 ! All fields are ordered vertically from bottom to top
15623 ! Pressures are in mb
15625 !ccc Read time-varying trace gases concentrations and interpolate them to run date.
15627 IF ( GHG_INPUT .EQ. 1 ) THEN
15628 CALL read_CAMgases(yr,julian,.false.,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
15629 IF ( wrf_dm_on_monitor() ) THEN
15630 WRITE(message,*)'RRTMG LWF CLWRF interpolated GHG values year:',yr,' julian day:',julian
15631 call wrf_debug( 1, message)
15632 WRITE(message,*)' co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12
15633 call wrf_debug( 1, message)
15636 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
15637 ! Annual function for co2 in WRF v4.2
15638 co2 = (280. + 90.*exp(0.02*(yr-2000)))*1.e-6
15648 ncol = (jte-jts+1)*(ite-its+1)
15651 j_loop: do j = jts,jte
15654 i_loop: do i = its,ite
15656 icol = i-its+1 + (j-jts)*(ite-its+1)
15659 Pw1D(K) = p8w(I,K,J)/100.
15660 Tw1D(K) = t8w(I,K,J)
15673 QV1D(K)=QV3D(I,K,J)
15674 QV1D(K)=max(0.,QV1D(K))
15677 IF (o3input.eq.2) THEN
15679 O31D(K)=O33D(I,K,J)
15690 P1D(K)=P3D(I,K,J)/100.
15691 DZ1D(K)=dz8w(I,K,J)
15696 IF (ICLOUD .ne. 0) THEN
15697 IF ( PRESENT( CLDFRA3D ) ) THEN
15699 CLDFRA1D(k)=CLDFRA3D(I,K,J)
15703 IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN
15706 QC1D(K)=QC3D(I,K,J)
15707 QC1D(K)=max(0.,QC1D(K))
15712 IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN
15715 QR1D(K)=QR3D(I,K,J)
15716 QR1D(K)=max(0.,QR1D(K))
15721 IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN
15724 qndrop1d(K)=qndrop3d(I,K,J)
15729 ! This logic is tortured because cannot test F_QI unless
15730 ! it is present, and order of evaluation of expressions
15731 ! is not specified in Fortran
15733 IF ( PRESENT ( F_QI ) ) THEN
15736 predicate = .FALSE.
15740 IF (.NOT. predicate .and. .not. warm_rain) THEN
15742 IF (T1D(K) .lt. 273.15) THEN
15751 IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN
15754 QI1D(K)=QI3D(I,K,J)
15755 QI1D(K)=max(0.,QI1D(K))
15760 IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN
15763 QS1D(K)=QS3D(I,K,J)
15764 QS1D(K)=max(0.,QS1D(K))
15769 IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN
15772 QG1D(K)=QG3D(I,K,J)
15773 QG1D(K)=max(0.,QG1D(K))
15778 ! mji - For MP option 5
15779 IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
15780 IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
15782 qi1d(k) = 0.1*qs3d(i,k,j)
15783 qs1d(k) = 0.9*qs3d(i,k,j)
15784 qc1d(k) = qc3d(i,k,j)
15785 qi1d(k) = max(0.,qi1d(k))
15786 qc1d(k) = max(0.,qc1d(k))
15793 ! EMISS0=EMISS(I,J)
15798 QV1D(K)=AMAX1(QV1D(K),1.E-12)
15801 ! Set up input for longwave
15803 ! Add extra layer from top of model to top of atmosphere
15804 ! nlay = (kte - kts + 1) + 1
15805 ! Edited for top of model adjustment (nlayers = kte + 1).
15806 ! Steven Cavallo, December 2010
15807 nlay = nlayers ! Keep these indices the same
15809 ! For optional calculation of the approximate change in upward flux as a function
15810 ! of surface temperature only between full radiation calls (0=off, 1=on)
15813 ! Select cloud liquid and ice optics parameterization options
15814 ! For passing in cloud optical properties directly:
15819 ! For passing in cloud physical properties; cloud optics parameterized in RRTMG:
15825 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
15826 IF (ICLOUD .ne. 0) THEN
15827 IF ( has_reqc .ne. 0) THEN
15830 recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
15831 if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
15832 & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean
15833 recloud1D(icol,K) = 10.5
15834 elseif(recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. &
15835 & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land
15836 recloud1D(icol,K) = 7.5
15841 recloud1D(icol,K) = 5.0
15845 IF ( has_reqi .ne. 0) THEN
15849 reice1D(icol,K) = MAX(5., re_ice(I,K,J)*1.E6)
15850 if (reice1D(icol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then
15851 idx_rei = int(t3d(i,k,j)-179.)
15852 idx_rei = min(max(idx_rei,1),75)
15853 corr = t3d(i,k,j) - int(t3d(i,k,j))
15854 reice1D(icol,K) = retab(idx_rei)*(1.-corr) + &
15855 & retab(idx_rei+1)*corr
15856 reice1D(icol,K) = MAX(reice1D(icol,K), 5.0)
15861 reice1D(icol,K) = 10.0
15865 IF ( has_reqs .ne. 0) THEN
15869 resnow1D(icol,K) = MAX(10., re_snow(I,K,J)*1.E6)
15873 resnow1D(icol,K) = 10.0
15877 ! special case for P3 microphysics
15878 ! put ice into snow category for optics, then set ice to zero
15879 IF (has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
15883 resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
15884 QS1D(K)=QI3D(I,K,J)
15886 reice1D(ncol,K)=10.
15892 ! Layer indexing goes bottom to top here for all fields.
15893 ! Water vapor and ozone are converted from mmr to vmr.
15894 ! Pressures are in units of mb here.
15895 plev(icol,1) = pw1d(1)
15898 tlev(icol,1) = tw1d(1)
15899 tsfc(icol) = tsk(i,j)
15901 play(icol,k) = p1d(k)
15902 plev(icol,k+1) = pw1d(k+1)
15903 pdel(icol,k) = plev(icol,k) - plev(icol,k+1)
15904 tlay(icol,k) = t1d(k)
15905 tlev(icol,k+1) = tw1d(k+1)
15906 h2ovmr(icol,k) = qv1d(k) * amdw
15907 co2vmr(icol,k) = co2
15909 ch4vmr(icol,k) = ch4
15910 n2ovmr(icol,k) = n2o
15911 cfc11vmr(icol,k) = cfc11
15912 cfc12vmr(icol,k) = cfc12
15913 cfc22vmr(icol,k) = cfc22
15914 ccl4vmr(icol,k) = ccl4
15917 ! This section is replaced with a new method to deal with model top
15920 ! Define profile values for extra layer from model top to top of atmosphere.
15921 ! The top layer temperature for all gridpoints is set to the top layer-1
15922 ! temperature plus a constant (0 K) that represents an isothermal layer
15923 ! above ptop. Top layer interface temperatures are linearly interpolated
15924 ! from the layer temperatures.
15926 play(icol,kte+1) = 0.5 * plev(icol,kte+1)
15927 tlay(icol,kte+1) = tlev(icol,kte+1) + 0.0
15928 plev(icol,kte+2) = 1.0e-5
15929 tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0
15930 h2ovmr(icol,kte+1) = h2ovmr(icol,kte)
15931 co2vmr(icol,kte+1) = co2vmr(icol,kte)
15932 o2vmr(icol,kte+1) = o2vmr(icol,kte)
15933 ch4vmr(icol,kte+1) = ch4vmr(icol,kte)
15934 n2ovmr(icol,kte+1) = n2ovmr(icol,kte)
15935 cfc11vmr(icol,kte+1) = cfc11vmr(icol,kte)
15936 cfc12vmr(icol,kte+1) = cfc12vmr(icol,kte)
15937 cfc22vmr(icol,kte+1) = cfc22vmr(icol,kte)
15938 ccl4vmr(icol,kte+1) = ccl4vmr(icol,kte)
15942 ! Set up values for extra layers to the top of the atmosphere.
15943 ! Temperature is calculated based on an average temperature profile given
15944 ! here in a table. The input table data is linearly interpolated to the
15945 ! column pressure. Mixing ratios are held constant except for ozone.
15946 ! Caution should be used if model top pressure is less than 5 hPa.
15947 ! Steven Cavallo, NCAR/MMM, December 2010
15948 ! Calculate the column pressure buffer levels above the
15950 do L=kte+1,nlayers,1
15951 plev(icol,L+1) = plev(icol,L) - deltap
15952 play(icol,L) = 0.5*(plev(icol,L) + plev(icol,L+1))
15954 ! Add zero as top level. This gets the temperature max at the
15955 ! stratopause, reducing the downward flux errors in the top
15956 ! levels. If zero happened to be the top level already,
15957 ! this will add another level with zero, but will not affect
15958 ! the radiative transfer calculation.
15959 plev(icol,nlayers+1) = 0.00
15960 play(icol,nlayers) = 0.5*(plev(icol,nlayers) + plev(icol,nlayers+1))
15962 ! Interpolate the table temperatures to column pressure levels
15964 if ( PPROF(nproflevs) .lt. plev(icol,L) ) then
15965 do LL=2,nproflevs,1
15966 if ( PPROF(LL) .lt. plev(icol,L) ) then
15976 if (klev .ne. nproflevs ) then
15978 vark1 = TPROF(klev+1)
15979 wght=(plev(icol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev))
15982 vark1 = TPROF(klev)
15985 varint(L) = wght*(vark1-vark)+vark
15989 ! Match the interpolated table temperature profile to WRF column
15990 do L=kte+1,nlayers+1,1
15991 tlev(icol,L) = varint(L) + (tlev(icol,kte) - varint(kte))
15992 !if ( L .le. nlay ) then
15993 tlay(icol,L-1) = 0.5*(tlev(icol,L) + tlev(icol,L-1))
15997 ! Now the chemical species (except for ozone)
15998 do L=kte+1,nlayers,1
15999 h2ovmr(icol,L) = h2ovmr(icol,kte)
16000 co2vmr(icol,L) = co2vmr(icol,kte)
16001 o2vmr(icol,L) = o2vmr(icol,kte)
16002 ch4vmr(icol,L) = ch4vmr(icol,kte)
16003 n2ovmr(icol,L) = n2ovmr(icol,kte)
16004 cfc11vmr(icol,L) = cfc11vmr(icol,kte)
16005 cfc12vmr(icol,L) = cfc12vmr(icol,kte)
16006 cfc22vmr(icol,L) = cfc22vmr(icol,kte)
16007 ccl4vmr(icol,L) = ccl4vmr(icol,kte)
16009 ! End top of model buffer
16010 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
16011 ! Get ozone profile including amount in extra layer above model top.
16012 ! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers
16013 ! dimension for o3mmr
16014 ! call inirad (o3mmr,plev,kts,nlay-1)
16015 call inirad (o3mmr,plev(icol,:),kts,nlay-1)
16017 ! Steven Cavallo: Changed to nlayers from kte+1
16018 if(o3input.eq.2) then
16019 do k = kts, nlayers
16020 o3vmr(icol,k) = o3mmr(k) * amdo
16022 o3vmr(icol,k) = o31d(k)
16024 ! apply shifted climatology profile above model top
16025 o3vmr(icol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
16026 if(o3vmr(icol,k) .le. 0.)o3vmr(icol,k) = o3mmr(k)*amdo
16030 do k = kts, nlayers
16031 o3vmr(icol,k) = o3mmr(k) * amdo
16035 ! Set surface emissivity in each RRTMG longwave band
16037 emis(icol, nb) = emiss(i,j)
16040 ! Define cloud optical properties for radiation (inflglw = 0)
16041 ! This is approach used with older RRTM_LW;
16042 ! Cloud and precipitation paths in g/m2
16043 ! qi=0 if no ice phase
16044 ! qs=0 if no ice phase
16045 if (inflglw .eq. 0) then
16047 ro = p1d(k) / (r * t1d(k))*100.
16049 clwp(k) = ro*qc1d(k)*dz*1000.
16050 ciwp(k) = ro*qi1d(k)*dz*1000.
16051 plwp(k) = (ro*qr1d(k))**0.75*dz*1000.
16052 piwp(k) = (ro*qs1d(k))**0.75*dz*1000.
16055 ! Cloud fraction and cloud optical depth; old approach used with RRTM_LW
16057 cldfrac(icol,k) = cldfra1d(k)
16059 taucld(icol,nb,k) = abcw*clwp(k) + abice*ciwp(k) &
16060 +abrn*plwp(k) + absn*piwp(k)
16061 if (taucld(icol,nb,k) .gt. 0.01) cldfrac(icol,k) = 1.
16065 ! Zero out cloud physical property arrays; not used when passing optical properties
16068 clwpth(icol,k) = 0.0
16069 ciwpth(icol,k) = 0.0
16075 ! Define cloud physical properties for radiation (inflglw = 1 or 2)
16077 ! Set cloud arrays if passing cloud physical properties into radiation
16078 if (inflglw .gt. 0) then
16080 cldfrac(icol,k) = cldfra1d(k)
16083 ! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method)
16085 pver = kte - kts + 1
16087 landfrac(icol) = 2.-XLAND(I,J)
16088 landm(icol) = landfrac(icol)
16089 snowh(icol) = 0.001*SNOW(I,J)
16090 icefrac(icol) = XICE(I,J)
16092 ! From module_ra_cam: Convert liquid and ice mixing ratios to water paths;
16093 ! pdel is in mb here; convert back to Pa (*100.)
16094 ! Water paths are in units of g/m2
16095 ! snow added as ice cloud (JD 091022)
16097 gicewp = (qi1d(k)+qs1d(k)) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
16098 gliqwp = qc1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path.
16099 cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path.
16100 cliqwp(icol,k) = gliqwp / max(0.01,cldfrac(icol,k)) ! In-cloud liquid water path.
16105 !..The ice water path is already sum of cloud ice and snow, but when we have explicit
16106 !.. ice effective radius, overwrite the ice path with only the cloud ice variable,
16107 !.. leaving out the snow for its own effect.
16108 if(iceflglw.ge.4)then
16110 gicewp = qi1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path.
16111 cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path.
16115 !..Here the snow path is adjusted if (radiation) effective radius of snow is
16116 !.. larger than what we currently have in the lookup tables. Since mass goes
16117 !.. rather close to diameter squared, adjust the mixing ratio of snow used
16118 !.. to compute its water path in combination with the max diameter. Not a
16119 !.. perfect fix, but certainly better than using all snow mass when diameter is
16120 !.. far larger than table currently contains and crystal sizes much larger than
16121 !.. about 140 microns have lesser impact than those much smaller sizes.
16123 if(iceflglw.eq.5)then
16125 snow_mass_factor = 0.99 ! Assume 1% of snow overlaps the cloud ice category
16126 gicewp = gicewp + (qs1d(k)*(1.0-snow_mass_factor) * pdel(ncol,k)*100.0 / gravmks * 1000.0)
16127 if (resnow1d(icol,k) .gt. 130.)then
16128 snow_mass_factor = MIN(snow_mass_factor, &
16129 & (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k)))
16130 resnow1d(icol,k) = 130.0
16131 IF ( wrf_dm_on_monitor() ) THEN
16132 WRITE(message,*)'RRTMG: reducing snow mass (cloud path) to ', &
16133 nint(snow_mass_factor*100.), ' percent of full value'
16134 call wrf_debug(150, message)
16137 gsnowp = qs1d(k) * snow_mass_factor * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path.
16138 csnowp(icol,k) = gsnowp / max(0.01,cldfrac(icol,k))
16143 !link the aerosol feedback to cloud -czhao
16144 if( PRESENT( progn ) ) then
16145 if (progn == 1) then
16146 !jdfcz if(prescribe==0) then
16151 relconst=3/(4.*pi*rhoh2o)
16152 ! minimun liquid water path to calculate rel
16153 ! corresponds to optical depth of 1.e-3 for radius 4 microns.
16156 reliq(icol,k) = 10.
16157 if( PRESENT( F_QNDROP ) ) then
16158 if( F_QNDROP ) then
16159 if ( qc1d(k)*pdel(icol,k).gt.lwpmin.and. &
16160 qndrop1d(k).gt.1000. ) then
16161 reliq(icol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m
16162 ! apply scaling from Martin et al., JAS 51, 1830.
16163 reliq(icol,k)=1.1*reliq(icol,k)
16164 reliq(icol,k)=reliq(icol,k)*1.e6 ! convert from m to microns
16165 reliq(icol,k)=max(reliq(icol,k),4.)
16166 reliq(icol,k)=min(reliq(icol,k),20.)
16171 !jdfcz else ! prescribe
16173 ! call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
16174 ! write(0,*) 'lw prescribe aerosol',maxval(qndrop3d)
16177 call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
16179 else !present(progn)
16180 call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
16183 ! following Kristjansson and Mitchell
16184 call reicalc(icol, pcols, pver, tlay, reice)
16187 !..If we already have effective radius of cloud and ice, then just overwrite what
16188 !.. was computed in the relcalc and reicalc subroutines above.
16190 if (inflglw .ge. 3) then
16192 reliq(icol,k) = recloud1d(icol,k)
16195 if (iceflglw .ge. 4) then
16197 reice(icol,k) = reice1d(icol,k)
16201 ! Limit upper bound of reice for Fu ice parameterization and convert
16202 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
16203 if (iceflglw .eq. 3) then
16205 reice(icol,k) = reice(icol,k) * 1.0315
16206 reice(icol,k) = min(140.0,reice(icol,k))
16209 !if CAMMGMP is used, use output from CAMMGMP
16210 if(is_CAMMGMP_used) then
16212 if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
16213 reice(icol,k) = iradius(i,k,j)
16215 reice(icol,k) = 25.
16217 reice(icol,k) = max(5., min(140.0,reice(icol,k)))
16218 if ( qc1d(k) .gt. 1.e-20) then
16219 reliq(icol,k) = lradius(i,k,j)
16221 reliq(icol,k) = 10.
16223 reliq(icol,k) = max(2.5, min(60.0,reliq(icol,k)))
16228 ! Set cloud physical property arrays
16230 clwpth(icol,k) = cliqwp(icol,k)
16231 ciwpth(icol,k) = cicewp(icol,k)
16232 rel(icol,k) = reliq(icol,k)
16233 rei(icol,k) = reice(icol,k)
16237 if (inflglw .eq. 5) then
16239 cswpth(icol,k) = csnowp(icol,k)
16240 res(icol,k) = resnow1d(icol,k)
16244 cswpth(icol,k) = 0.
16249 ! Zero out cloud optical properties here; not used when passing physical properties
16250 ! to radiation and taucld is calculated in radiation
16253 taucld(icol,nb,k) = 0.0
16258 ! No clouds are allowed in the extra layer from model top to TOA
16259 ! Steven Cavallo: Edited out for buffer adjustment below
16263 clwpth(icol,kte+1) = 0.
16264 ciwpth(icol,kte+1) = 0.
16265 cswpth(icol,kte+1) = 0.
16266 rel(icol,kte+1) = 10.
16267 rei(icol,kte+1) = 10.
16268 res(icol,kte+1) = 10.
16269 cldfrac(icol,kte+1) = 0.
16271 taucld(icol,nb,kte+1) = 0.
16276 ! Buffer adjustment. Steven Cavallo December 2010
16278 clwpth(icol,k) = 0.
16279 ciwpth(icol,k) = 0.
16280 cswpth(icol,k) = 0.
16284 cldfrac(icol,k) = 0.
16286 taucld(icol,nb,k) = 0.
16290 ! mji - mcica sub-column generator called inside rrtmg_lw for gpu
16293 ! Sub-column generator for McICA
16294 ! call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
16295 ! cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, cldfmcl, &
16296 ! ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl)
16298 !--------------------------------------------------------------------------
16299 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
16300 !--------------------------------------------------------------------------
16301 ! Aerosol optical depth by layer for each RRTMG longwave band
16302 ! No aerosols in layer above model top (kte+1)
16303 ! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1
16304 ! do nb = 1, nbndlw
16305 ! do k = kts, kte+1
16306 ! tauaer(ncol,k,nb) = 0.
16310 ! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao
16314 tauaer(icol,k,nb) = 0.
16318 #if ( WRF_CHEM == 1 )
16319 IF ( AER_RA_FEEDBACK == 1) then
16320 ! do nb = 1, nbndlw
16321 do k = kts,kte !wig
16322 if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then
16323 tauaer(icol,k,1)=tauaerlw1(i,k,j)
16324 tauaer(icol,k,2)=tauaerlw2(i,k,j)
16325 tauaer(icol,k,3)=tauaerlw3(i,k,j)
16326 tauaer(icol,k,4)=tauaerlw4(i,k,j)
16327 tauaer(icol,k,5)=tauaerlw5(i,k,j)
16328 tauaer(icol,k,6)=tauaerlw6(i,k,j)
16329 tauaer(icol,k,7)=tauaerlw7(i,k,j)
16330 tauaer(icol,k,8)=tauaerlw8(i,k,j)
16331 tauaer(icol,k,9)=tauaerlw9(i,k,j)
16332 tauaer(icol,k,10)=tauaerlw10(i,k,j)
16333 tauaer(icol,k,11)=tauaerlw11(i,k,j)
16334 tauaer(icol,k,12)=tauaerlw12(i,k,j)
16335 tauaer(icol,k,13)=tauaerlw13(i,k,j)
16336 tauaer(icol,k,14)=tauaerlw14(i,k,j)
16337 tauaer(icol,k,15)=tauaerlw15(i,k,j)
16338 tauaer(icol,k,16)=tauaerlw16(i,k,j)
16345 slope = 0. !use slope as a sum holder
16347 slope = slope + tauaer(icol,k,nb)
16349 if( slope < 0. ) then
16350 write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
16351 call wrf_error_fatal(msg)
16352 else if( slope > 5. ) then
16353 call wrf_message("-------------------------")
16354 write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb
16355 call wrf_message(msg)
16357 call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16")
16359 write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j)
16360 call wrf_message(msg)
16362 call wrf_message("-------------------------")
16365 endif ! aer_ra_feedback
16372 ! Call RRTMG longwave radiation model for full grid for gpu
16374 (ncol ,nlay ,icld ,idrv , &
16375 play ,plev ,tlay ,tlev ,tsfc , &
16376 h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , &
16377 cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , &
16378 inflglw ,iceflglw,liqflglw,cldfrac , &
16379 taucld ,ciwpth ,clwpth ,cswpth ,rei ,rel ,res , &
16381 uflx ,dflx ,hr ,uflxc ,dflxc, hrc, &
16382 duflx_dt,duflxc_dt)
16384 ! Output downard surface flux, and outgoing longwave flux and cloud forcing
16385 ! at the top of atmosphere (W/m2)
16388 j_loop2: do j = jts,jte
16391 i_loop2: do i = its,ite
16393 icol = i-its+1 + (j-jts)*(ite-its+1)
16395 glw(i,j) = dflx(icol,1)
16396 ! olr(i,j) = uflx(icol,kte+2)
16397 ! lwcf(i,j) = uflxc(icol,kte+2) - uflx(icol,kte+2)
16398 ! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead
16399 ! of top of model. Dec 2010.
16400 olr(i,j) = uflx(icol,nlayers+1)
16401 lwcf(i,j) = uflxc(icol,nlayers+1) - uflx(icol,nlayers+1)
16403 if (present(lwupt)) then
16404 ! Output up and down toa fluxes for total and clear sky
16405 lwupt(i,j) = uflx(icol,nlayers+1)
16406 lwuptc(i,j) = uflxc(icol,nlayers+1)
16407 lwdnt(i,j) = dflx(icol,nlayers+1)
16408 lwdntc(i,j) = dflxc(icol,nlayers+1)
16409 ! Output up and down surface fluxes for total and clear sky
16410 lwupb(i,j) = uflx(icol,1)
16411 lwupbc(i,j) = uflxc(icol,1)
16412 lwdnb(i,j) = dflx(icol,1)
16413 lwdnbc(i,j) = dflxc(icol,1)
16416 ! Output up and down layer fluxes for total and clear sky.
16417 ! Vertical ordering is from bottom to top in units of W m-2.
16418 if ( present (lwupflx) ) then
16420 lwupflx(i,k,j) = uflx(icol,k)
16421 lwupflxc(i,k,j) = uflxc(icol,k)
16422 lwdnflx(i,k,j) = dflx(icol,k)
16423 lwdnflxc(i,k,j) = dflxc(icol,k)
16427 ! Output heating rate tendency; convert heating rate from K/d to K/s
16428 ! Heating rate arrays are ordered vertically from bottom to top here.
16430 tten1d(k) = hr(icol,k)/86400.
16431 rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j)
16432 tten1d(k) = hrc(icol,k)/86400.
16433 rthratenlwc(i,k,j) = tten1d(k)/pi3d(i,k,j)
16439 !-------------------------------------------------------------------
16441 END SUBROUTINE RRTMG_LWRAD_FAST
16444 !-------------------------------------------------------------------------
16445 SUBROUTINE INIRAD (O3PROF,Plev, kts, kte)
16446 !-------------------------------------------------------------------------
16448 !-------------------------------------------------------------------------
16449 INTEGER, INTENT(IN ) :: kts,kte
16451 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
16453 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
16460 ! COMPUTE OZONE MIXING RATIO DISTRIBUTION
16466 CALL O3DATA(O3PROF, Plev, kts, kte)
16468 END SUBROUTINE INIRAD
16470 !-------------------------------------------------------------------------
16471 SUBROUTINE O3DATA (O3PROF, Plev, kts, kte)
16472 !-------------------------------------------------------------------------
16474 !-------------------------------------------------------------------------
16476 INTEGER, INTENT(IN ) :: kts, kte
16478 REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF
16480 REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev
16485 REAL :: PRLEVH(kts:kte+2),PPWRKH(32), &
16486 O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), &
16487 O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31)
16489 REAL :: PB1, PB2, PT1, PT2
16491 DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, &
16492 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, &
16493 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, &
16494 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, &
16495 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, &
16496 9.856E-6,5.960E-6,5.960E-6/
16498 DATA PPSUM /955.890,850.532,754.599,667.742,589.841, &
16499 519.421,455.480,398.085,347.171,301.735,261.310,225.360, &
16500 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, &
16501 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, &
16502 9.277, 4.660, 2.421, 1.294, 0.647/
16504 DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, &
16505 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, &
16506 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, &
16507 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, &
16508 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, &
16509 9.389E-6,6.135E-6,6.135E-6/
16511 DATA PPWIN /955.747,841.783,740.199,649.538,568.404, &
16512 495.815,431.069,373.464,322.354,277.190,237.635,203.433, &
16513 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, &
16514 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, &
16515 7.583, 3.620, 1.807, 0.938, 0.469/
16522 O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1))
16525 O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* &
16526 (PPSUM(K)-PPWIN(K-1))
16530 O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K))
16538 ! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS
16541 ! Plev is total P at model levels, from bottom to top
16550 PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2.
16555 IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN
16558 PB1=PRLEVH(K)-PPWRKH(JJ)
16560 IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN
16563 PB2=PRLEVH(K)-PPWRKH(JJ+1)
16565 IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN
16568 PT1=PRLEVH(K+1)-PPWRKH(JJ)
16570 IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN
16573 PT2=PRLEVH(K+1)-PPWRKH(JJ+1)
16575 O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ)
16577 O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1))
16581 END SUBROUTINE O3DATA
16583 !------------------------------------------------------------------
16585 !====================================================================
16586 SUBROUTINE rrtmg_lwinit_fast( &
16587 p_top, allowed_to_read , &
16588 ids, ide, jds, jde, kds, kde, &
16589 ims, ime, jms, jme, kms, kme, &
16590 its, ite, jts, jte, kts, kte )
16591 !--------------------------------------------------------------------
16593 !--------------------------------------------------------------------
16595 LOGICAL , INTENT(IN) :: allowed_to_read
16596 INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, &
16597 ims, ime, jms, jme, kms, kme, &
16598 its, ite, jts, jte, kts, kte
16599 REAL, INTENT(IN) :: p_top
16601 ! Steven Cavallo. Added for buffer layer adjustment. December 2010.
16602 NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels.
16603 ! nlayers will subsequently
16606 ! Read in absorption coefficients and other data
16607 IF ( allowed_to_read ) THEN
16608 CALL rrtmg_lwlookuptable
16611 ! Perform g-point reduction and other initializations
16612 ! Specific heat of dry air (cp) used in flux to heating rate conversion factor.
16613 call rrtmg_lw_ini(cp)
16615 END SUBROUTINE rrtmg_lwinit_fast
16618 ! **************************************************************************
16619 SUBROUTINE rrtmg_lwlookuptable
16620 ! **************************************************************************
16627 LOGICAL , EXTERNAL :: wrf_dm_on_monitor
16629 CHARACTER*80 errmess
16632 IF ( wrf_dm_on_monitor() ) THEN
16634 INQUIRE ( i , OPENED = opened )
16635 IF ( .NOT. opened ) THEN
16643 CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE )
16644 IF ( rrtmg_unit < 0 ) THEN
16645 CALL wrf_error_fatal ( 'module_ra_rrtmg_lwf: rrtm_lwlookuptable: Can not '// &
16646 'find unused fortran unit to read in lookup table.' )
16649 IF ( wrf_dm_on_monitor() ) THEN
16650 OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA', &
16651 FORM='UNFORMATTED',STATUS='OLD',ERR=9009)
16654 call lw_kgb01(rrtmg_unit)
16655 call lw_kgb02(rrtmg_unit)
16656 call lw_kgb03(rrtmg_unit)
16657 call lw_kgb04(rrtmg_unit)
16658 call lw_kgb05(rrtmg_unit)
16659 call lw_kgb06(rrtmg_unit)
16660 call lw_kgb07(rrtmg_unit)
16661 call lw_kgb08(rrtmg_unit)
16662 call lw_kgb09(rrtmg_unit)
16663 call lw_kgb10(rrtmg_unit)
16664 call lw_kgb11(rrtmg_unit)
16665 call lw_kgb12(rrtmg_unit)
16666 call lw_kgb13(rrtmg_unit)
16667 call lw_kgb14(rrtmg_unit)
16668 call lw_kgb15(rrtmg_unit)
16669 call lw_kgb16(rrtmg_unit)
16671 IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit)
16675 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error opening RRTMG_LW_DATA on unit ',rrtmg_unit
16676 CALL wrf_error_fatal(errmess)
16678 END SUBROUTINE rrtmg_lwlookuptable
16680 ! **************************************************************************
16681 ! RRTMG Longwave Radiative Transfer Model
16682 ! Atmospheric and Environmental Research, Inc., Cambridge, MA
16684 ! Original version: E. J. Mlawer, et al.
16685 ! Revision for GCMs: Michael J. Iacono; October, 2002
16686 ! Revision for F90 formatting: Michael J. Iacono; June 2006
16688 ! This file contains 16 READ statements that include the
16689 ! absorption coefficients and other data for each of the 16 longwave
16690 ! spectral bands used in RRTMG_LW. Here, the data are defined for 16
16691 ! g-points, or sub-intervals, per band. These data are combined and
16692 ! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce
16693 ! the total number of g-points from 256 to 140 for use in the GCM.
16694 ! **************************************************************************
16696 ! **************************************************************************
16697 subroutine lw_kgb01(rrtmg_unit)
16698 ! **************************************************************************
16700 use rrlw_kg01_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, &
16708 integer, intent(in) :: rrtmg_unit
16711 character*80 errmess
16712 logical, external :: wrf_dm_on_monitor
16714 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
16715 ! and upper atmosphere.
16716 ! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K
16718 ! The array KAO contains absorption coefs at the 16 chosen g-values
16719 ! for a range of pressure levels > ~100mb and temperatures. The first
16720 ! index in the array, JT, which runs from 1 to 5, corresponds to
16721 ! different temperatures. More specifically, JT = 3 means that the
16722 ! data are for the corresponding TREF for this pressure level,
16723 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
16724 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
16725 ! index, JP, runs from 1 to 13 and refers to the corresponding
16726 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
16727 ! The third index, IG, goes from 1 to 16, and tells us which
16728 ! g-interval the absorption coefficients are for.
16730 ! The array KBO contains absorption coefs at the 16 chosen g-values
16731 ! for a range of pressure levels < ~100mb and temperatures. The first
16732 ! index in the array, JT, which runs from 1 to 5, corresponds to
16733 ! different temperatures. More specifically, JT = 3 means that the
16734 ! data are for the reference temperature TREF for this pressure
16735 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
16736 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
16737 ! The second index, JP, runs from 13 to 59 and refers to the JPth
16738 ! reference pressure level (see taumol.f for the value of these
16739 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
16740 ! and tells us which g-interval the absorption coefficients are for.
16742 ! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the
16743 ! nitrogen continuum for the upper and lower atmosphere.
16744 ! Minor gas mapping levels:
16745 ! Lower - n2: P = 142.5490 mbar, T = 215.70 K
16746 ! Upper - n2: P = 142.5490 mbar, T = 215.70 K
16748 ! The array FORREFO contains the coefficient of the water vapor
16749 ! foreign-continuum (including the energy term). The first
16750 ! index refers to reference temperature (296,260,224,260) and
16751 ! pressure (970,475,219,3 mbar) levels. The second index
16752 ! runs over the g-channel (1 to 16).
16754 ! The array SELFREFO contains the coefficient of the water vapor
16755 ! self-continuum (including the energy term). The first index
16756 ! refers to temperature in 7.2 degree increments. For instance,
16757 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
16758 ! etc. The second index runs over the g-channel (1 to 16).
16760 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
16762 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
16763 fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo
16764 DM_BCAST_MACRO(fracrefao)
16765 DM_BCAST_MACRO(fracrefbo)
16766 DM_BCAST_MACRO(kao)
16767 DM_BCAST_MACRO(kbo)
16768 DM_BCAST_MACRO(kao_mn2)
16769 DM_BCAST_MACRO(kbo_mn2)
16770 DM_BCAST_MACRO(selfrefo)
16771 DM_BCAST_MACRO(forrefo)
16775 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
16776 CALL wrf_error_fatal(errmess)
16778 end subroutine lw_kgb01
16780 ! **************************************************************************
16781 subroutine lw_kgb02(rrtmg_unit)
16782 ! **************************************************************************
16784 use rrlw_kg02_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
16790 integer, intent(in) :: rrtmg_unit
16793 character*80 errmess
16794 logical, external :: wrf_dm_on_monitor
16796 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
16797 ! and upper atmosphere.
16798 ! Planck fraction mapping levels:
16799 ! Lower: P = 1053.630 mbar, T = 294.2 K
16800 ! Upper: P = 3.206e-2 mb, T = 197.92 K
16802 ! The array KAO contains absorption coefs at the 16 chosen g-values
16803 ! for a range of pressure levels > ~100mb and temperatures. The first
16804 ! index in the array, JT, which runs from 1 to 5, corresponds to
16805 ! different temperatures. More specifically, JT = 3 means that the
16806 ! data are for the corresponding TREF for this pressure level,
16807 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
16808 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
16809 ! index, JP, runs from 1 to 13 and refers to the corresponding
16810 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
16811 ! The third index, IG, goes from 1 to 16, and tells us which
16812 ! g-interval the absorption coefficients are for.
16814 ! The array KBO contains absorption coefs at the 16 chosen g-values
16815 ! for a range of pressure levels < ~100mb and temperatures. The first
16816 ! index in the array, JT, which runs from 1 to 5, corresponds to
16817 ! different temperatures. More specifically, JT = 3 means that the
16818 ! data are for the reference temperature TREF for this pressure
16819 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
16820 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
16821 ! The second index, JP, runs from 13 to 59 and refers to the JPth
16822 ! reference pressure level (see taumol.f for the value of these
16823 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
16824 ! and tells us which g-interval the absorption coefficients are for.
16826 ! The array FORREFO contains the coefficient of the water vapor
16827 ! foreign-continuum (including the energy term). The first
16828 ! index refers to reference temperature (296,260,224,260) and
16829 ! pressure (970,475,219,3 mbar) levels. The second index
16830 ! runs over the g-channel (1 to 16).
16832 ! The array SELFREFO contains the coefficient of the water vapor
16833 ! self-continuum (including the energy term). The first index
16834 ! refers to temperature in 7.2 degree increments. For instance,
16835 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
16836 ! etc. The second index runs over the g-channel (1 to 16).
16838 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
16840 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
16841 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
16842 DM_BCAST_MACRO(fracrefao)
16843 DM_BCAST_MACRO(fracrefbo)
16844 DM_BCAST_MACRO(kao)
16845 DM_BCAST_MACRO(kbo)
16846 DM_BCAST_MACRO(selfrefo)
16847 DM_BCAST_MACRO(forrefo)
16851 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
16852 CALL wrf_error_fatal(errmess)
16854 end subroutine lw_kgb02
16856 ! **************************************************************************
16857 subroutine lw_kgb03(rrtmg_unit)
16858 ! **************************************************************************
16860 use rrlw_kg03_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
16861 kbo_mn2o, selfrefo, forrefo
16867 integer, intent(in) :: rrtmg_unit
16870 character*80 errmess
16871 logical, external :: wrf_dm_on_monitor
16873 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
16874 ! and upper atmosphere.
16875 ! Planck fraction mapping levels:
16876 ! Lower: P = 212.7250 mbar, T = 223.06 K
16877 ! Upper: P = 95.8 mbar, T = 215.7 k
16879 ! The array KAO contains absorption coefs for each of the 16 g-intervals
16880 ! for a range of pressure levels > ~100mb, temperatures, and ratios
16881 ! of water vapor to CO2. The first index in the array, JS, runs
16882 ! from 1 to 10, and corresponds to different gas column amount ratios,
16883 ! as expressed through the binary species parameter eta, defined as
16884 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
16885 ! ratio of the reference MLS column amount value of gas 1
16887 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
16888 ! to different temperatures. More specifically, JT = 3 means that the
16889 ! data are for the reference temperature TREF for this pressure
16890 ! level, JT = 2 refers to the temperature
16891 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
16892 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
16893 ! to the reference pressure level (e.g. JP = 1 is for a
16894 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
16895 ! and tells us which g-interval the absorption coefficients are for.
16897 ! The array KBO contains absorption coefs at the 16 chosen g-values
16898 ! for a range of pressure levels < ~100mb and temperatures. The first
16899 ! index in the array, JT, which runs from 1 to 5, corresponds to
16900 ! different temperatures. More specifically, JT = 3 means that the
16901 ! data are for the reference temperature TREF for this pressure
16902 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
16903 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
16904 ! The second index, JP, runs from 13 to 59 and refers to the JPth
16905 ! reference pressure level (see taumol.f for the value of these
16906 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
16907 ! and tells us which g-interval the absorption coefficients are for.
16908 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
16909 ! to different temperatures. More specifically, JT = 3 means that the
16910 ! data are for the reference temperature TREF for this pressure
16911 ! level, JT = 2 refers to the temperature
16912 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
16913 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
16914 ! to the reference pressure level (e.g. JP = 1 is for a
16915 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
16916 ! and tells us which g-interval the absorption coefficients are for.
16918 ! The array KAO_Mxx contains the absorption coefficient for
16919 ! a minor species at the 16 chosen g-values for a reference pressure
16920 ! level below 100~ mb. The first index in the array, JS, runs
16921 ! from 1 to 10, and corresponds to different gas column amount ratios,
16922 ! as expressed through the binary species parameter eta, defined as
16923 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
16924 ! ratio of the reference MLS column amount value of gas 1
16925 ! to that of gas2. The second index refers to temperature
16926 ! in 7.2 degree increments. For instance, JT = 1 refers to a
16927 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
16928 ! runs over the g-channel (1 to 16).
16930 ! The array KBO_Mxx contains the absorption coefficient for
16931 ! a minor species at the 16 chosen g-values for a reference pressure
16932 ! level above 100~ mb. The first index in the array, JS, runs
16933 ! from 1 to 10, and corresponds to different gas column amounts ratios,
16934 ! as expressed through the binary species parameter eta, defined as
16935 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
16936 ! ratio of the reference MLS column amount value of gas 1 to
16937 ! that of gas2. The second index refers to temperature
16938 ! in 7.2 degree increments. For instance, JT = 1 refers to a
16939 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
16940 ! runs over the g-channel (1 to 16).
16942 ! The array FORREFO contains the coefficient of the water vapor
16943 ! foreign-continuum (including the energy term). The first
16944 ! index refers to reference temperature (296,260,224,260) and
16945 ! pressure (970,475,219,3 mbar) levels. The second index
16946 ! runs over the g-channel (1 to 16).
16948 ! The array SELFREFO contains the coefficient of the water vapor
16949 ! self-continuum (including the energy term). The first index
16950 ! refers to temperature in 7.2 degree increments. For instance,
16951 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
16952 ! etc. The second index runs over the g-channel (1 to 16).
16954 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
16956 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
16957 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
16958 DM_BCAST_MACRO(fracrefao)
16959 DM_BCAST_MACRO(fracrefbo)
16960 DM_BCAST_MACRO(kao)
16961 DM_BCAST_MACRO(kbo)
16962 DM_BCAST_MACRO(kao_mn2o)
16963 DM_BCAST_MACRO(kbo_mn2o)
16964 DM_BCAST_MACRO(selfrefo)
16965 DM_BCAST_MACRO(forrefo)
16969 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
16970 CALL wrf_error_fatal(errmess)
16972 end subroutine lw_kgb03
16974 ! **************************************************************************
16975 subroutine lw_kgb04(rrtmg_unit)
16976 ! **************************************************************************
16978 use rrlw_kg04_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
16984 integer, intent(in) :: rrtmg_unit
16987 character*80 errmess
16988 logical, external :: wrf_dm_on_monitor
16990 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
16991 ! and upper atmosphere.
16992 ! Planck fraction mapping levels:
16993 ! Lower : P = 142.5940 mbar, T = 215.70 K
16994 ! Upper : P = 95.58350 mb, T = 215.70 K
16996 ! The array KAO contains absorption coefs for each of the 16 g-intervals
16997 ! for a range of pressure levels > ~100mb, temperatures, and ratios
16998 ! of water vapor to CO2. The first index in the array, JS, runs
16999 ! from 1 to 10, and corresponds to different gas column amount ratios,
17000 ! as expressed through the binary species parameter eta, defined as
17001 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17002 ! ratio of the reference MLS column amount value of gas 1
17004 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17005 ! to different temperatures. More specifically, JT = 3 means that the
17006 ! data are for the reference temperature TREF for this pressure
17007 ! level, JT = 2 refers to the temperature
17008 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17009 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17010 ! to the reference pressure level (e.g. JP = 1 is for a
17011 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17012 ! and tells us which g-interval the absorption coefficients are for.
17014 ! The array KBO contains absorption coefs for each of the 16 g-intervals
17015 ! for a range of pressure levels < ~100mb, temperatures, and ratios
17016 ! of H2O to CO2. The first index in the array, JS, runs
17017 ! from 1 to 10, and corresponds to different gas column amount ratios,
17018 ! as expressed through the binary species parameter eta, defined as
17019 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17020 ! ratio of the reference MLS column amount value of gas 1
17021 ! to that of gas2. The second index, JT, which
17022 ! runs from 1 to 5, corresponds to different temperatures. More
17023 ! specifically, JT = 3 means that the data are for the corresponding
17024 ! reference temperature TREF for this pressure level, JT = 2 refers
17025 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
17026 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
17027 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
17028 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
17029 ! 16, and tells us which g-interval the absorption coefficients are for.
17031 ! The array FORREFO contains the coefficient of the water vapor
17032 ! foreign-continuum (including the energy term). The first
17033 ! index refers to reference temperature (296,260,224,260) and
17034 ! pressure (970,475,219,3 mbar) levels. The second index
17035 ! runs over the g-channel (1 to 16).
17037 ! The array SELFREFO contains the coefficient of the water vapor
17038 ! self-continuum (including the energy term). The first index
17039 ! refers to temperature in 7.2 degree increments. For instance,
17040 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17041 ! etc. The second index runs over the g-channel (1 to 16).
17043 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17045 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17046 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
17047 DM_BCAST_MACRO(fracrefao)
17048 DM_BCAST_MACRO(fracrefbo)
17049 DM_BCAST_MACRO(kao)
17050 DM_BCAST_MACRO(kbo)
17051 DM_BCAST_MACRO(selfrefo)
17052 DM_BCAST_MACRO(forrefo)
17056 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17057 CALL wrf_error_fatal(errmess)
17059 end subroutine lw_kgb04
17061 ! **************************************************************************
17062 subroutine lw_kgb05(rrtmg_unit)
17063 ! **************************************************************************
17065 use rrlw_kg05_f, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, &
17066 selfrefo, forrefo, ccl4o
17072 integer, intent(in) :: rrtmg_unit
17075 character*80 errmess
17076 logical, external :: wrf_dm_on_monitor
17078 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17079 ! and upper atmosphere.
17080 ! Planck fraction mapping levels:
17081 ! Lower: P = 473.42 mb, T = 259.83
17082 ! Upper: P = 0.2369280 mbar, T = 253.60 K
17084 ! The arrays kao_mo3 and ccl4o contain the coefficients for
17085 ! ozone and ccl4 in the lower atmosphere.
17086 ! Minor gas mapping level:
17087 ! Lower - o3: P = 317.34 mbar, T = 240.77 k
17090 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17091 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17092 ! of water vapor to CO2. The first index in the array, JS, runs
17093 ! from 1 to 10, and corresponds to different gas column amount ratios,
17094 ! as expressed through the binary species parameter eta, defined as
17095 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17096 ! ratio of the reference MLS column amount value of gas 1
17098 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17099 ! to different temperatures. More specifically, JT = 3 means that the
17100 ! data are for the reference temperature TREF for this pressure
17101 ! level, JT = 2 refers to the temperature
17102 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17103 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17104 ! to the reference pressure level (e.g. JP = 1 is for a
17105 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17106 ! and tells us which g-interval the absorption coefficients are for.
17108 ! The array KBO contains absorption coefs for each of the 16 g-intervals
17109 ! for a range of pressure levels < ~100mb, temperatures, and ratios
17110 ! of H2O to CO2. The first index in the array, JS, runs
17111 ! from 1 to 10, and corresponds to different gas column amount ratios,
17112 ! as expressed through the binary species parameter eta, defined as
17113 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17114 ! ratio of the reference MLS column amount value of gas 1
17115 ! to that of gas2. The second index, JT, which
17116 ! runs from 1 to 5, corresponds to different temperatures. More
17117 ! specifically, JT = 3 means that the data are for the corresponding
17118 ! reference temperature TREF for this pressure level, JT = 2 refers
17119 ! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and
17120 ! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and
17121 ! refers to the corresponding pressure level in PREF (e.g. JP = 13 is
17122 ! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to
17123 ! 16, and tells us which g-interval the absorption coefficients are for.
17125 ! The array KAO_Mxx contains the absorption coefficient for
17126 ! a minor species at the 16 chosen g-values for a reference pressure
17127 ! level below 100~ mb. The first index in the array, JS, runs
17128 ! from 1 to 10, and corresponds to different gas column amount ratios,
17129 ! as expressed through the binary species parameter eta, defined as
17130 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17131 ! ratio of the reference MLS column amount value of gas 1
17132 ! to that of gas2. The second index refers to temperature
17133 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17134 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
17135 ! runs over the g-channel (1 to 16).
17137 ! The array FORREFO contains the coefficient of the water vapor
17138 ! foreign-continuum (including the energy term). The first
17139 ! index refers to reference temperature (296,260,224,260) and
17140 ! pressure (970,475,219,3 mbar) levels. The second index
17141 ! runs over the g-channel (1 to 16).
17143 ! The array SELFREFO contains the coefficient of the water vapor
17144 ! self-continuum (including the energy term). The first index
17145 ! refers to temperature in 7.2 degree increments. For instance,
17146 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17147 ! etc. The second index runs over the g-channel (1 to 16).
17149 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17151 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17152 fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo
17153 DM_BCAST_MACRO(fracrefao)
17154 DM_BCAST_MACRO(fracrefbo)
17155 DM_BCAST_MACRO(kao)
17156 DM_BCAST_MACRO(kbo)
17157 DM_BCAST_MACRO(kao_mo3)
17158 DM_BCAST_MACRO(ccl4o)
17159 DM_BCAST_MACRO(selfrefo)
17160 DM_BCAST_MACRO(forrefo)
17164 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17165 CALL wrf_error_fatal(errmess)
17167 end subroutine lw_kgb05
17169 ! **************************************************************************
17170 subroutine lw_kgb06(rrtmg_unit)
17171 ! **************************************************************************
17173 use rrlw_kg06_f, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, &
17180 integer, intent(in) :: rrtmg_unit
17183 character*80 errmess
17184 logical, external :: wrf_dm_on_monitor
17186 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17187 ! and upper atmosphere.
17188 ! Planck fraction mapping levels:
17189 ! Lower: : P = 473.4280 mb, T = 259.83 K
17191 ! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for
17192 ! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper
17194 ! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band.
17195 ! Minor gas mapping level:
17196 ! Lower - co2: P = 706.2720 mb, T = 294.2 k
17197 ! Upper - cfc11, cfc12
17199 ! The array KAO contains absorption coefs at the 16 chosen g-values
17200 ! for a range of pressure levels > ~100mb and temperatures. The first
17201 ! index in the array, JT, which runs from 1 to 5, corresponds to
17202 ! different temperatures. More specifically, JT = 3 means that the
17203 ! data are for the corresponding TREF for this pressure level,
17204 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
17205 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
17206 ! index, JP, runs from 1 to 13 and refers to the corresponding
17207 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
17208 ! The third index, IG, goes from 1 to 16, and tells us which
17209 ! g-interval the absorption coefficients are for.
17211 ! The array KAO_Mxx contains the absorption coefficient for
17212 ! a minor species at the 16 chosen g-values for a reference pressure
17213 ! level below 100~ mb. The first index refers to temperature
17214 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17215 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17216 ! runs over the g-channel (1 to 16).
17218 ! The array FORREFO contains the coefficient of the water vapor
17219 ! foreign-continuum (including the energy term). The first
17220 ! index refers to reference temperature (296,260,224,260) and
17221 ! pressure (970,475,219,3 mbar) levels. The second index
17222 ! runs over the g-channel (1 to 16).
17224 ! The array SELFREFO contains the coefficient of the water vapor
17225 ! self-continuum (including the energy term). The first index
17226 ! refers to temperature in 7.2 degree increments. For instance,
17227 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17228 ! etc. The second index runs over the g-channel (1 to 16).
17230 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17232 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17233 fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo
17234 DM_BCAST_MACRO(fracrefao)
17235 DM_BCAST_MACRO(kao)
17236 DM_BCAST_MACRO(kao_mco2)
17237 DM_BCAST_MACRO(cfc11adjo)
17238 DM_BCAST_MACRO(cfc12o)
17239 DM_BCAST_MACRO(selfrefo)
17240 DM_BCAST_MACRO(forrefo)
17244 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17245 CALL wrf_error_fatal(errmess)
17247 end subroutine lw_kgb06
17249 ! **************************************************************************
17250 subroutine lw_kgb07(rrtmg_unit)
17251 ! **************************************************************************
17253 use rrlw_kg07_f, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, &
17254 kbo_mco2, selfrefo, forrefo
17260 integer, intent(in) :: rrtmg_unit
17263 character*80 errmess
17264 logical, external :: wrf_dm_on_monitor
17266 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17267 ! and upper atmosphere.
17268 ! Planck fraction mapping levels:
17269 ! Lower : P = 706.27 mb, T = 278.94 K
17270 ! Upper : P = 95.58 mbar, T= 215.70 K
17272 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17273 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17274 ! of water vapor to CO2. The first index in the array, JS, runs
17275 ! from 1 to 10, and corresponds to different gas column amount ratios,
17276 ! as expressed through the binary species parameter eta, defined as
17277 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17278 ! ratio of the reference MLS column amount value of gas 1
17280 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17281 ! to different temperatures. More specifically, JT = 3 means that the
17282 ! data are for the reference temperature TREF for this pressure
17283 ! level, JT = 2 refers to the temperature
17284 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17285 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17286 ! to the reference pressure level (e.g. JP = 1 is for a
17287 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17288 ! and tells us which g-interval the absorption coefficients are for.
17290 ! The array KBO contains absorption coefs at the 16 chosen g-values
17291 ! for a range of pressure levels < ~100mb and temperatures. The first
17292 ! index in the array, JT, which runs from 1 to 5, corresponds to
17293 ! different temperatures. More specifically, JT = 3 means that the
17294 ! data are for the reference temperature TREF for this pressure
17295 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17296 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17297 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17298 ! reference pressure level (see taumol.f for the value of these
17299 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17300 ! and tells us which g-interval the absorption coefficients are for.
17302 ! The array KAO_Mxx contains the absorption coefficient for
17303 ! a minor species at the 16 chosen g-values for a reference pressure
17304 ! level below 100~ mb. The first index in the array, JS, runs
17305 ! from 1 to 10, and corresponds to different gas column amount ratios,
17306 ! as expressed through the binary species parameter eta, defined as
17307 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17308 ! ratio of the reference MLS column amount value of gas 1
17309 ! to that of gas2. The second index refers to temperature
17310 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17311 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
17312 ! runs over the g-channel (1 to 16).
17314 ! The array KBO_Mxx contains the absorption coefficient for
17315 ! a minor species at the 16 chosen g-values for a reference pressure
17316 ! level above 100~ mb. The first index refers to temperature
17317 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17318 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17319 ! runs over the g-channel (1 to 16).
17321 ! The array FORREFO contains the coefficient of the water vapor
17322 ! foreign-continuum (including the energy term). The first
17323 ! index refers to reference temperature (296_rb,260_rb,224,260) and
17324 ! pressure (970,475,219,3 mbar) levels. The second index
17325 ! runs over the g-channel (1 to 16).
17327 ! The array SELFREFO contains the coefficient of the water vapor
17328 ! self-continuum (including the energy term). The first index
17329 ! refers to temperature in 7.2 degree increments. For instance,
17330 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17331 ! etc. The second index runs over the g-channel (1 to 16).
17333 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17335 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17336 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo
17337 DM_BCAST_MACRO(fracrefao)
17338 DM_BCAST_MACRO(fracrefbo)
17339 DM_BCAST_MACRO(kao)
17340 DM_BCAST_MACRO(kbo)
17341 DM_BCAST_MACRO(kao_mco2)
17342 DM_BCAST_MACRO(kbo_mco2)
17343 DM_BCAST_MACRO(selfrefo)
17344 DM_BCAST_MACRO(forrefo)
17348 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17349 CALL wrf_error_fatal(errmess)
17351 end subroutine lw_kgb07
17353 ! **************************************************************************
17354 subroutine lw_kgb08(rrtmg_unit)
17355 ! **************************************************************************
17357 use rrlw_kg08_f, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, &
17358 kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, &
17365 integer, intent(in) :: rrtmg_unit
17368 character*80 errmess
17369 logical, external :: wrf_dm_on_monitor
17371 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17372 ! and upper atmosphere.
17373 ! Planck fraction mapping levels:
17374 ! Lower: P=473.4280 mb, T = 259.83 K
17375 ! Upper: P=95.5835 mb, T= 215.7 K
17377 ! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for
17378 ! carbon dioxide and n2o in the lower and upper atmosphere.
17379 ! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere,
17380 ! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22.
17381 ! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1
17382 ! and 1290-1335 cm-1 bands.
17383 ! Minor gas mapping level:
17384 ! Lower - co2: P = 1053.63 mb, T = 294.2 k
17385 ! Lower - o3: P = 317.348 mb, T = 240.77 k
17386 ! Lower - n2o: P = 706.2720 mb, T= 278.94 k
17387 ! Lower - cfc12, cfc22
17388 ! Upper - co2: P = 35.1632 mb, T = 223.28 k
17389 ! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k
17391 ! The array KAO contains absorption coefs at the 16 chosen g-values
17392 ! for a range of pressure levels > ~100mb and temperatures. The first
17393 ! index in the array, JT, which runs from 1 to 5, corresponds to
17394 ! different temperatures. More specifically, JT = 3 means that the
17395 ! data are for the corresponding TREF for this pressure level,
17396 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
17397 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
17398 ! index, JP, runs from 1 to 13 and refers to the corresponding
17399 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
17400 ! The third index, IG, goes from 1 to 16, and tells us which
17401 ! g-interval the absorption coefficients are for.
17403 ! The array KBO contains absorption coefs at the 16 chosen g-values
17404 ! for a range of pressure levels < ~100mb and temperatures. The first
17405 ! index in the array, JT, which runs from 1 to 5, corresponds to
17406 ! different temperatures. More specifically, JT = 3 means that the
17407 ! data are for the reference temperature TREF for this pressure
17408 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17409 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17410 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17411 ! reference pressure level (see taumol.f for the value of these
17412 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17413 ! and tells us which g-interval the absorption coefficients are for.
17415 ! The array KAO_Mxx contains the absorption coefficient for
17416 ! a minor species at the 16 chosen g-values for a reference pressure
17417 ! level below 100~ mb. The first index refers to temperature
17418 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17419 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17420 ! runs over the g-channel (1 to 16).
17422 ! The array KBO_Mxx contains the absorption coefficient for
17423 ! a minor species at the 16 chosen g-values for a reference pressure
17424 ! level above 100~ mb. The first index refers to temperature
17425 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17426 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17427 ! runs over the g-channel (1 to 16).
17429 ! The array FORREFO contains the coefficient of the water vapor
17430 ! foreign-continuum (including the energy term). The first
17431 ! index refers to reference temperature (296,260,224,260) and
17432 ! pressure (970,475,219,3 mbar) levels. The second index
17433 ! runs over the g-channel (1 to 16).
17435 ! The array SELFREFO contains the coefficient of the water vapor
17436 ! self-continuum (including the energy term). The first index
17437 ! refers to temperature in 7.2 degree increments. For instance,
17438 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17439 ! etc. The second index runs over the g-channel (1 to 16).
17441 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17443 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17444 fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, &
17445 kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo
17446 DM_BCAST_MACRO(fracrefao)
17447 DM_BCAST_MACRO(fracrefbo)
17448 DM_BCAST_MACRO(kao)
17449 DM_BCAST_MACRO(kbo)
17450 DM_BCAST_MACRO(kao_mco2)
17451 DM_BCAST_MACRO(kbo_mco2)
17452 DM_BCAST_MACRO(kao_mn2o)
17453 DM_BCAST_MACRO(kbo_mn2o)
17454 DM_BCAST_MACRO(kao_mo3)
17455 DM_BCAST_MACRO(cfc12o)
17456 DM_BCAST_MACRO(cfc22adjo)
17457 DM_BCAST_MACRO(selfrefo)
17458 DM_BCAST_MACRO(forrefo)
17462 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17463 CALL wrf_error_fatal(errmess)
17465 end subroutine lw_kgb08
17467 ! **************************************************************************
17468 subroutine lw_kgb09(rrtmg_unit)
17469 ! **************************************************************************
17471 use rrlw_kg09_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, &
17472 kbo_mn2o, selfrefo, forrefo
17478 integer, intent(in) :: rrtmg_unit
17481 character*80 errmess
17482 logical, external :: wrf_dm_on_monitor
17484 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17485 ! and upper atmosphere.
17486 ! Planck fraction mapping levels:
17487 ! Lower: P=212.7250 mb, T = 223.06 K
17488 ! Upper: P=3.20e-2 mb, T = 197.92 k
17490 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17491 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17492 ! of water vapor to CO2. The first index in the array, JS, runs
17493 ! from 1 to 10, and corresponds to different gas column amount ratios,
17494 ! as expressed through the binary species parameter eta, defined as
17495 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17496 ! ratio of the reference MLS column amount value of gas 1
17498 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17499 ! to different temperatures. More specifically, JT = 3 means that the
17500 ! data are for the reference temperature TREF for this pressure
17501 ! level, JT = 2 refers to the temperature
17502 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17503 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17504 ! to the reference pressure level (e.g. JP = 1 is for a
17505 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17506 ! and tells us which g-interval the absorption coefficients are for.
17508 ! The array KBO contains absorption coefs at the 16 chosen g-values
17509 ! for a range of pressure levels < ~100mb and temperatures. The first
17510 ! index in the array, JT, which runs from 1 to 5, corresponds to
17511 ! different temperatures. More specifically, JT = 3 means that the
17512 ! data are for the reference temperature TREF for this pressure
17513 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17514 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17515 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17516 ! reference pressure level (see taumol.f for the value of these
17517 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17518 ! and tells us which g-interval the absorption coefficients are for.
17520 ! The array KAO_Mxx contains the absorption coefficient for
17521 ! a minor species at the 16 chosen g-values for a reference pressure
17522 ! level below 100~ mb. The first index in the array, JS, runs
17523 ! from 1 to 10, and corresponds to different gas column amount ratios,
17524 ! as expressed through the binary species parameter eta, defined as
17525 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17526 ! ratio of the reference MLS column amount value of gas 1
17527 ! to that of gas2. The second index refers to temperature
17528 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17529 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
17530 ! runs over the g-channel (1 to 16).
17532 ! The array KBO_Mxx contains the absorption coefficient for
17533 ! a minor species at the 16 chosen g-values for a reference pressure
17534 ! level above 100~ mb. The first index refers to temperature
17535 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17536 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17537 ! runs over the g-channel (1 to 16).
17539 ! The array FORREFO contains the coefficient of the water vapor
17540 ! foreign-continuum (including the energy term). The first
17541 ! index refers to reference temperature (296,260,224,260) and
17542 ! pressure (970,475,219,3 mbar) levels. The second index
17543 ! runs over the g-channel (1 to 16).
17545 ! The array SELFREFO contains the coefficient of the water vapor
17546 ! self-continuum (including the energy term). The first index
17547 ! refers to temperature in 7.2 degree increments. For instance,
17548 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17549 ! etc. The second index runs over the g-channel (1 to 16).
17551 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17553 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17554 fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo
17555 DM_BCAST_MACRO(fracrefao)
17556 DM_BCAST_MACRO(fracrefbo)
17557 DM_BCAST_MACRO(kao)
17558 DM_BCAST_MACRO(kbo)
17559 DM_BCAST_MACRO(kao_mn2o)
17560 DM_BCAST_MACRO(kbo_mn2o)
17561 DM_BCAST_MACRO(selfrefo)
17562 DM_BCAST_MACRO(forrefo)
17566 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17567 CALL wrf_error_fatal(errmess)
17569 end subroutine lw_kgb09
17571 ! **************************************************************************
17572 subroutine lw_kgb10(rrtmg_unit)
17573 ! **************************************************************************
17575 use rrlw_kg10_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
17581 integer, intent(in) :: rrtmg_unit
17584 character*80 errmess
17585 logical, external :: wrf_dm_on_monitor
17587 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17588 ! and upper atmosphere.
17589 ! Planck fraction mapping levels:
17590 ! Lower: P = 212.7250 mb, T = 223.06 K
17591 ! Upper: P = 95.58350 mb, T = 215.70 K
17593 ! The array KAO contains absorption coefs at the 16 chosen g-values
17594 ! for a range of pressure levels > ~100mb and temperatures. The first
17595 ! index in the array, JT, which runs from 1 to 5, corresponds to
17596 ! different temperatures. More specifically, JT = 3 means that the
17597 ! data are for the corresponding TREF for this pressure level,
17598 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
17599 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
17600 ! index, JP, runs from 1 to 13 and refers to the corresponding
17601 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
17602 ! The third index, IG, goes from 1 to 16, and tells us which
17603 ! g-interval the absorption coefficients are for.
17605 ! The array KBO contains absorption coefs at the 16 chosen g-values
17606 ! for a range of pressure levels < ~100mb and temperatures. The first
17607 ! index in the array, JT, which runs from 1 to 5, corresponds to
17608 ! different temperatures. More specifically, JT = 3 means that the
17609 ! data are for the reference temperature TREF for this pressure
17610 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17611 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17612 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17613 ! reference pressure level (see taumol.f for the value of these
17614 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17615 ! and tells us which g-interval the absorption coefficients are for.
17617 ! The array FORREFO contains the coefficient of the water vapor
17618 ! foreign-continuum (including the energy term). The first
17619 ! index refers to reference temperature (296,260,224,260) and
17620 ! pressure (970,475,219,3 mbar) levels. The second index
17621 ! runs over the g-channel (1 to 16).
17623 ! The array SELFREFO contains the coefficient of the water vapor
17624 ! self-continuum (including the energy term). The first index
17625 ! refers to temperature in 7.2 degree increments. For instance,
17626 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17627 ! etc. The second index runs over the g-channel (1 to 16).
17629 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17631 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17632 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
17633 DM_BCAST_MACRO(fracrefao)
17634 DM_BCAST_MACRO(fracrefbo)
17635 DM_BCAST_MACRO(kao)
17636 DM_BCAST_MACRO(kbo)
17637 DM_BCAST_MACRO(selfrefo)
17638 DM_BCAST_MACRO(forrefo)
17642 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17643 CALL wrf_error_fatal(errmess)
17645 end subroutine lw_kgb10
17647 ! **************************************************************************
17648 subroutine lw_kgb11(rrtmg_unit)
17649 ! **************************************************************************
17651 use rrlw_kg11_f, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, &
17652 kbo_mo2, selfrefo, forrefo
17658 integer, intent(in) :: rrtmg_unit
17661 character*80 errmess
17662 logical, external :: wrf_dm_on_monitor
17664 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17665 ! and upper atmosphere.
17666 ! Planck fraction mapping levels:
17667 ! Lower: P=1053.63 mb, T= 294.2 K
17668 ! Upper: P=0.353 mb, T = 262.11 K
17670 ! The array KAO contains absorption coefs at the 16 chosen g-values
17671 ! for a range of pressure levels > ~100mb and temperatures. The first
17672 ! index in the array, JT, which runs from 1 to 5, corresponds to
17673 ! different temperatures. More specifically, JT = 3 means that the
17674 ! data are for the corresponding TREF for this pressure level,
17675 ! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30,
17676 ! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second
17677 ! index, JP, runs from 1 to 13 and refers to the corresponding
17678 ! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb).
17679 ! The third index, IG, goes from 1 to 16, and tells us which
17680 ! g-interval the absorption coefficients are for.
17682 ! The array KBO contains absorption coefs at the 16 chosen g-values
17683 ! for a range of pressure levels < ~100mb and temperatures. The first
17684 ! index in the array, JT, which runs from 1 to 5, corresponds to
17685 ! different temperatures. More specifically, JT = 3 means that the
17686 ! data are for the reference temperature TREF for this pressure
17687 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17688 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17689 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17690 ! reference pressure level (see taumol.f for the value of these
17691 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17692 ! and tells us which g-interval the absorption coefficients are for.
17694 ! The array KAO_Mxx contains the absorption coefficient for
17695 ! a minor species at the 16 chosen g-values for a reference pressure
17696 ! level below 100~ mb. The first index refers to temperature
17697 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17698 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17699 ! runs over the g-channel (1 to 16).
17701 ! The array KBO_Mxx contains the absorption coefficient for
17702 ! a minor species at the 16 chosen g-values for a reference pressure
17703 ! level above 100~ mb. The first index refers to temperature
17704 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17705 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17706 ! runs over the g-channel (1 to 16).
17708 ! The array FORREFO contains the coefficient of the water vapor
17709 ! foreign-continuum (including the energy term). The first
17710 ! index refers to reference temperature (296,260,224,260) and
17711 ! pressure (970,475,219,3 mbar) levels. The second index
17712 ! runs over the g-channel (1 to 16).
17714 ! The array SELFREFO contains the coefficient of the water vapor
17715 ! self-continuum (including the energy term). The first index
17716 ! refers to temperature in 7.2 degree increments. For instance,
17717 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17718 ! etc. The second index runs over the g-channel (1 to 16).
17720 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17722 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17723 fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo
17724 DM_BCAST_MACRO(fracrefao)
17725 DM_BCAST_MACRO(fracrefbo)
17726 DM_BCAST_MACRO(kao)
17727 DM_BCAST_MACRO(kbo)
17728 DM_BCAST_MACRO(kao_mo2)
17729 DM_BCAST_MACRO(kbo_mo2)
17730 DM_BCAST_MACRO(selfrefo)
17731 DM_BCAST_MACRO(forrefo)
17735 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17736 CALL wrf_error_fatal(errmess)
17738 end subroutine lw_kgb11
17740 ! **************************************************************************
17741 subroutine lw_kgb12(rrtmg_unit)
17742 ! **************************************************************************
17744 use rrlw_kg12_f, only : fracrefao, kao, selfrefo, forrefo
17750 integer, intent(in) :: rrtmg_unit
17753 character*80 errmess
17754 logical, external :: wrf_dm_on_monitor
17756 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17757 ! and upper atmosphere.
17758 ! Planck fraction mapping levels:
17759 ! Lower: P = 174.1640 mbar, T= 215.78 K
17761 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17762 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17763 ! of water vapor to CO2. The first index in the array, JS, runs
17764 ! from 1 to 10, and corresponds to different gas column amount ratios,
17765 ! as expressed through the binary species parameter eta, defined as
17766 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17767 ! ratio of the reference MLS column amount value of gas 1
17769 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17770 ! to different temperatures. More specifically, JT = 3 means that the
17771 ! data are for the reference temperature TREF for this pressure
17772 ! level, JT = 2 refers to the temperature
17773 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17774 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17775 ! to the reference pressure level (e.g. JP = 1 is for a
17776 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17777 ! and tells us which g-interval the absorption coefficients are for.
17779 ! The array FORREFO contains the coefficient of the water vapor
17780 ! foreign-continuum (including the energy term). The first
17781 ! index refers to reference temperature (296,260,224,260) and
17782 ! pressure (970,475,219,3 mbar) levels. The second index
17783 ! runs over the g-channel (1 to 16).
17785 ! The array SELFREFO contains the coefficient of the water vapor
17786 ! self-continuum (including the energy term). The first index
17787 ! refers to temperature in 7.2 degree increments. For instance,
17788 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17789 ! etc. The second index runs over the g-channel (1 to 16).
17791 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17793 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17794 fracrefao, kao, selfrefo, forrefo
17795 DM_BCAST_MACRO(fracrefao)
17796 DM_BCAST_MACRO(kao)
17797 DM_BCAST_MACRO(selfrefo)
17798 DM_BCAST_MACRO(forrefo)
17802 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17803 CALL wrf_error_fatal(errmess)
17805 end subroutine lw_kgb12
17807 ! **************************************************************************
17808 subroutine lw_kgb13(rrtmg_unit)
17809 ! **************************************************************************
17811 use rrlw_kg13_f, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, &
17812 kbo_mo3, selfrefo, forrefo
17818 integer, intent(in) :: rrtmg_unit
17821 character*80 errmess
17822 logical, external :: wrf_dm_on_monitor
17824 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17825 ! and upper atmosphere.
17826 ! Planck fraction mapping levels:
17827 ! Lower: P=473.4280 mb, T = 259.83 K
17828 ! Upper: P=4.758820 mb, T = 250.85 K
17830 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17831 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17832 ! of water vapor to CO2. The first index in the array, JS, runs
17833 ! from 1 to 10, and corresponds to different gas column amount ratios,
17834 ! as expressed through the binary species parameter eta, defined as
17835 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17836 ! ratio of the reference MLS column amount value of gas 1
17838 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17839 ! to different temperatures. More specifically, JT = 3 means that the
17840 ! data are for the reference temperature TREF for this pressure
17841 ! level, JT = 2 refers to the temperature
17842 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17843 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17844 ! to the reference pressure level (e.g. JP = 1 is for a
17845 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17846 ! and tells us which g-interval the absorption coefficients are for.
17848 ! The array KAO_Mxx contains the absorption coefficient for
17849 ! a minor species at the 16 chosen g-values for a reference pressure
17850 ! level below 100~ mb. The first index in the array, JS, runs
17851 ! from 1 to 10, and corresponds to different gas column amount ratios,
17852 ! as expressed through the binary species parameter eta, defined as
17853 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17854 ! ratio of the reference MLS column amount value of gas 1
17855 ! to that of gas2. The second index refers to temperature
17856 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17857 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
17858 ! runs over the g-channel (1 to 16).
17860 ! The array KBO_Mxx contains the absorption coefficient for
17861 ! a minor species at the 16 chosen g-values for a reference pressure
17862 ! level above 100~ mb. The first index refers to temperature
17863 ! in 7.2 degree increments. For instance, JT = 1 refers to a
17864 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index
17865 ! runs over the g-channel (1 to 16).
17867 ! The array FORREFO contains the coefficient of the water vapor
17868 ! foreign-continuum (including the energy term). The first
17869 ! index refers to reference temperature (296,260,224,260) and
17870 ! pressure (970,475,219,3 mbar) levels. The second index
17871 ! runs over the g-channel (1 to 16).
17873 ! The array SELFREFO contains the coefficient of the water vapor
17874 ! self-continuum (including the energy term). The first index
17875 ! refers to temperature in 7.2 degree increments. For instance,
17876 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17877 ! etc. The second index runs over the g-channel (1 to 16).
17879 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17881 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17882 fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo
17883 DM_BCAST_MACRO(fracrefao)
17884 DM_BCAST_MACRO(fracrefbo)
17885 DM_BCAST_MACRO(kao)
17886 DM_BCAST_MACRO(kao_mco2)
17887 DM_BCAST_MACRO(kao_mco)
17888 DM_BCAST_MACRO(kbo_mo3)
17889 DM_BCAST_MACRO(selfrefo)
17890 DM_BCAST_MACRO(forrefo)
17894 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17895 CALL wrf_error_fatal(errmess)
17897 end subroutine lw_kgb13
17899 ! **************************************************************************
17900 subroutine lw_kgb14(rrtmg_unit)
17901 ! **************************************************************************
17903 use rrlw_kg14_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
17909 integer, intent(in) :: rrtmg_unit
17912 character*80 errmess
17913 logical, external :: wrf_dm_on_monitor
17915 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17916 ! and upper atmosphere.
17917 ! Planck fraction mapping levels:
17918 ! Lower: P = 142.5940 mb, T = 215.70 K
17919 ! Upper: P = 4.758820 mb, T = 250.85 K
17921 ! The array KAO contains absorption coefs for each of the 16 g-intervals
17922 ! for a range of pressure levels > ~100mb, temperatures, and ratios
17923 ! of water vapor to CO2. The first index in the array, JS, runs
17924 ! from 1 to 10, and corresponds to different gas column amount ratios,
17925 ! as expressed through the binary species parameter eta, defined as
17926 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
17927 ! ratio of the reference MLS column amount value of gas 1
17929 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
17930 ! to different temperatures. More specifically, JT = 3 means that the
17931 ! data are for the reference temperature TREF for this pressure
17932 ! level, JT = 2 refers to the temperature
17933 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
17934 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
17935 ! to the reference pressure level (e.g. JP = 1 is for a
17936 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
17937 ! and tells us which g-interval the absorption coefficients are for.
17939 ! The array KBO contains absorption coefs at the 16 chosen g-values
17940 ! for a range of pressure levels < ~100mb and temperatures. The first
17941 ! index in the array, JT, which runs from 1 to 5, corresponds to
17942 ! different temperatures. More specifically, JT = 3 means that the
17943 ! data are for the reference temperature TREF for this pressure
17944 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
17945 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
17946 ! The second index, JP, runs from 13 to 59 and refers to the JPth
17947 ! reference pressure level (see taumol.f for the value of these
17948 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
17949 ! and tells us which g-interval the absorption coefficients are for.
17951 ! The array FORREFO contains the coefficient of the water vapor
17952 ! foreign-continuum (including the energy term). The first
17953 ! index refers to reference temperature (296,260,224,260) and
17954 ! pressure (970,475,219,3 mbar) levels. The second index
17955 ! runs over the g-channel (1 to 16).
17957 ! The array SELFREFO contains the coefficient of the water vapor
17958 ! self-continuum (including the energy term). The first index
17959 ! refers to temperature in 7.2 degree increments. For instance,
17960 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
17961 ! etc. The second index runs over the g-channel (1 to 16).
17963 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
17965 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
17966 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
17967 DM_BCAST_MACRO(fracrefao)
17968 DM_BCAST_MACRO(fracrefbo)
17969 DM_BCAST_MACRO(kao)
17970 DM_BCAST_MACRO(kbo)
17971 DM_BCAST_MACRO(selfrefo)
17972 DM_BCAST_MACRO(forrefo)
17976 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
17977 CALL wrf_error_fatal(errmess)
17979 end subroutine lw_kgb14
17981 ! **************************************************************************
17982 subroutine lw_kgb15(rrtmg_unit)
17983 ! **************************************************************************
17985 use rrlw_kg15_f, only : fracrefao, kao, kao_mn2, selfrefo, forrefo
17991 integer, intent(in) :: rrtmg_unit
17994 character*80 errmess
17995 logical, external :: wrf_dm_on_monitor
17997 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
17998 ! and upper atmosphere.
17999 ! Planck fraction mapping levels:
18000 ! Lower: P = 1053. mb, T = 294.2 K
18002 ! The array KAO contains absorption coefs for each of the 16 g-intervals
18003 ! for a range of pressure levels > ~100mb, temperatures, and ratios
18004 ! of water vapor to CO2. The first index in the array, JS, runs
18005 ! from 1 to 10, and corresponds to different gas column amount ratios,
18006 ! as expressed through the binary species parameter eta, defined as
18007 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
18008 ! ratio of the reference MLS column amount value of gas 1
18010 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
18011 ! to different temperatures. More specifically, JT = 3 means that the
18012 ! data are for the reference temperature TREF for this pressure
18013 ! level, JT = 2 refers to the temperature
18014 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
18015 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
18016 ! to the reference pressure level (e.g. JP = 1 is for a
18017 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
18018 ! and tells us which g-interval the absorption coefficients are for.
18020 ! The array KA_Mxx contains the absorption coefficient for
18021 ! a minor species at the 16 chosen g-values for a reference pressure
18022 ! level below 100~ mb. The first index in the array, JS, runs
18023 ! from 1 to 10, and corresponds to different gas column amount ratios,
18024 ! as expressed through the binary species parameter eta, defined as
18025 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
18026 ! ratio of the reference MLS column amount value of gas 1
18027 ! to that of gas2. The second index refers to temperature
18028 ! in 7.2 degree increments. For instance, JT = 1 refers to a
18029 ! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index
18030 ! runs over the g-channel (1 to 16).
18032 ! The array FORREFO contains the coefficient of the water vapor
18033 ! foreign-continuum (including the energy term). The first
18034 ! index refers to reference temperature (296,260,224,260) and
18035 ! pressure (970,475,219,3 mbar) levels. The second index
18036 ! runs over the g-channel (1 to 16).
18038 ! The array SELFREFO contains the coefficient of the water vapor
18039 ! self-continuum (including the energy term). The first index
18040 ! refers to temperature in 7.2 degree increments. For instance,
18041 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
18042 ! etc. The second index runs over the g-channel (1 to 16).
18044 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
18046 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
18047 fracrefao, kao, kao_mn2, selfrefo, forrefo
18048 DM_BCAST_MACRO(fracrefao)
18049 DM_BCAST_MACRO(kao)
18050 DM_BCAST_MACRO(kao_mn2)
18051 DM_BCAST_MACRO(selfrefo)
18052 DM_BCAST_MACRO(forrefo)
18056 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
18057 CALL wrf_error_fatal(errmess)
18059 end subroutine lw_kgb15
18061 ! **************************************************************************
18062 subroutine lw_kgb16(rrtmg_unit)
18063 ! **************************************************************************
18065 use rrlw_kg16_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
18071 integer, intent(in) :: rrtmg_unit
18074 character*80 errmess
18075 logical, external :: wrf_dm_on_monitor
18077 ! Arrays fracrefao and fracrefbo are the Planck fractions for the lower
18078 ! and upper atmosphere.
18079 ! Planck fraction mapping levels:
18080 ! Lower: P = 387.6100 mbar, T = 250.17 K
18081 ! Upper: P=95.58350 mb, T = 215.70 K
18083 ! The array KAO contains absorption coefs for each of the 16 g-intervals
18084 ! for a range of pressure levels > ~100mb, temperatures, and ratios
18085 ! of water vapor to CO2. The first index in the array, JS, runs
18086 ! from 1 to 10, and corresponds to different gas column amount ratios,
18087 ! as expressed through the binary species parameter eta, defined as
18088 ! eta = gas1/(gas1 + (rat) * gas2), where rat is the
18089 ! ratio of the reference MLS column amount value of gas 1
18091 ! The 2nd index in the array, JT, which runs from 1 to 5, corresponds
18092 ! to different temperatures. More specifically, JT = 3 means that the
18093 ! data are for the reference temperature TREF for this pressure
18094 ! level, JT = 2 refers to the temperature
18095 ! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5
18096 ! is for TREF+30. The third index, JP, runs from 1 to 13 and refers
18097 ! to the reference pressure level (e.g. JP = 1 is for a
18098 ! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16,
18099 ! and tells us which g-interval the absorption coefficients are for.
18101 ! The array KBO contains absorption coefs at the 16 chosen g-values
18102 ! for a range of pressure levels < ~100mb and temperatures. The first
18103 ! index in the array, JT, which runs from 1 to 5, corresponds to
18104 ! different temperatures. More specifically, JT = 3 means that the
18105 ! data are for the reference temperature TREF for this pressure
18106 ! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for
18107 ! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30.
18108 ! The second index, JP, runs from 13 to 59 and refers to the JPth
18109 ! reference pressure level (see taumol.f for the value of these
18110 ! pressure levels in mb). The third index, IG, goes from 1 to 16,
18111 ! and tells us which g-interval the absorption coefficients are for.
18113 ! The array FORREFO contains the coefficient of the water vapor
18114 ! foreign-continuum (including the energy term). The first
18115 ! index refers to reference temperature (296,260,224,260) and
18116 ! pressure (970,475,219,3 mbar) levels. The second index
18117 ! runs over the g-channel (1 to 16).
18119 ! The array SELFREFO contains the coefficient of the water vapor
18120 ! self-continuum (including the energy term). The first index
18121 ! refers to temperature in 7.2 degree increments. For instance,
18122 ! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8,
18123 ! etc. The second index runs over the g-channel (1 to 16).
18125 #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE )
18127 IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) &
18128 fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo
18129 DM_BCAST_MACRO(fracrefao)
18130 DM_BCAST_MACRO(fracrefbo)
18131 DM_BCAST_MACRO(kao)
18132 DM_BCAST_MACRO(kbo)
18133 DM_BCAST_MACRO(selfrefo)
18134 DM_BCAST_MACRO(forrefo)
18138 WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit
18139 CALL wrf_error_fatal(errmess)
18141 end subroutine lw_kgb16
18143 !===============================================================================
18144 subroutine relcalc(icol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh)
18145 !-----------------------------------------------------------------------
18148 ! Compute cloud water size
18151 ! analytic formula following the formulation originally developed by J. T. Kiehl
18153 ! Author: Phil Rasch
18155 !-----------------------------------------------------------------------
18157 !------------------------------Arguments--------------------------------
18161 integer, intent(in) :: icol
18162 integer, intent(in) :: pcols, pver
18163 real, intent(in) :: landfrac(pcols) ! Land fraction
18164 real, intent(in) :: icefrac(pcols) ! Ice fraction
18165 real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m)
18166 real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean
18167 real, intent(in) :: t(pcols,pver) ! Temperature
18172 real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns)
18174 !---------------------------Local workspace-----------------------------
18176 integer i,k ! Lon, lev indices
18177 real tmelt ! freezing temperature of fresh water (K)
18178 real rliqland ! liquid drop size if over land
18179 real rliqocean ! liquid drop size if over ocean
18180 real rliqice ! liquid drop size if over sea ice
18182 !-----------------------------------------------------------------------
18190 ! jrm Reworked effective radius algorithm
18191 ! Start with temperature-dependent value appropriate for continental air
18192 ! Note: findmcnew has a pressure dependence here
18193 rel(icol,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(icol,k))*0.05))
18194 ! Modify for snow depth over land
18195 rel(icol,k) = rel(icol,k) + (rliqocean-rel(icol,k)) * min(1.0,max(0.0,snowh(icol)*10.))
18196 ! Ramp between polluted value over land to clean value over ocean.
18197 rel(icol,k) = rel(icol,k) + (rliqocean-rel(icol,k)) * min(1.0,max(0.0,1.0-landm(icol)))
18198 ! Ramp between the resultant value and a sea ice value in the presence of ice.
18199 rel(icol,k) = rel(icol,k) + (rliqice-rel(icol,k)) * min(1.0,max(0.0,icefrac(icol)))
18203 end subroutine relcalc
18204 !===============================================================================
18205 subroutine reicalc(icol, pcols, pver, t, re)
18208 integer, intent(in) :: icol, pcols, pver
18209 real, intent(out) :: re(pcols,pver)
18210 real, intent(in) :: t(pcols,pver)
18216 ! Tabulated values of re(T) in the temperature interval
18217 ! 180 K -- 274 K; hexagonal columns assumed:
18222 index = int(t(icol,k)-179.)
18223 index = min(max(index,1),94)
18224 corr = t(icol,k) - int(t(icol,k))
18225 re(icol,k) = retab(index)*(1.-corr) &
18226 +retab(index+1)*corr
18227 ! re(icol,k) = amax1(amin1(re(icol,k),30.),10.)
18232 end subroutine reicalc
18233 !------------------------------------------------------------------
18235 END MODULE module_ra_rrtmg_lwf