Changeset 2024 for LMDZ5/branches/testing/libf/dyn3dpar
- Timestamp:
- Apr 25, 2014, 7:11:59 PM (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ5/branches/testing/libf/dyn3dpar/guide_p_mod.F90
r1910 r2024 491 491 IF (f_out) THEN 492 492 ! Calcul niveaux pression milieu de couches 493 494 493 CALL pression_p( ip1jmp1, ap, bp, ps, p ) 494 if (pressure_exner) then 495 495 CALL exner_hyb_p(ip1jmp1,ps,p,alpha,beta,pks,pk,pkf) 496 496 else 497 497 CALL exner_milieu_p(ip1jmp1,ps,p,beta,pks,pk,pkf) 498 498 endif 499 499 unskap=1./kappa 500 501 502 503 504 505 506 507 CALL guide_out(" P",jjp1,llm,p(1:ip1jmp1,1:llm),1.)500 DO l = 1, llm 501 DO j=jjb_u,jje_u 502 DO i =1, iip1 503 p(i+(j-1)*iip1,l) = preff * ( pk(i,j,l)/cpp) ** unskap 504 ENDDO 505 ENDDO 506 ENDDO 507 CALL guide_out("SP",jjp1,llm,p(1:ip1jmp1,1:llm),1.) 508 508 ENDIF 509 509 … … 517 517 if (guide_zon) CALL guide_zonave(1,jjp1,llm,f_add) 518 518 CALL guide_addfield(ip1jmp1,llm,f_add,alpha_u) 519 IF (f_out) CALL guide_out("U",jjp1,llm,f_add(:,:),factt) 519 IF (f_out) CALL guide_out("u",jjp1,llm,ucov,factt) 520 IF (f_out) CALL guide_out("ua",jjp1,llm,(1.-tau)*ugui1(:,:)+tau*ugui2(:,:),factt) 521 IF (f_out) CALL guide_out("ucov",jjp1,llm,f_add(:,:)/factt,factt) 520 522 ucov(ijb_u:ije_u,:)=ucov(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) 521 523 endif … … 529 531 if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) 530 532 CALL guide_addfield(ip1jmp1,llm,f_add,alpha_T) 531 IF (f_out) CALL guide_out(" T",jjp1,llm,f_add(:,:),factt)533 IF (f_out) CALL guide_out("teta",jjp1,llm,f_add(:,:)/factt,factt) 532 534 teta(ijb_u:ije_u,:)=teta(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) 533 535 endif … … 541 543 if (guide_zon) CALL guide_zonave(2,jjp1,1,f_add(1:ip1jmp1,1)) 542 544 CALL guide_addfield(ip1jmp1,1,f_add(1:ip1jmp1,1),alpha_P) 543 IF (f_out) CALL guide_out(" SP",jjp1,1,f_add(1:ip1jmp1,1),factt)545 IF (f_out) CALL guide_out("ps",jjp1,1,f_add(1:ip1jmp1,1)/factt,factt) 544 546 ps(ijb_u:ije_u)=ps(ijb_u:ije_u)+f_add(ijb_u:ije_u,1) 545 547 CALL pression_p(ip1jmp1,ap,bp,ps,p) … … 555 557 if (guide_zon) CALL guide_zonave(2,jjp1,llm,f_add) 556 558 CALL guide_addfield(ip1jmp1,llm,f_add,alpha_Q) 557 IF (f_out) CALL guide_out(" Q",jjp1,llm,f_add(:,:),factt)559 IF (f_out) CALL guide_out("q",jjp1,llm,f_add(:,:)/factt,factt) 558 560 q(ijb_u:ije_u,:)=q(ijb_u:ije_u,:)+f_add(ijb_u:ije_u,:) 559 561 endif … … 568 570 if (guide_zon) CALL guide_zonave(2,jjm,llm,f_add(1:ip1jm,:)) 569 571 CALL guide_addfield(ip1jm,llm,f_add(1:ip1jm,:),alpha_v) 570 IF (f_out) CALL guide_out("V",jjm,llm,f_add(1:ip1jm,:),factt) 572 IF (f_out) CALL guide_out("v",jjm,llm,vcov(1:ip1jm,:),factt) 573 IF (f_out) CALL guide_out("va",jjm,llm,(1.-tau)*vgui1(:,:)+tau*vgui2(:,:),factt) 574 IF (f_out) CALL guide_out("vcov",jjm,llm,f_add(1:ip1jm,:)/factt,factt) 571 575 vcov(ijb_v:ije_v,:)=vcov(ijb_v:ije_v,:)+f_add(ijb_v:ije_v,:) 572 576 endif … … 784 788 IF (guide_plevs.EQ.1) THEN 785 789 DO l=1,llm 786 787 790 DO j=jjb_u,jje_u 791 DO i =1, iip1 788 792 pls(i,j,l)=(ap(l)+ap(l+1))/2.+psi(i,j)*(bp(l)+bp(l+1))/2. 789 790 793 ENDDO 794 ENDDO 791 795 ENDDO 792 796 ELSE 793 794 797 CALL pression_p( ip1jmp1, ap, bp, psi, p ) 798 if (pressure_exner) then 795 799 CALL exner_hyb_p(ip1jmp1,psi,p,alpha,beta,pks,pk,pkf) 796 800 else 797 801 CALL exner_milieu_p(ip1jmp1,psi,p,beta,pks,pk,pkf) 798 802 endif 799 800 801 802 803 804 805 806 803 unskap=1./kappa 804 DO l = 1, llm 805 DO j=jjb_u,jje_u 806 DO i =1, iip1 807 pls(i,j,l) = preff * ( pk(i,j,l)/cpp) ** unskap 808 ENDDO 809 ENDDO 810 ENDDO 807 811 ENDIF 808 812 … … 1024 1028 ! Calcul des nouvelles valeurs des niveaux de pression du guidage 1025 1029 IF (guide_plevs.EQ.1) THEN 1026 1027 1028 1029 1030 1031 1030 CALL Register_SwapFieldHallo(psnat1,psnat1,ip1jmp1,1,jj_Nb_caldyn,1,2,Req) 1031 CALL SendRequest(Req) 1032 CALL WaitRequest(Req) 1033 CALL Register_SwapFieldHallo(psnat2,psnat2,ip1jmp1,1,jj_Nb_caldyn,1,2,Req) 1034 CALL SendRequest(Req) 1035 CALL WaitRequest(Req) 1032 1036 DO l=1,nlevnc 1033 1037 DO j=jjb_v,jje_v … … 1041 1045 ENDDO 1042 1046 ELSE IF (guide_plevs.EQ.2) THEN 1043 1044 1045 1046 1047 1048 1047 CALL Register_SwapFieldHallo(pnat1,pnat1,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) 1048 CALL SendRequest(Req) 1049 CALL WaitRequest(Req) 1050 CALL Register_SwapFieldHallo(pnat2,pnat2,ip1jmp1,llm,jj_Nb_caldyn,1,2,Req) 1051 CALL SendRequest(Req) 1052 CALL WaitRequest(Req) 1049 1053 DO l=1,nlevnc 1050 1054 DO j=jjb_v,jje_v … … 1807 1811 1808 1812 ! Variables entree 1809 CHARACTER , INTENT(IN) :: varname1813 CHARACTER*(*), INTENT(IN) :: varname 1810 1814 INTEGER, INTENT (IN) :: hsize,vsize 1811 1815 REAL, DIMENSION (iip1,hsize,vsize), INTENT(IN) :: field … … 1817 1821 INTEGER :: nid, id_lonu, id_lonv, id_latu, id_latv, id_tim, id_lev 1818 1822 INTEGER :: vid_lonu,vid_lonv,vid_latu,vid_latv,vid_cu,vid_cv,vid_lev 1823 INTEGER :: vid_au,vid_av 1824 INTEGER :: l 1819 1825 INTEGER, DIMENSION (3) :: dim3 1820 1826 INTEGER, DIMENSION (4) :: dim4,count,start 1821 1827 INTEGER :: ierr, varid 1828 REAL, DIMENSION (iip1,hsize,vsize) :: field2 1822 1829 1823 1830 CALL gather_field(field,iip1*hsize,vsize,0) … … 1834 1841 ! Definition des dimensions 1835 1842 ierr=NF_DEF_DIM(nid,"LONU",iip1,id_lonu) 1843 print*,'id_lonu 1 ',id_lonu 1836 1844 ierr=NF_DEF_DIM(nid,"LONV",iip1,id_lonv) 1837 1845 ierr=NF_DEF_DIM(nid,"LATU",jjp1,id_latu) … … 1842 1850 ! Creation des variables dimensions 1843 1851 ierr=NF_DEF_VAR(nid,"LONU",NF_FLOAT,1,id_lonu,vid_lonu) 1852 print*,'id_lonu 2 ',id_lonu 1844 1853 ierr=NF_DEF_VAR(nid,"LONV",NF_FLOAT,1,id_lonv,vid_lonv) 1845 1854 ierr=NF_DEF_VAR(nid,"LATU",NF_FLOAT,1,id_latu,vid_latu) … … 1848 1857 ierr=NF_DEF_VAR(nid,"cu",NF_FLOAT,2,(/id_lonu,id_latu/),vid_cu) 1849 1858 ierr=NF_DEF_VAR(nid,"cv",NF_FLOAT,2,(/id_lonv,id_latv/),vid_cv) 1859 ierr=NF_DEF_VAR(nid,"au",NF_FLOAT,2,(/id_lonu,id_latu/),vid_au) 1860 ierr=NF_DEF_VAR(nid,"av",NF_FLOAT,2,(/id_lonv,id_latv/),vid_av) 1850 1861 1851 1862 ierr=NF_ENDDEF(nid) … … 1853 1864 ! Enregistrement des variables dimensions 1854 1865 #ifdef NC_DOUBLE 1866 print*,'id_lonu DOUBLE ',id_lonu,rlonu*180./pi 1855 1867 ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonu,rlonu*180./pi) 1856 1868 ierr = NF_PUT_VAR_DOUBLE(nid,vid_lonv,rlonv*180./pi) … … 1860 1872 ierr = NF_PUT_VAR_DOUBLE(nid,vid_cu,cu) 1861 1873 ierr = NF_PUT_VAR_DOUBLE(nid,vid_cv,cv) 1874 ierr = NF_PUT_VAR_DOUBLE(nid,vid_au,alpha_u) 1875 ierr = NF_PUT_VAR_DOUBLE(nid,vid_av,alpha_v) 1862 1876 #else 1877 print*,'id_lonu 3 ',id_lonu,rlonu*180./pi 1863 1878 ierr = NF_PUT_VAR_REAL(nid,vid_lonu,rlonu*180./pi) 1864 1879 ierr = NF_PUT_VAR_REAL(nid,vid_lonv,rlonv*180./pi) … … 1868 1883 ierr = NF_PUT_VAR_REAL(nid,vid_cu,cu) 1869 1884 ierr = NF_PUT_VAR_REAL(nid,vid_cv,cv) 1885 ierr = NF_PUT_VAR_REAL(nid,vid_au,alpha_u) 1886 ierr = NF_PUT_VAR_REAL(nid,vid_av,alpha_v) 1870 1887 #endif 1871 1888 ! -------------------------------------------------------------------- … … 1875 1892 ! Pressure (GCM) 1876 1893 dim4=(/id_lonv,id_latu,id_lev,id_tim/) 1877 ierr = NF_DEF_VAR(nid," P",NF_FLOAT,4,dim4,varid)1894 ierr = NF_DEF_VAR(nid,"SP",NF_FLOAT,4,dim4,varid) 1878 1895 ! Surface pressure (guidage) 1879 1896 IF (guide_P) THEN … … 1883 1900 ! Zonal wind 1884 1901 IF (guide_u) THEN 1902 print*,'id_lonu 4 ',id_lonu,varname 1885 1903 dim4=(/id_lonu,id_latu,id_lev,id_tim/) 1904 ierr = NF_DEF_VAR(nid,"u",NF_FLOAT,4,dim4,varid) 1905 ierr = NF_DEF_VAR(nid,"ua",NF_FLOAT,4,dim4,varid) 1886 1906 ierr = NF_DEF_VAR(nid,"ucov",NF_FLOAT,4,dim4,varid) 1887 1907 ENDIF … … 1889 1909 IF (guide_v) THEN 1890 1910 dim4=(/id_lonv,id_latv,id_lev,id_tim/) 1911 ierr = NF_DEF_VAR(nid,"v",NF_FLOAT,4,dim4,varid) 1912 ierr = NF_DEF_VAR(nid,"va",NF_FLOAT,4,dim4,varid) 1891 1913 ierr = NF_DEF_VAR(nid,"vcov",NF_FLOAT,4,dim4,varid) 1892 1914 ENDIF … … 1912 1934 ierr=NF_OPEN("guide_ins.nc",NF_WRITE,nid) 1913 1935 1936 IF (varname=="SP") timestep=timestep+1 1937 1938 IF (varname=="SP") THEN 1939 print*,'varname=SP=',varname 1940 ELSE 1941 print*,'varname diff SP=',varname 1942 ENDIF 1943 1944 1945 ierr = NF_INQ_VARID(nid,varname,varid) 1914 1946 SELECT CASE (varname) 1915 CASE ("P") 1916 timestep=timestep+1 1917 ierr = NF_INQ_VARID(nid,"P",varid) 1947 CASE ("SP","ps") 1918 1948 start=(/1,1,1,timestep/) 1919 1949 count=(/iip1,jjp1,llm,1/) 1920 #ifdef NC_DOUBLE 1921 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field) 1922 #else 1923 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field) 1924 #endif 1925 CASE ("SP") 1926 ierr = NF_INQ_VARID(nid,"ps",varid) 1927 start=(/1,1,timestep,0/) 1928 count=(/iip1,jjp1,1,0/) 1929 #ifdef NC_DOUBLE 1930 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt) 1931 #else 1932 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt) 1933 #endif 1934 CASE ("U") 1935 ierr = NF_INQ_VARID(nid,"ucov",varid) 1950 CASE ("v","va","vcov") 1951 start=(/1,1,1,timestep/) 1952 count=(/iip1,jjm,llm,1/) 1953 CASE DEFAULT 1936 1954 start=(/1,1,1,timestep/) 1937 1955 count=(/iip1,jjp1,llm,1/) 1956 END SELECT 1957 1958 SELECT CASE (varname) 1959 CASE("u","ua") 1960 DO l=1,llm ; field2(:,2:jjm,l)=field(:,2:jjm,l)/cu(:,2:jjm) ; ENDDO 1961 field2(:,1,:)=0. ; field2(:,jjp1,:)=0. 1962 CASE("v","va") 1963 DO l=1,llm ; field2(:,:,l)=field(:,:,l)/cv(:,:) ; ENDDO 1964 CASE DEFAULT 1965 field2=field 1966 END SELECT 1967 1938 1968 #ifdef NC_DOUBLE 1939 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)1969 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field2) 1940 1970 #else 1941 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)1971 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field2) 1942 1972 #endif 1943 CASE ("V")1944 ierr = NF_INQ_VARID(nid,"vcov",varid)1945 start=(/1,1,1,timestep/)1946 count=(/iip1,jjm,llm,1/)1947 #ifdef NC_DOUBLE1948 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)1949 #else1950 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)1951 #endif1952 CASE ("T")1953 ierr = NF_INQ_VARID(nid,"teta",varid)1954 start=(/1,1,1,timestep/)1955 count=(/iip1,jjp1,llm,1/)1956 #ifdef NC_DOUBLE1957 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)1958 #else1959 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)1960 #endif1961 CASE ("Q")1962 ierr = NF_INQ_VARID(nid,"q",varid)1963 start=(/1,1,1,timestep/)1964 count=(/iip1,jjp1,llm,1/)1965 #ifdef NC_DOUBLE1966 ierr = NF_PUT_VARA_DOUBLE(nid,varid,start,count,field/factt)1967 #else1968 ierr = NF_PUT_VARA_REAL(nid,varid,start,count,field/factt)1969 #endif1970 END SELECT1971 1973 1972 1974 ierr = NF_CLOSE(nid)
Note: See TracChangeset
for help on using the changeset viewer.
